;;; 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 LISP based expert systems shell 
;;; from chapter 14.
;;; In order to produce the complete code for the expert system shell, 
;;; include the definition of unify (in the file "unification"), the stream 
;;; handling functions (in the file "stream functions").

;;; to run it on the trees knowledge base from chapter 14, evaluate
;;; the contents of the file trees_knowledge_base.lisp, and 
;;; start the interpreter by evaluating (lisp-shell)
;;; A sample initial query is: ( kind unknown-plant (var x))

;;; top level interpreter loop

(defun lisp-shell ()
  (declare (special *case-specific-data*))
   (setq *case-specific-data* ())
   (prin1 'lisp-shell> )
   (let ((goal (read)))
     (cond ((equal goal 'quit) 'bye)
       (t (print-solutions goal (solve goal (subst-record nil  0)))

;;; 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)
   (if (conjunctive-goal-p goal) 
      (cdr (body goal)) 
      (solve (car (body goal)) substitutions))
     (solve-simple-goal goal substitutions))
        #'(lambda (x) (< 0.2 (subst-cf x)))))

(defun solve-simple-goal (goal substitutions)
  (declare (special *assertions*))
  (declare (special *case-specific-data*))
   (told goal substitutions *case-specific-data*)
   (infer goal substitutions *assertions*)
   (ask-for goal substitutions)))

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

(defun filter-through-conj-goals (goals substitution-stream)
   (if (null goals) 
      (cdr goals) 
      (filter-through-goal (car goals) substitution-stream))))

(defun filter-through-goal (goal substitution-stream)
   (if (empty-stream-p substitution-stream) 
     (let ((subs (head-stream substitution-stream)))
        (map-stream (solve goal subs)
                    #'(lambda (x) ( subst-record (subst-list x) 
                                                 (min (subst-cf x) (subst-cf subs)))))
        (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) 
                           (subst-list substitutions))
                    (unify goal assertion (subst-list substitutions)))))
      (if (equal match 'failed)
        (infer goal substitutions (cdr kb))
        (if (rulep assertion)
           (solve-rule assertion (subst-record match (subst-cf substitutions)))
           (infer goal substitutions (cdr kb)))
          (cons-stream (subst-record match (fact-cf assertion)) 
                       (infer goal substitutions (cdr kb))))))))

(defun solve-rule (rule substitutions)
  (map-stream (solve (premise rule) substitutions)
              #'(lambda (x) (subst-record 
                             (subst-list x)
                             (* (subst-cf x) (rule-cf rule))))))
;;; 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 
                                       (subst-list (head-stream substitution-stream))))
           (write-string " cf = ")
           (prin1 (subst-cf (head-stream substitution-stream)))
           (terpri) (terpri)
           (print-solutions goal (tail-stream substitution-stream)))))


;;; rule functions     
;;; 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)))
(defun rule-cf (rule) (nth 5 rule))

;;; fact functions
;;; fact format is
;;; ( . CF)

(defun fact-pattern (fact) (car fact))

(defun fact-cf (fact) (cdr fact))

;;; substitutions format is
;;; ( . cf)

(defun subst-list (substitutions) (car substitutions))

(defun subst-cf (substitutions) (cdr substitutions))

(defun subst-record (substitutions cf) (cons substitutions cf))

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

;;; ask-for

(defun ask-for (goal substitutions)
  (declare (special *askables*))
  (declare (special *case-specific-data*))
  (if (askable goal *askables*) 
    (let* ((query (apply-substitutions goal (subst-list substitutions)))
           (result (ask-rec query)))
      (setq *case-specific-data* (cons (subst-record query result) 
      (cons-stream (subst-record (subst-list substitutions) result)

(defun ask-rec (query)
  (prin1 query)
  (write-string "  >")
   (let ((answer (read)))
     (cond ((equal answer 'y) 1)
           ((equal answer 'n) -1)
	   (t (print "answer must be y or n")
	      (ask-rec query)))))

(defun askable (goal askables)
   (cond ((null askables) nil)
         ((not (equal (unify goal (car askables) ()) 'failed)) t)
         (t (askable goal (cdr askables)))))

;;; told
 (defun told (goal substitutions case-specific-data)
    (if (null case-specific-data) (make-empty-stream)
        (let ((match (unify goal 
                            (fact-pattern (car case-specific-data)) 
                            (subst-list substitutions))))
          (if (equal match 'failed)
            (told goal substitutions (cdr case-specific-data))
             (subst-record match (fact-cf (car case-specific-data)))



Close Window