LISP

;;; This is one of the example programs from the textbook:
;;;
;;; Artificial Intelligence: 
;;; Structures and strategies for complex problem solving
;;;
;;; by George F. Luger and William A. Stubblefield
;;; 
;;; These programs are copyrighted by Benjamin/Cummings Publishers.
;;;
;;; We offer them for use, free of charge, for educational purposes only.
;;;
;;; Disclaimer: These programs are provided with no warranty whatsoever as to
;;; their correctness, reliability, or any other property.  We have written 
;;; them for specific educational purposes, and have made no effort
;;; to produce commercial quality computer programs.  Please do not expect 
;;; more of them then we have intended.
;;;

;;; These functions implement the logic programming interpreter 
;;; described in chapter 14.

;;; In order to produce the complete code for the logic interpreter, 
;;; include the definition of "unify" (the file "unification) and the 
;;; stream handling functions with delayed evaluation.

;;; After binding an appropriate set of assertions to the global
;;; variable *assertions*, a call to (logic-shell) will launch
;;; the query handler.

;;; top level interpreter loop

(defun logic-shell ()
  (print '> )
  (let ((goal (read)))
    (cond ((equal goal 'quit) 'bye)
          (t (print-solutions goal (solve goal nil))
             (terpri)
             (logic-shell)))))

;;; solve will take a single goal and a set of substitutions and return a
;;; stream of augmented substitutions that satisfy the goal.

(defun solve (goal substitutions)
  (declare (special *assertions*))
   (if (conjunctive-goal-p goal) 
     (filter-through-conj-goals (body goal) 
                                (cons-stream substitutions (make-empty-stream)))
     (infer goal substitutions *assertions*)))


;;; filter-through-conj-goals will take a list of goals and a stream of 
;;; substitutions and filter them through the goals one at a time,
;;; eliminating failures.

(defun filter-through-conj-goals (goals substitution-stream)
   (if (null goals) 
     substitution-stream
     (filter-through-conj-goals 
      (cdr goals) 
      (filter-through-goal (car goals) substitution-stream))))
	     
;;; filter-through-goal takes a goal (a pattern) and uses that goal as a 
;;; filter to a stream of substitutions.

(defun filter-through-goal (goal substitution-stream)
   (if (empty-stream-p substitution-stream) 
     (make-empty-stream)
     (combine-streams 
      (solve goal (head-stream substitution-stream))
      (filter-through-goal goal (tail-stream substitution-stream)))))

;;; infer will take a goal, a set of substitutions and a knowledge base
;;; and attempt to infer the goal from the kb

(defun infer (goal substitutions kb)
  (if (null kb) 
    (make-empty-stream)
    (let* ((assertion (rename-variables (car kb)))
           (match (if (rulep assertion)
                    (unify goal (conclusion assertion) substitutions)
                    (unify goal assertion substitutions))))
      (if (equal match 'failed)
        (infer goal substitutions (cdr kb))
        (if (rulep assertion)
          (combine-streams 
           (solve (premise assertion) match)
           (infer goal substitutions (cdr kb)))
          (cons-stream match (infer goal substitutions (cdr kb))))))))

;;; apply-substitutions will return the result of applying a
;;; set of substitutions to a pattern.

(defun apply-substitutions (pattern substitution-list)
  (cond ((is-constant-p pattern) pattern)
	((varp pattern)
	    (let ((binding (get-binding pattern substitution-list)))
	       (cond (binding (apply-substitutions 
				(get-binding-value binding)
				substitution-list))
		     (t pattern))))
	(t (cons (apply-substitutions (car pattern) substitution-list)
	         (apply-substitutions (cdr pattern) substitution-list)))))

;;; print solutions will take a goal and a stream of substitutions and
;;; print that goal with each substitution in the stream

(defun print-solutions (goal substitution-stream)
    (cond ((empty-stream-p substitution-stream) nil)
	  (t (print (apply-substitutions goal 
					 (head-stream substitution-stream)))
	     (terpri)
	     (print-solutions goal (tail-stream substitution-stream)))))


;;; rule format is 
;;; (rule if  then )

(defun premise (rule) (nth 2 rule))

(defun conclusion (rule) (nth 4 rule))

(defun rulep (pattern) 
   (and (listp pattern)
	(equal (nth 0 pattern) 'rule)))

;;; conjunctive goals are goals of the form 
;;; (and   ... )

(defun conjunctive-goal-p (goal)
   (and (listp goal)
        (equal (car goal) 'and)))

(defun body (goal) (cdr goal))

;;; rename variables will take an assertion and rename all its 
;;; variables using gensym

(defun rename-variables (assertion)
  (declare (special *name-list*))
   ;(declare special *name-list*)
   (setq *name-list* ()) 
   (rename-rec assertion))

(defun rename-rec (exp)
   (cond ((is-constant-p exp) exp)
	 ((varp exp) (rename exp))
	 (t (cons (rename-rec (car exp))
		  (rename-rec (cdr exp))))))

(defun rename (var)
   (declare (special *name-list*))
   (list 'var (or (cdr (assoc var *name-list* :test #'equal))
                  (let ((name (gensym))) 
		     (setq *name-list* (acons var name *name-list*))
	             name))))


  

Close Window