home *** CD-ROM | disk | FTP | other *** search
/ rtsi.com / 2014.01.www.rtsi.com.tar / www.rtsi.com / OS9 / OSK / EFFO / forum3.lzh / LISP / prolog.lsp < prev    next >
Lisp/Scheme  |  1987-11-19  |  4KB  |  104 lines
  1. ;; The following is a tiny Prolog interpreter in MacLisp
  2. ;; written by Ken Kahn and modified for XLISP by David Betz.
  3. ;; It was inspired by other tiny Lisp-based Prologs of
  4. ;; Par Emanuelson and Martin Nilsson.
  5. ;; There are no side-effects anywhere in the implementation.
  6. ;; Though it is VERY slow of course.
  7.  
  8. (defun prolog (database &aux goal)
  9.        (do () ((not (progn (princ "Query?") (setq goal (read)))))
  10.               (prove (list (rename-variables goal '(0)))
  11.                      '((bottom-of-environment))
  12.                      database
  13.                      1)))
  14.  
  15. ;; prove - proves the conjunction of the list-of-goals
  16. ;;         in the current environment
  17.  
  18. (defun prove (list-of-goals environment database level)
  19.       (cond ((null list-of-goals) ;; succeeded since there are no goals
  20.              (print-bindings environment environment)
  21.              (not (y-or-n-p "More?")))
  22.             (t (try-each database database
  23.                          (cdr list-of-goals) (car list-of-goals)
  24.                          environment level))))
  25.  
  26. (defun try-each (database-left database goals-left goal environment level 
  27.                  &aux assertion new-enviroment)
  28.        (cond ((null database-left) nil) ;; fail since nothing left in database
  29.              (t (setq assertion
  30.                       (rename-variables (car database-left)
  31.                                         (list level)))
  32.                 (setq new-environment
  33.                       (unify goal (car assertion) environment))
  34.                 (cond ((null new-environment) ;; failed to unify
  35.                        (try-each (cdr database-left) database
  36.                                  goals-left goal
  37.                                  environment level))
  38.                       ((prove (append (cdr assertion) goals-left)
  39.                               new-environment
  40.                               database
  41.                               (+ 1 level)))
  42.                       (t (try-each (cdr database-left) database
  43.                                    goals-left goal
  44.                                    environment level))))))
  45.  
  46. (defun unify (x y environment &aux new-environment)
  47.        (setq x (value x environment))
  48.        (setq y (value y environment))
  49.        (cond ((variable-p x) (cons (list x y) environment))
  50.              ((variable-p y) (cons (list y x) environment))
  51.              ((or (atom x) (atom y))
  52.                   (cond ((equal x y) environment)
  53.                         (t nil)))
  54.              (t (setq new-environment (unify (car x) (car y) environment))
  55.                 (cond (new-environment (unify (cdr x) (cdr y) new-environment))
  56.                   (t nil)))))
  57.  
  58. (defun value (x environment &aux binding)
  59.        (cond ((variable-p x)
  60.               (setq binding (assoc x environment :test #'equal))
  61.               (cond ((null binding) x)
  62.                     (t (value (cadr binding) environment))))
  63.              (t x)))
  64.  
  65. (defun variable-p (x)
  66.        (and x (listp x) (eq (car x) '?)))
  67.  
  68. (defun rename-variables (term list-of-level)
  69.        (cond ((variable-p term) (append term list-of-level))
  70.              ((atom term) term)
  71.              (t (cons (rename-variables (car term) list-of-level)
  72.                       (rename-variables (cdr term) list-of-level)))))
  73.  
  74. (defun print-bindings (environment-left environment)
  75.        (cond ((cdr environment-left)
  76.               (cond ((= 0 (nth 2 (caar environment-left)))
  77.                      (prin1 (cadr (caar environment-left)))
  78.                      (princ " = ")
  79.                      (print (value (caar environment-left) environment))))
  80.               (print-bindings (cdr environment-left) environment))))
  81.  
  82. ;; a sample database:
  83. (setq db '(((father madelyn ernest))
  84.            ((mother madelyn virginia))
  85.        ((father david arnold))
  86.        ((mother david pauline))
  87.        ((father rachel david))
  88.        ((mother rachel madelyn))
  89.            ((grandparent (? grandparent) (? grandchild))
  90.             (parent (? grandparent) (? parent))
  91.             (parent (? parent) (? grandchild)))
  92.            ((parent (? parent) (? child))
  93.             (mother (? parent) (? child)))
  94.            ((parent (? parent) (? child))
  95.             (father (? parent) (? child)))))
  96.  
  97. ;; the following are utilities
  98. (defun y-or-n-p (prompt)
  99.        (princ prompt)
  100.        (eq (read) 'y))
  101.  
  102. ;; start things going
  103. (prolog db)
  104.