;--------------------------------------------------
; basic backward chainer with matching rules
;--------------------------------------------------
; this is an implementation of a simple backward chaining system
; using rules based on matching tuples. This version is to illustrate
; the general approach - it can be improved
;--------------------------------------------------
; some sample rules & facts
;--------------------------------------------------
(defvar *facts*) ; facts & rules are global
(defvar *rules*)
(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
(defun reset-facts ()
(setf *facts*
'((gives daisy milk)
(lives-in daisy pasture)
(has daisy hair)
(eats daisy grass)
(has daisy hoofs)
))
)
;--------------------------------------------------
; the top level function
;--------------------------------------------------
(defun bwd (goal)
"bwd chain on the goal"
(format t "~&bwd proving ~a~&" goal)
(or (member goal *facts* :test #'equal) ; either fact already known
(try-to-fire (useful-rules goal)) ; or try any useful rules
))
;--------------------------------------------------
; finding & binding appropriate rules
;--------------------------------------------------
(defun useful-rules (goal)
"find rules whose consequents match the goal"
(loop for rule in *rules*
when (check&bind rule goal)
collect it
))
(defun check&bind (rule goal)
"find a rule with a consequent matching the goal & return it bound"
;
; any rule whose consequents matches the goal is returned
; partially bound, ie: any match vars bound during consequent
; matching have their bindings propagated through the rule
; so it becomes specialised to the current goal
;
(some #'(lambda (c)
(mlet (c goal)
(return-from check&bind (match-> rule))
))
(consequents rule)
))
;--------------------------------------------------
; firing rules
;--------------------------------------------------
(defun try-to-fire (rules)
"go through a collection of rules until one fires"
(format t "~&queueing rules ~a~&" (mapcar #'rule-id rules))
(some #'check&fire rules))
(defun check&fire (rule)
"try a rule, bwd-chaining on its antecedents"
(format t "~&trying ~a~&" (rule-id rule))
(when (every #'bwd (antecedents rule))
(setf *facts*
($+ (apply-rule rule *facts*) *facts*))
))
(defun apply-rule (r facts)
(format t "~&applying ~a ~a~&" (rule-id r) (consequents r))
(or (all-present ((antecedents r) facts) ; if rule works
($+ (match-bind (consequents r)) facts)) ; return updated facts
facts ; return facts unchanged
))
;--------------------------------------------------
; rule accessors
;--------------------------------------------------
(defmatch antecedents ((Rule ?id ??antecedents => ??consequents))
#?antecedents)
(defmatch antecedents (?r)
(error "badly formed rule ~a" #?r))
(defmatch consequents ((Rule ?id ??antcedents => ??consequents))
#?consequents)
(defmatch consequents (?r)
(error "badly formed rule ~a" #?r))
(defmatch rule-id ((Rule ?id ??antcedents => ??consequents))
#?id)
(defmatch rule-id (?r)
(error "badly formed rule ~a" #?r))
;--------------------------------------------------
; example run
;--------------------------------------------------
#|
cg-user(1): (reset-facts)
((gives daisy milk) (lives-in daisy pasture) (has daisy hair)
(eats daisy grass) (has daisy hoofs))
cg-user(2): (bwd '(is daisy cow))
bwd proving (is daisy cow)
queueing rules (3 7)
trying 3
bwd proving (is daisy ungulate)
queueing rules (2)
trying 2
bwd proving (is daisy mammal)
queueing rules (1 5 6)
trying 1
bwd proving (has daisy warm-blood)
queueing rules nil
trying 5
bwd proving (has daisy hair)
applying 5 ((is daisy mammal))
bwd proving (has daisy hoofs)
applying 2 ((is daisy ungulate))
bwd proving (chews daisy cud)
queueing rules (4)
trying 4
bwd proving (lives-in daisy pasture)
bwd proving (eats daisy grass)
applying 4 ((chews daisy cud) (is daisy herbivore))
bwd proving (goes daisy moo)
queueing rules nil
trying 7
bwd proving (is daisy herbivore)
bwd proving (is daisy ungulate)
bwd proving (gives daisy milk)
applying 7 ((is daisy cow))
((is daisy cow) (chews daisy cud) (is daisy herbivore)
(is daisy ungulate) (is daisy mammal) (gives daisy milk)
(lives-in daisy pasture) (has daisy hair) (eats daisy grass)
(has daisy hoofs))
cg-user(3):
|#