;;; 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))

;;; 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) 
      (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) 
      (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) 
    (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)
           (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)
		     (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)))
	     (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*))


Close Window