Class examples: forward chaining (9/27/00)
<![CDATA[
;;;;;;;;;;;;;;;;;;;;;;;
;;
;; A database of assertions for following
;; the Wars of the Roses plays.
(define *the-assertions*
'((father (edward III) (john of-gaunt))
(father (edward III) (edward prince-of-wales))
(father (edward III) (edmund duke-of-york))
(brother (john of-gaunt) (edward prince-of-wales))
(brother (john of-gaunt) (edmund duke-of-york))
(brother (edward prince-of-wales)
(edmund duke-of-york))
(husband (john of-gaunt) (blanche of-lancaster))
(wife (blanche of-lancaster) (john of-gaunt))
(father (john of-gaunt) (henry IV))
(father (edward prince-of-wales) (richard II))
(father (henry IV) (henry V))
(husband (henry V) (catherine of-france))
(wife (catherine of-france) (henry V))
(father (henry V) (henry VI))
(mother (catherine of-france) (henry VI))))
;;;;;;;;;;;;;;;;
;;
;; The basic pattern matcher
(define (match pattern expression dictionary)
(cond ((eq? dictionary 'failed) 'failed)
((atom? pattern)
(if (equal? pattern expression) dictionary 'failed))
((null? expression) 'failed)
((variable? pattern)
(extend-dictionary pattern expression dictionary))
((atom? expression) 'failed)
(else (match (cdr pattern) (cdr expression)
(match
(car pattern)
(car expression) dictionary)))))
;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Helper procedures needed for MATCH
(define (variable? pattern)
(eq? (car pattern) '?v))
(define (variable-name var) (cadr var))
(define (extend-dictionary variable expression dictionary)
(let* ((vname (variable-name variable))
(v (assoc vname dictionary)))
(cond ((not v) (cons (list vname expression) dictionary))
((equal? (cadr v) expression) dictionary)
(else 'failed))))
(define (get-value variable dictionary)
(cadr (assoc (variable-name variable) dictionary)))
;;;;;;;;;;;;;;;;;;;
;;
;; PATTERN MATCHING VERSION 1
;;
;; This is a simple beginning. The idea is that we
;; can test a pattern against each assertion in the
;; list, retrieving a list of matching dictionaries
;; (or NIL if there were no matching dictionaries).
(define (try-all-assertions pattern assertion-list)
(filter (lambda (dictionary)
(not (eq? dictionary 'failed)))
(map (lambda (assertion)
(match pattern assertion '()))
assertion-list)))
(define (try pattern)
(try-all-assertions pattern *the-assertions*))
;;;;;;;;;;;;;;;;;
;;
;; Version 2: Adding AND-patterns
;;
(define (try-all-assertions pattern assertion-list starting-dictionary)
(filter (lambda (dictionary) (not (eq? dictionary 'failed)))
(map (lambda (assertion)
(match pattern assertion starting-dictionary))
assertion-list)))
(define (try-all-assertions-for-each-dictionary
pattern assertion-list dictionary-list)
(map-append
(lambda (dictionary)
(try-all-assertions pattern assertion-list dictionary))
dictionary-list))
(define (type-dispatch pattern assertions dictionary-list)
(cond ((eq? (car pattern) 'and)
(try-and-series (cdr pattern) dictionary-list assertions))
(else (try-all-assertions-for-each-dictionary
pattern assertions dictionary-list))))
(define (try-and-series and-clauses dictionary-list assertions)
(cond ((null? and-clauses) dictionary-list)
(else (try-and-series (cdr and-clauses)
(type-dispatch (car and-clauses)
assertions
dictionary-list)
assertions))))
;; The new top-level TRY procedure
(define (try pattern)
(remove-duplicates
(type-dispatch pattern *the-assertions* (list '()))))
(define (remove-duplicates lis)
(cond ((null? lis) '())
((member (car lis) (cdr lis))
(remove-duplicates (cdr lis)))
(else (cons (car lis) (remove-duplicates (cdr lis))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Version 3: Using individual rules
(define *rule1*
'((and (father (?v oldperson) (?v youngerperson))
(father (?v youngerperson) (?v stillyoungerperson)))
(grandfather (?v oldperson) (?v stillyoungerperson))))
(define *rule2*
'((and (father (?v fath1) (?v son1))
(father (?v fath2) (?v son2))
(brother (?v fath1) (?v fath2)))
(cousin (?v son1) (?v son2))))
(define *rule3*
'((cousin (?v csn1) (?v csn2))
(rival (?v csn1) (?v csn2))))
(define (try-a-rule rule assertions)
(let* ((matching-dictionaries
(find-matching-dictionaries (if-part rule) assertions))
(possible-new-assertions
(map (lambda (dictionary)
(plug-dictionary-values-into dictionary
(then-part rule)))
matching-dictionaries)))
(remove-duplicates
(filter (lambda (new-assertion)
(not (member new-assertion assertions)))
possible-new-assertions))))
(define (find-matching-dictionaries pattern assertions)
(remove-duplicates (type-dispatch pattern assertions (list '()))))
(define (if-part rule) (car rule))
(define (then-part rule) (cadr rule))
(define (plug-dictionary-values-into dictionary pattern)
(cond ((null? pattern) '())
((atom? (car pattern))
(cons (car pattern) (plug-dictionary-values-into
dictionary (cdr pattern))))
((variable? (car pattern))
(cons (get-value (car pattern) dictionary)
(plug-dictionary-values-into dictionary (cdr pattern))))
(else
(cons (plug-dictionary-values-into dictionary (car pattern))
(plug-dictionary-values-into dictionary
(cdr pattern))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Version 4: Forward chaining using a series of rules
(define *the-rules* (list *rule1* *rule2* *rule3*))
(define (do-one-rule-pass rule-list assertion-list)
(remove-duplicates
(map-append
(lambda (rule) (try-a-rule rule assertion-list))
rule-list)))
(define (forward-chain rules new-assertions old-assertions)
(let ((newly-inferred-assertions
(do-one-rule-pass
rules (append new-assertions old-assertions))))
(cond ((null? newly-inferred-assertions) new-assertions)
(else (forward-chain
rules (append newly-inferred-assertions new-assertions)
old-assertions)))))
]]>