;;; This is one of the example programs from the textbook
;;; by George F. Luger and William A. Stubblefield
;;; These functions implement the LISP based expert systems shell from chapter 14.
;;; top level interpreter loop. (ess) to start.
(defun ess ()
(declare (special *case-specific-data*))
(setq *case-specific-data* ())
(let (continue goal)
(terpri)
(format t "~%Continue ? (y/n) ")
(setq continue (read-char))
(cond ((equal continue #\n) (format t "~%~%~%========== Bye ==========~%~%~% ") t)
(t
(setq goal '(kind animal (var x)))
(print-solutions goal (solve goal (subst-record nil 0)))
(terpri)
(ess)))))
;;; 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 (terpri)(terpri)
(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)
(d
eclare (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)
(terpri)
(print query)
(write-string "? ")
(let ((answer (read-char)))
(cond ((equal answer #\y) 1)
((equal answer #\n) -1)
(t (terpri)
(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))))))
;;; This is the unification algorithm from section 7.6 of the text.
;;; recursive unification algorithm, takes two patterns and a list of
;;; substitutions found so far and returns either "failed" or the
;;; substitution-list augmented with those bindings needed for a match
(defun unify (pattern1 pattern2 substitution-list)
(cond ((equal substitution-list 'failed) 'failed)
((varp pattern1)
(match-var pattern1 pattern2 substitution-list))
((varp pattern2)
(match-var pattern2 pattern1 substitution-list))
((is-constant-p pattern1)
(cond ((equal pattern1 pattern2) substitution-list)
(t 'failed)))
((is-constant-p pattern2) 'failed)
(t (unify (cdr pattern1) (cdr pattern2)
(unify (car pattern1) (car pattern2)
substitution-list)))))
;;; will attempt to match a variable to a pattern, first
;;; checking for existing bindings on the variable, then
;;; performing an occurs check.
(defun match-var (var pattern substitution-list)
(cond ((equal var pattern) substitution-list)
(t (let ((binding (get-binding var substitution-list)))
(cond (binding
(unify (get-binding-value bindin
g)
pattern substitution-list))
((occursp var pattern) 'failed)
(t (acons var pattern substitution-list)))))))
;;; occursp will check if a variable occurs in a pattern.
(defun occursp (var pattern)
(cond ((equal var pattern) t)
((or (varp pattern) (is-constant-p pattern))
nil)
(t (or (occursp var (car pattern))
(occursp var (cdr pattern))))))
;;; is-constant-p determines if an item is a constant. In this simple
;;; program, we are assuming that all constants are atoms.
(defun is-constant-p (item)
(atom item))
(defun varp (item)
(and (listp item)
(equal (length item) 2)
(equal (car item) 'var)))
;;; get-binding takes a variable and a substitution list, and returns
;;; a (variable . binding-value) pair
(defun get-binding (var substitution-list)
(assoc var substitution-list :test #'equal))
;;; get-binding-value returns the binding value from
;;; a (variable . binding-value) pair
(defun get-binding-value (binding) (cdr binding))
;;; add-substitution adds a variable and a binding-value to a
;;; substitution-list
(defun add-substitution (var pattern substitution-list)
(acons var pattern substitution-list))
;;; These functions implement the basic stream handling operations
;;; with delayed evaluation, as used in chapter 14.
;;; force and delay allow us to control evaluation of expressions.
(defmacro delay (exp) `(function (lambda () ,exp)))
(defun force (function-closure) (funcall function-closure))
;;; Cons-stream adds a new first element to a stream
(defmacro cons-stream (exp stream)
`(cons ,exp (delay ,stream)))
;;; Head-stream returns the first element of the stream
(defun head-stream (stream)
(car stream))
;;; Tail-stream returns the stream with its first element deleted.
(defun tail-stream (stream)
(force (cdr stream)))
;;; Empty-stream-p is true if the stream is empty.
(defun empty-stream-p (stream)
(null stream))
;;; Make-empty-stream creates an empty stream.
(defun make-empty-stream ()
nil)
;;; Combine-streams appends two streams.
(defun combine-streams (stream1 stream2)
(cond ((empty-stream-p stream1) stream2)
(t (cons-stream (head-stream stream1)
(combine-streams (tail-stream stream1) stream2)))))
;;; Filter-stream
(defun filter-stream (stream test)
(cond ((empty-stream-p stream) (make-empty-stream))
((funcall test (head-stream stream))
(cons-stream (head-stream stream)
(filter-stream (tail-stream stream) test)))
(t (filter-stream (tail-stream stream) test))))
;;; map stream
(defun map-stream (stream func)
(cond ((empty-stream-p stream) (make-empty-stream))
(t (cons-stream (funcall func (head-stream stream))
(map-stream (tail-stream stream) func)))))
;;;==========================================
=================================
;;;===========================================================================
;;; This is the "trees" knowledge base for use with the expert system
;;; shell in section14.4 as the text.
;;;===========================================================================
;;;===========================================================================
(setq *assertions* '(
(rule ;;1
if (and (fur (var x)) (nurse (var x)))
then (mammal (var x)) 1)
(rule ;;2
if (and (feather (var x)) (lay-eggs (var x)))
then (bird (var x)) 1)
(rule ;;3
if (eat-meat (var x))
then (carnivores (var x)) 1)
(rule ;;4
if (and (mammal (var x)) (carnivores (var x)) (Claw (var x)))
then (Cats (var x)) .9)
(rule ;;5
if (and (bird (var x))(carnivores (var x)) (Claw (var x)))
then (Birds_of_prey (var x)) .9)
(rule ;;6
if (and (mammal (var x)) (have_hoof (var x)))
then (hoofed (var x)) .8)
(rule ;;7
if (and (hoofed (var x)) (Ruminant (var x)))
then (Cloven-hoofed (var x)) .7)
(rule ;;8
if (and (cats (var x)) (color (var x) yellow-brown) (mark (var) black_stripe))
then (kind (var x) tiger) .9)
(rule ;;9
if (and (cats (var x)) (color (var x) yellow-brown) (mark (var) black_spot))
then (kind (var x) Leopard) .9)
(rule ;;10
if (and (Cloven-hoofed (var x)) (mark (var) black_stripe))
then (kind (var x) zebra) .9)
(rule ;;11
if (and (Cloven-hoofed (var x)) (long_neck (var x)) (mark (var) black_spot))
then (kind (var x) Giraffe) .9)
(rule ;;12
if (and (bird (var x)) (swim (var x) yes) (fly (var x) no) (color (var x) black-white))
then (kind (var x) penguin) .9)
(rule ;;13
if (and (bird (var x)) (long_neck (var x)) (fly (var x) no) (color (var x) black-white))
then (kind (var x) Ostrich) .7)
(rule ;;14
if (and (Birds_of_prey (var x)) (swim (var x) yes) (fly (var x) yes))
then (kind (var x) Albatross) .6)
(rule ;;15
if (and (Birds_of_prey (var x)) (swim (var x) no) (fly (var x) yes))
then (kind (var x) Eagle) .6)
))
(setq *askables* '(
(fur (var x))
(nurse (var x))
(feather (var x))
(eat-meat (var x))
(Canine-tooth (var x))
(Claw (var x))
(fly (var x)(var y))
(lay-eggs (var x))
(swim (var x)(var y))
(color (var x)(var y))
(have_hoof (var x))
(Ruminant (var x))
(mark (var x)(var y))
(long_neck (var x))
))