Artificial Intelligence

Class examples: forward chaining (9/27/00)

;;;;;;;;;;;;;;;;;;;;;;; ;; ;; 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)))))