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 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)))
(terpri)
(cond ((equal goal 'quit) 'bye)
(t (print-solutions goal (solve goal (subst-record nil 0)))
(terpri)
(lisp-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)
(filter-stream
(if (conjunctive-goal-p goal)
(filter-through-conj-goals
(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*))
(or
(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)
substitution-stream
(filter-through-conj-goals
(cdr goals)
(filter-through-goal (car goals) substitution-stream))))
(defun filter-through-goal (goal substitution-stream)
(if (empty-stream-p substitution-stream)
(make-empty-stream)
(let ((subs (head-stream substitution-stream)))
(combine-streams
(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)
(make-empty-stream)
(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)
(combine-streams
(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)
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
(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*))
name))))
;;; 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)
*case-specific-data*))
(cons-stream (subst-record (subst-list substitutions) result)
(make-empty-stream)))))
(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")
(terpri)
(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))
(cons-stream
(subst-record match (fact-cf (car case-specific-data)))
(make-empty-stream))))))
Close Window