;--------------------------------------------------
; basic backward chainer with matching rules
;--------------------------------------------------
(defvar *rules*) ;; the rule set - specified by user
(defvar *facts*) ;; used internally to hold fact-base
(defvar *goals*) ;; used internally for goal stack
;=============================
; goal stack stuff
;=============================
(defun post-facts (facts)
; post some new facts on the goal stack
; (use reverse so they are in the order specified)
(mapc #'post-fact (reverse facts)))
(defun post-fact (f)
; post a single fact on the goal stack
(push `(fact ,f) *goals*))
(defun post-rule (r f)
; post a rule on the goal stack
; assume an expanded rule,
; antecedents are pushed after the rule
(push `(rule ,r ,f) *goals*)
(post-facts (antecedents-of r)))
(defun is-fact (g)
; used to check if new goal is a fact
(eq 'fact (first g)))
(defun is-rule (g)
; used to check if new goal is a rule
(eq 'rule (first g)))
(defun print-goal-stack ()
(format t "~&goal stack....")
(pprint *goals*)
(format t "~&")
)
;=============================
; rule handling
;=============================
(defmatch antecedents-of ((rule ?id ??antecedents => ??consequents))
#?antecedents)
(defmatch antecedents-of (?r)
(error "badly formed rule ~a" #?r))
(defmatch consequents-of ((rule ?id ??antcedents => ??consequents))
#?consequents)
(defmatch consequents-of (?r)
(error "badly formed rule ~a" #?r))
(defmatch name-of ((rule ?id ??antcedents => ??consequents))
#?id)
(defmatch name-of (?r)
(error "badly formed rule ~a" #?r))
;___ firing rules ______________________
;---------------------------------------
(defmatch try-rule ((rule ?r ?f))
;
; this tries to fire a rule, if it fires its consequents are
; added to facts. If it doesnt fire the next suitable rule in
; the ruleset is stacked.
; If there is no suitable rule left, the chainer fails
;
(format t "trying rule ~a~&" #?r)
(format t " with ~a~&"*facts*)
(let ((newf (apply-rule #?r *facts*)))
(if* newf
then (format t " ==> ~a~%~%" newf)
(mapc #'(lambda (n) (setf *facts* ($+ n *facts*))) newf)
else
;; get remaining rules from rule-set
(format t " rule ~a fails~%~%" (name-of #?r))
(stack-next-rule (remaining-rules #?r) #?f)
)))
(defun apply-rule (r facts)
;(format t "applying ~a ~&" r)
;(format t " over ~a ~&" facts)
(or (forevery ((antecedents-of r) facts)
;(format t "rule ~a ok => ~a~&" (name-of r)(consequents-of r))
(match>> (consequents-of r)))
(progn
;(format t "rule ~a fails~&" (name-of r))
nil
)))
(defun expand-rule (r f)
;
; matches fact to rule consequents then expands any bound
; match vars throughout entire rule
;
(let ((b (some #'(lambda (c) (matches c f)) (consequents-of r))))
(when b (m>> r b))
))
(defun stack-next-rule (rules f)
;
; find the next rule that can be used to assert current fact
; and post it on the goal stack
;
(let ((r (some #'(lambda (r) (expand-rule r f)) rules)))
(if* (null r)
then (format t "no applicable rules for ~a" f)
else (post-rule r f)
)))
(defun remaining-rules (r)
;
; finds r in *rules* & returns all rules sequentially after r
; r can be expanded or unexpanded
;
(rest (member r *rules*
:test #'(lambda (x y)
(eq (name-of x) (name-of y)))
)))
(defmatch try-fact ((fact ?f))
(format t "trying fact ~a~&" #?f)
(or (member #?f *facts* :test #'equal) ; either fact already known
(stack-next-rule *rules* #?f)) ; or try anty useful rules
)
;--- modified matcher fn ---------------
; this version leaves ?var as ?var if var has no match binding
; matcher version dumps unbound match vars as nil
(defun m>> (pat &optional (bind nil))
;;(format t "~&bind= ~a~%" bind)
(let* (sym val)
(cond ((null pat) nil)
((listp (car pat))
(cons (m>> (car pat) bind)
(m>> (cdr pat) bind))
)
((and (setf sym (matcher::check-prefix (car pat) '??))
(setf val (matcher::getbinding bind sym)))
(append val (m>> (cdr pat) bind))
)
((and (setf sym (matcher::check-prefix (car pat) '?))
(setf val (matcher::getbinding bind sym)))
(cons val (m>> (cdr pat) bind))
)
( t
(cons (car pat) (m>> (cdr pat) bind))
))
))
;=============================
; top level stuff
;=============================
(defun match-fire-cycle ()
(let ((g (pop *goals*)))
(format t "~&new goal ==> ~a~&" g)
(if* (is-fact g)
then (try-fact g)
elseif (is-rule g)
then (try-rule g)
else
(error "whoops: bad goal ~a" g)
))
(print-goal-stack)
)
;___ firing rules ______________________
;---------------------------------------
;; this is what you call
(defun bwd-chain (goal facts)
;
; assumes *rules* correctly set up
;
(setf *goals* nil)
(setf *facts* facts)
(post-fact goal)
(print-goal-stack)
(until (null *goals*)
(match-fire-cycle))
*facts*)
;--------------------------------------------------
; sample rules & facts
;--------------------------------------------------
(setf *rules*
'((rule 1 (has ?x warm-blood) => (is ?x mammal))
(rule 2 (is ?x mammal) (has ?x hoofs)
=> (is ?x ungulate))
(rule 3 (is ?x ungulate) (chews ?x cud) (goes ?x moo)
=> (is ?x cow))
(rule 4 (lives-in ?x pasture) (eats ?x grass)
=> (chews ?x cud) (is ?x herbivore))
(rule 5 (has ?x hair) => (is ?x mammal))
(rule 6 (gives ?x milk) => (is ?x mammal))
(rule 7 (is ?x herbivore) (is ?x ungulate) (gives ?x milk)
=> (is ?x cow))
))
;;; some sample facts
(defparameter *facts1*
'((gives daisy milk)
(lives-in daisy pasture)
(has daisy hair)
(eats daisy grass)
(has daisy hoofs)
))
;--------------------------------------------------
; sample output
;--------------------------------------------------
cg-user(68): (bwd-chain '(is daisy cow) *facts1*)
goal stack....
((fact (is daisy cow)))
new goal ==> (fact (is daisy cow))
trying fact (is daisy cow)
goal stack....
((fact (is daisy ungulate)) (fact (chews daisy cud)) (fact (goes daisy moo))
(rule (rule 3 (is daisy ungulate) (chews daisy cud) (goes daisy moo) => (is daisy cow)) (is daisy cow)))
new goal ==> (fact (is daisy ungulate))
trying fact (is daisy ungulate)
goal stack....
((fact (is daisy mammal)) (fact (has daisy hoofs))
(rule (rule 2 (is daisy mammal) (has daisy hoofs) => (is daisy ungulate)) (is daisy ungulate)) (fact (chews daisy cud))
(fact (goes daisy moo))
(rule (rule 3 (is daisy ungulate) (chews daisy cud) (goes daisy moo) => (is daisy cow)) (is daisy cow)))
new goal ==> (fact (is daisy mammal))
trying fact (is daisy mammal)
goal stack....
((fact (has daisy warm-blood)) (rule (rule 1 (has daisy warm-blood) => (is daisy mammal)) (is daisy mammal))
(fact (has daisy hoofs)) (rule (rule 2 (is daisy mammal) (has daisy hoofs) => (is daisy ungulate)) (is daisy ungulate))
(fact (chews daisy cud)) (fact (goes daisy moo))
(rule (rule 3 (is daisy ungulate) (chews daisy cud) (goes daisy moo) => (is daisy cow)) (is daisy cow)))
new goal ==> (fact (has daisy warm-blood))
trying fact (has daisy warm-blood)
no applicable rules for (has daisy warm-blood)
goal stack....
((rule (rule 1 (has daisy warm-blood) => (is daisy mammal)) (is daisy mammal)) (fact (has daisy hoofs))
(rule (rule 2 (is daisy mammal) (has daisy hoofs) => (is daisy ungulate)) (is daisy ungulate)) (fact (chews daisy cud))
(fact (goes daisy moo))
(rule (rule 3 (is daisy ungulate) (chews daisy cud) (goes daisy moo) => (is daisy cow)) (is daisy cow)))
new goal ==> (rule (rule 1 (has daisy warm-blood) => (is daisy mammal)) (is daisy mammal))
trying rule (rule 1 (has daisy warm-blood) => (is daisy mammal))
with ((gives daisy milk) (lives-in daisy pasture) (has daisy hair) (eats daisy grass) (has daisy hoofs))
rule 1 fails
goal stack....
((fact (has daisy hair)) (rule (rule 5 (has daisy hair) => (is daisy mammal)) (is daisy mammal)) (fact (has daisy hoofs))
(rule (rule 2 (is daisy mammal) (has daisy hoofs) => (is daisy ungulate)) (is daisy ungulate)) (fact (chews daisy cud))
(fact (goes daisy moo))
(rule (rule 3 (is daisy ungulate) (chews daisy cud) (goes daisy moo) => (is daisy cow)) (is daisy cow)))
new goal ==> (fact (has daisy hair))
trying fact (has daisy hair)
goal stack....
((rule (rule 5 (has daisy hair) => (is daisy mammal)) (is daisy mammal)) (fact (has daisy hoofs))
(rule (rule 2 (is daisy mammal) (has daisy hoofs) => (is daisy ungulate)) (is daisy ungulate)) (fact (chews daisy cud))
(fact (goes daisy moo))
(rule (rule 3 (is daisy ungulate) (chews daisy cud) (goes daisy moo) => (is daisy cow)) (is daisy cow)))
new goal ==> (rule (rule 5 (has daisy hair) => (is daisy mammal)) (is daisy mammal))
trying rule (rule 5 (has daisy hair) => (is daisy mammal))
with ((gives daisy milk) (lives-in daisy pasture) (has daisy hair) (eats daisy grass) (has daisy hoofs))
==> (((is daisy mammal)))
goal stack....
((fact (has daisy hoofs)) (rule (rule 2 (is daisy mammal) (has daisy hoofs) => (is daisy ungulate)) (is daisy ungulate))
(fact (chews daisy cud)) (fact (goes daisy moo))
(rule (rule 3 (is daisy ungulate) (chews daisy cud) (goes daisy moo) => (is daisy cow)) (is daisy cow)))
new goal ==> (fact (has daisy hoofs))
trying fact (has daisy hoofs)
goal stack....
((rule (rule 2 (is daisy mammal) (has daisy hoofs) => (is daisy ungulate)) (is daisy ungulate)) (fact (chews daisy cud))
(fact (goes daisy moo))
(rule (rule 3 (is daisy ungulate) (chews daisy cud) (goes daisy moo) => (is daisy cow)) (is daisy cow)))
new goal ==> (rule (rule 2 (is daisy mammal) (has daisy hoofs) => (is daisy ungulate)) (is daisy ungulate))
trying rule (rule 2 (is daisy mammal) (has daisy hoofs) => (is daisy ungulate))
with ((is daisy mammal) (gives daisy milk) (lives-in daisy pasture) (has daisy hair) (eats daisy grass)
(has daisy hoofs))
==> (((is daisy ungulate)))
goal stack....
((fact (chews daisy cud)) (fact (goes daisy moo))
(rule (rule 3 (is daisy ungulate) (chews daisy cud) (goes daisy moo) => (is daisy cow)) (is daisy cow)))
new goal ==> (fact (chews daisy cud))
trying fact (chews daisy cud)
goal stack....
((fact (lives-in daisy pasture)) (fact (eats daisy grass))
(rule (rule 4 (lives-in daisy pasture) (eats daisy grass) => (chews daisy cud) (is daisy herbivore)) (chews daisy cud))
(fact (goes daisy moo))
(rule (rule 3 (is daisy ungulate) (chews daisy cud) (goes daisy moo) => (is daisy cow)) (is daisy cow)))
new goal ==> (fact (lives-in daisy pasture))
trying fact (lives-in daisy pasture)
goal stack....
((fact (eats daisy grass))
(rule (rule 4 (lives-in daisy pasture) (eats daisy grass) => (chews daisy cud) (is daisy herbivore)) (chews daisy cud))
(fact (goes daisy moo))
(rule (rule 3 (is daisy ungulate) (chews daisy cud) (goes daisy moo) => (is daisy cow)) (is daisy cow)))
new goal ==> (fact (eats daisy grass))
trying fact (eats daisy grass)
goal stack....
((rule (rule 4 (lives-in daisy pasture) (eats daisy grass) => (chews daisy cud) (is daisy herbivore)) (chews daisy cud))
(fact (goes daisy moo))
(rule (rule 3 (is daisy ungulate) (chews daisy cud) (goes daisy moo) => (is daisy cow)) (is daisy cow)))
new goal ==> (rule (rule 4 (lives-in daisy pasture) (eats daisy grass) => (chews daisy cud) (is daisy herbivore))
(chews daisy cud))
trying rule (rule 4 (lives-in daisy pasture) (eats daisy grass) => (chews daisy cud) (is daisy herbivore))
with ((is daisy ungulate) (is daisy mammal) (gives daisy milk) (lives-in daisy pasture) (has daisy hair)
(eats daisy grass) (has daisy hoofs))
==> (((chews daisy cud) (is daisy herbivore)))
goal stack....
((fact (goes daisy moo))
(rule (rule 3 (is daisy ungulate) (chews daisy cud) (goes daisy moo) => (is daisy cow)) (is daisy cow)))
new goal ==> (fact (goes daisy moo))
trying fact (goes daisy moo)
no applicable rules for (goes daisy moo)
goal stack....
((rule (rule 3 (is daisy ungulate) (chews daisy cud) (goes daisy moo) => (is daisy cow)) (is daisy cow)))
new goal ==> (rule (rule 3 (is daisy ungulate) (chews daisy cud) (goes daisy moo) => (is daisy cow)) (is daisy cow))
trying rule (rule 3 (is daisy ungulate) (chews daisy cud) (goes daisy moo) => (is daisy cow))
with ((is daisy herbivore) (chews daisy cud) (is daisy ungulate) (is daisy mammal) (gives daisy milk)
(lives-in daisy pasture) (has daisy hair) (eats daisy grass) (has daisy hoofs))
rule 3 fails
goal stack....
((fact (is daisy herbivore)) (fact (is daisy ungulate)) (fact (gives daisy milk))
(rule (rule 7 (is daisy herbivore) (is daisy ungulate) (gives daisy milk) => (is daisy cow)) (is daisy cow)))
new goal ==> (fact (is daisy herbivore))
trying fact (is daisy herbivore)
goal stack....
((fact (is daisy ungulate)) (fact (gives daisy milk))
(rule (rule 7 (is daisy herbivore) (is daisy ungulate) (gives daisy milk) => (is daisy cow)) (is daisy cow)))
new goal ==> (fact (is daisy ungulate))
trying fact (is daisy ungulate)
goal stack....
((fact (gives daisy milk))
(rule (rule 7 (is daisy herbivore) (is daisy ungulate) (gives daisy milk) => (is daisy cow)) (is daisy cow)))
new goal ==> (fact (gives daisy milk))
trying fact (gives daisy milk)
goal stack....
((rule (rule 7 (is daisy herbivore) (is daisy ungulate) (gives daisy milk) => (is daisy cow)) (is daisy cow)))
new goal ==> (rule (rule 7 (is daisy herbivore) (is daisy ungulate) (gives daisy milk) => (is daisy cow)) (is daisy cow))
trying rule (rule 7 (is daisy herbivore) (is daisy ungulate) (gives daisy milk) => (is daisy cow))
with ((is daisy herbivore) (chews daisy cud) (is daisy ungulate) (is daisy mammal) (gives daisy milk)
(lives-in daisy pasture) (has daisy hair) (eats daisy grass) (has daisy hoofs))
==> (((is daisy cow)))
goal stack....
nil
((is daisy cow) (is daisy herbivore) (chews daisy cud) (is daisy ungulate) (is daisy mammal) (gives daisy milk)
(lives-in daisy pasture) (has daisy hair) (eats daisy grass) (has daisy hoofs))
cg-user(69):