Написание программы на ЛИСПе (Хищник и его свойства)

;; [url]http://forum.ru-board.com/topic.cgi?forum=33&topic=9177[/url]
 
(defstruct правило им_ услови_ выводы)
(make-правило
  :им_     'ПРАВИЛО9
  :услови_ '(
              (высота полёта до 50 м)
            )
  :выводы  '(
              (птица Воробей)
            )
)
(setq ПРАВИЛО1
  '(ЕСЛИ размах крыльев до 2.4 м
    ТО птица Орёл)
)
(setq ПРАВИЛО2
  '(ЕСЛИ окраска оперени_ чёрно-бела_
    ТО птица Орёл)
)
(setq ПРАВИЛО3
  '(ЕСЛИ высота полёта до 1500 м
    ТО птица Орёл)
)
(setq ПРАВИЛО4
  '(ЕСЛИ размах крыльев до 1.2 м
    ТО птица Сокол)
)
(setq ПРАВИЛО5
  '(ЕСЛИ окраска оперени_ тёмна_
    ТО птица Сокол)
)
(setq ПРАВИЛО6
  '(ЕСЛИ высота полёта до 2000 м
    ТО птица Сокол)
)
 
(setq ПРАВИЛО7
  '(ЕСЛИ размах крыльев до 0.25 м
    ТО птица Воробей)
)
(setq ПРАВИЛО8
  '(ЕСЛИ окраска оперени_ коричнева_
    ТО птица Воробей)
)
(setq ПРАВИЛО9
  '(ЕСЛИ высота полёта до 50 м
    ТО птица Воробей)
)
;Функци_ дл_ добавлени_ элемента в конец списка
(defun присоедини (x y)  
  (append x (list y))
)
;Анализирует правила и составл_ет из них список
(defun анализируй (правила)
  (mapcar (function анализируй-правило) правила)
)
;Преобразует правило в форме предложени_ в структуру
(defun анализируй-правило (им_)
  (let ((правило (eval им_)))
    (make-правило  
      :им_ им_
      :услови_ (услови_ правило)
      :выводы (выводы правило)
    )
  )
)
;Возвращает услови_ в виде списка
(defun услови_ (предложение)
  (предложение-и (cdr предложение) nil nil)
)
 
;Возвращает выводы в виде списка
(defun выводы (предложение)
  (предложение-и (cdr (member 'то предложение)) nil nil)
)
 
;Выдел_ет предложени_, раздел_емые символом И
(defun предложение-и (предложение часть результат)
  (cond
    (
      (null предложение) ;; условие окончани_  
      (присоедини результат часть)
    )  
    (
      (eq (car предложение) 'то) ;; условие окончани_  
      (присоедини результат часть)
    )
    (
      (eq (car предложение) 'и) ;; новое предложение  
      (предложение-и  
        (cdr предложение)  
        nil
        (присоедини результат часть)
      )
    )
    (
      t ; следующее слово
      (предложение-и  
        (cdr предложение)
        (присоедини часть  (car предложение))
        результат
      )
    )
  )
)
(setq *база-знаний*
  '(ПРАВИЛО1 ПРАВИЛО2 ПРАВИЛО3 ПРАВИЛО4 ПРАВИЛО5
    ПРАВИЛО6 ПРАВИЛО7 ПРАВИЛО8 ПРАВИЛО9)
)
(setq *правила* (анализируй *база-знаний*))
;Провер_ет, применимо ли правило
(defun проверь-правило (правило)
  (подмножество (правило-услови_ правило) *факты*)
)
 
;Провер_ет, _вл_етс_ ли множество подмножеством
(defun подмножество (подмножество множество)
  (equal  
    подмножество
    (intersection подмножество множество)
  )
)
 
(defmacro mypush (v l)
    `(setf ,l (cons ,v ,l))
)
 
 
;Расшир_ет список фактов выводами правила
(defun добавь-выводы (правило)
  (do ((выводы (правило-выводы правило) (cdr выводы)))
    ((null выводы) *факты*)
    (if (member (car выводы) *факты*)
      nil
      (progn
        (format t "Согласно правилу ~S : " (правило-им_ правило))
        (выведи-элементы (car выводы))
        (mypush (car выводы) *факты*)
      )
    )
  )
)
 
;Выводит элементы списка
(defun выведи-элементы (список)
  (dotimes (i (length список))
    (princ (nth i список))
    (princ " ")
  )
  (terpri)
  t
)
(setq *гипотезы*
  '(
    (птица Орёл)
    (птица Сокол)
    (птица Воробей)
  )
)
(setq *факты* nil)
(setq *запросы* nil)
 
;;; Глобальные динамические переменнне
(defvar *гипотезы*)  ; значение определено выше
(defvar *правила*)   ; значение определено выше
(defvar *факты*)     ; значение определено выше
(defvar *запросы*)   ; значение определено выше
 
;;; Главна_ программа Птички
(defun Птички ()  ; Экспертна_ система дл_ распознавани_ птиц
  (setq *факты* nil)
  (setq *запросы* nil)
  (знаток-птиц *гипотезы*)
)
 
;Пытаетс_ проверить какую-нибудь гипотезу
(defun знаток-птиц (гипотезы)  
  (cond
    (
      (null гипотезы)
      "Не могу доказать никакую из известных мне гипотез"
    )
    (
      (докажи (car гипотезы))
      (car гипотезы)   ; результат
    )
    (
      t
      (знаток-птиц (cdr гипотезы)) ; нова_ попытка
    )
  )
)
(defun докажи (гипотеза)
  (let ((прав nil))
    (cond
      ((member гипотеза *факты*) t)            ; ветвь 1
      (
        (setq прав (возможные гипотеза))       ; ветвь 2
        (if (пр_мо гипотеза прав)  
          t
          (рекурсивно гипотеза прав)
        )
      )
      (
        t                                      ; ветвь 3
        (ветка3 гипотеза)
      )
    )
  )
)
 
(defun ветка3 (гипотеза)
  (cond
    ((member гипотеза *запросы*) nil)    
    (
      (and
        (princ "Это правда, что: ")
        (выведи-элементы гипотеза)
        (eq (read) 'Да)
      )
      (setq *факты* (union (list гипотеза) *факты*))  
      t
    )
    (
      t
      (mypush гипотеза *запросы*)
      nil
    )
  )
)
 
(defun возможные (гипотеза)
  (let ((result nil))
    (dotimes (i (length *правила*) result)
      (when (member  
               гипотеза (правило-выводы (nth i *правила*))
               :test (function equal)
               )
         (setq result (append result (list (nth i *правила*))))
      )
    )
  )
)
 
;Провер_ет, можно ли доказать гипотезу непосредственно
;при помощи какого-нибудь правила
(defun пр_мо (гипотеза возможные)
  (cond
    ((null возможные) nil)
    ((null *факты*) nil)
    (
      (проверь-правило (car возможные))
      (добавь-выводы (car возможные))
    )
    (
      t
      (пр_мо гипотеза (cdr возможные))
    )
  )
)
 
;Рекурсивно провер_ет гипотезу
(defun рекурсивно (гипотеза возможные)
  (cond
    ((null возможные) nil)
    (
      (проверь-непр_мо (правило-услови_ (car возможные)))
      (добавь-выводы (car возможные))
    )
    (
      t
      (рекурсивно гипотеза (cdr возможные))
    )
  )
)
 
;Рекурсивно провер_ет все услови_
(defun проверь-непр_мо (услови_)
  (every (function докажи) услови_)
)