4

(setf *database* ())

(defun add-record (&key d n pt)
    (setf *database* (cons (list :destination d :id n :plan-type pt) *database*)))

(defun printAll (&optional (outstr NIL))
    (dolist (item *database*)
        (print item outstr)))

(add-record :d "Moscow" :n 7 :pt "Boeing 747-8")
(add-record :d "Paris" :n 8 :pt "Boeing 747-400")
(add-record :d "Sicily" :n 6 :pt "Boeing 777")
(add-record :d "Bahia" :n 7 :pt "Boeing 777")
(add-record :d "San jose" :n 8 :pt "Boeing 747-8")
(add-record :d "Paris" :n 6 :pt "Boeing 737")
(add-record :d "Majorca" :n 7 :pt "Boeing 747-8")
(add-record :d "Büchen" :n 8 :pt "Boeing 747-400")
(add-record :d "Cologne" :n 6 :pt "Boeing 787")

(defun match (p d)   (cond      
                         ;;правило 1     
                         ((and (null p)(null d)) t)     
                         ;;правило 2     
                         ((and (null d)           
                               (eq (car p) '$)           
                               (null (cdr p))) t)          
                         ;;один из списков исчерпан     
                         ((or (null p)(null d)) nil)          
                         ;;правило 3 и правило 4     
                         ((or (equal (car p) '?)          
                              (equal (car p) (car d)))      
                          (match (cdr p)(cdr d)))          
                         ;;правило 5 и 6     
                         ((eq (car p) '$)      
                          (cond ((match (cdr p) d) t)        
                              ((match p (cdr d)) t)))          
                         ;;правило 7 - сопоставление списков,включающих подсписки     
                         ((and (not (atom (car p)))           
                               (not (atom (car d)))           
                               (match (car p)(car d)))      
                          (match (cdr p) (cdr d)))          
                         ;;правило 8 – подстановка значения в переменную      
                         ;;пример вызова:(match '(AVTO ?MODEL ?YEAR) '(AVTO ford 1998))     
                         ;;MODEL=ford, YEAR=1998     
                         ((and (atom (car p))           
                               (eq (car-letter (car p)) #\?)           
                               (match (cdr p)(cdr d)))      
                          (set  (cdr-name (car p)) (car d)) t) 
                         ;;правило 9 - подстановка сегмента значений в переменную      
                         ;;пример вызова: (match '(?F $V) '(Petrov 1975 5 October))     
                         ;;F=Petrov, V=(1975 5 October)     
                         ((and (atom (car p))           
                               (eq (car-letter (car p)) #\$))      
                               (cond ((match (cdr p)(cdr d))             
                                      (set (cdr-name (car p)) (list (car d))) t)        
                                   ((match p (cdr d))         
                                    (set (cdr-name (car p))              
                                         (cons (car d)(eval (cdr-name (car p))))) t)))          
                         ;; правило 10 - обработка пакета ограничений, если в пакете есть «?»     
                         ((and (not(atom (car p)))           
                               (eq (caar p)  'restrict)           
                               (eq (cadar p) '?)           
                               (and-to-list  
                                   (mapcar  #'(lambda (pred)                         
                                                  (funcall pred (car d))) (cddar p))))      
                          (match (cdr p)(cdr d)))          
                         ;; правило 11 - обработка пакета ограничений, если в пакете есть «?V»     
                         ;; например: (match '((restrict  ?V  integerp  evenp) b c) '(36  b  c))     
                         ((and (not (atom (car p)))           
                               (not (atom  d))           
                               (eq (caar p)  'restrict)           
                               (eq (car-letter (cadar p)) #\?)           
                               (and-to-list             
                                (mapcar  #'(lambda (pred)                         
                                                   (funcall pred (car d))) (cddar p)))           
                               (match (cdr p)(cdr d)))      
                               (set (cdr-name (cadar p)) (car d)) t))) 
;;;;<2. Вспомогательные функции 
;;; выделение первой литеры из имени 
(defun car-letter (x) 
    (if (not (numberp x)) 
        (car (coerce (string x) 'list)))) 
;;; возвращает имя без первой 
(defun cdr-name (x) (intern  (coerce (cdr (coerce (string x) 'list)) 'string))) 
;;; проверяет,  все ли элементы списка lis имеют значение T 
(defun and-to-list ( lis )   
    ;lis - список логических значений    
    (let ((res t))   
         (dolist (temp lis res)     
             (setq res (and res temp)))))

(defun get-matches (p db)    
    ;db - база данных    
    ;p  - запрос (образец)    
    (cond ((null db) nil)              
        ((match p (car db))               
         (cons (car db) (get-matches p (cdr db))))              
        (t (get-matches p (cdr db)))))

(defun answer-generator()
    (setf fact (read))
    (cond
        ;(Выведи все записы пожалуйста)
        ((match '($ все записы $) fact)
         (setf matches (get-matches '(:destination ? :id ? :plan-type ?) *database*))
         (print "All fligts:")
         (dolist (item matches) 
             (print (getf item :id))
             (prin1 (getf item :destination))
             (prin1 (getf item :plan-type))))
        ;(where can I fly using boeing 777)
        ((match '($ where $ boeing 777 $) fact)
         (setf matches (get-matches '(:destination ? :id ? :plan-type "Boeing 777") *database*))
         (princ "You can visit this towns: ")
         (dolist (item matches) 
             (princ (getf item :destination))
             (princ ", ")))
        ;(what can you say about flight number 8)
        ((match '($ what $ say about $ number ?number $) fact)
         (get-matches `(:destination ?dest :id ,number :plan-type ?type) *database*)
         (princ type)
         (princ " flying in ")
         (princ dest))
        ;(what can you say about flights in "Paris")
        ((match '($ what $ say about $ flights in $ ?dest $) fact)
         (setf matches (get-matches `(:destination ,dest :id ? :plan-type ?) *database*))
         (princ "You can visit ")
         (princ dest)
         (princ " by flight numbers ")
         (dolist (item matches)
             (princ (getf item :id))
             (princ ", "))
         (princ " using ")
         (dolist (item matches)
             (princ (getf item :plan-type))
             (princ ", "))
         (princ "respectively"))
        (t (princ "Unknown request"))))

(answer-generator)