; ; Patrick MARIE ; Tp5 IA: Moteur d'inference chainage arriere d'ordre 1 (define NOMBRE 3) (define base_regles '( (1 0 (parent-de ?x1 ?x2) (pere-de ?x1 ?x2)) (2 0 (parent-de ?x3 ?x4) (mere-de ?x3 ?x4)) (3 0 (frere-de ?x6 ?x7) (parent-de ?x5 ?x6) (parent-de ?x5 ?x7)) (4 0 (gd-parent-de ?x8 ?x10) (parent-de ?x8 ?x9) (parent-de ?x9 ?x10)) ) ) (define base_faits '( (mere-de Gaia Cronos) (mere-de Rhea Zeus) (mere-de Rhea Hades) (pere-de Ouranos Cronos) (pere-de Cronos Zeus) (pere-de Zeus Pollux) (pere-de Zeus Helene) (pere-de Zeus Castor) ) ) ; Algo d'unification: ; On suppose juste que les prédicats de meme noms ont tous le meme nombre ; d'expressions. ; (define exp1 '(f ?x (g ?y (h a)) b)) (define var1 '?x) (define var2 '?y) (define var3 '?z) (define int1 42) (define con1 'q) (define (terme:variable? u) (cond ( (not (symbol? u)) #f) (else (string=? "?" (substring (symbol->string u) 0 1))) ) ) (define (terme:constante? u) (cond ( (integer? u) #t) ( (not (symbol? u)) #f) (else (not (terme:variable? u))) ) ) (define (terme:predicat p) (cond ( (terme:variable? p) #f) ( (terme:constante? p) #f) (else (car p)) ) ) (define (terme:fils-liste p) (cond ( (terme:variable? p) #f) ( (terme:constante? p) #f) (else (cdr p)) ) ) ; ; Some special occur check (define (some-oc f u l) (if (null? l) #f (or (f u (car l)) (some-oc f u (cdr l)) ) ) ) ; ; On cherche u dans p (define (occur-check u p) (cond ( (terme:variable? p) (equal? u p)) ( (terme:constante? p) (equal? u p)) (else (some-oc occur-check u (terme:fils-liste p))) ) ) ; ; Dans une liste l, remplace les occurences de e par f (define (remplace e f l) (cond ( (and (list? l) (not (null? l))) (append (cons (remplace e f (car l)) '()) (remplace e f (cdr l)))) ( (equal? l e) f) (else l) ) ) (remplace '?x '?y '(f ?x (h ?x ?x) ?x)) (define (nouvelle-pile pile expr1 expr2) (if (null? pile) '() (cons (remplace expr2 expr1 (car pile)) (nouvelle-pile (cdr pile) expr1 expr2)) ) ) (define (nouvelle-pile-4cas pile expr1 expr2) (if (null? expr1) pile (nouvelle-pile-4cas (append pile (cons (car expr1) (cons (car expr2) '()))) (cdr expr1) (cdr expr2)) ) ) (nouvelle-pile '(a ?y) 'a '?y) (define (r-nouvel-pgu pgu expr1 expr2) (if (null? pgu) '() (cons (remplace expr2 expr1 (car pgu)) (r-nouvel-pgu (cdr pgu) expr1 expr2)) ) ) (define (nouvel-pgu pgu expr1 expr2) (append (r-nouvel-pgu pgu expr1 expr2) (cons expr1 (cons expr2 '()))) ) (define (unific pile pgu) (if (null? pile) pgu ; La pile est ainsi: '(p1 p2 p3 p4 p5 p6) ou p1 = p2, p3 = p4, p5 = p6 ; On recupere la 1ere equation, les 2 membres et on les separe (let ( (expr1 (car pile)) (expr2 (car (cdr pile))) (pile (cdr (cdr pile))) ) ; 1 er cas, X et Y sont deux expressions identiques (cond ( (equal? expr1 expr2) (unific pile pgu)) ; 2 nd cas, X est une variable absente de Y ( (and (terme:variable? expr1) (not (occur-check expr1 expr2)) ) (unific (nouvelle-pile pile expr2 expr1) (nouvel-pgu pgu expr2 expr1)) ) ; 3 em cas, Y est une variable absente de X ( (and (terme:variable? expr2) (not (occur-check expr2 expr1)) ) (unific (nouvelle-pile pile expr1 expr2) (nouvel-pgu pgu expr1 expr2)) ) ; 4 em cas: f(n) == f(m) ( (and (terme:predicat expr1) (terme:predicat expr2) (equal? (terme:predicat expr1) (terme:predicat expr2)) ) (unific (nouvelle-pile-4cas pile (cdr expr1) (cdr expr2)) pgu) ) ; Sinon, c'est faux (else '()) ) ) ) ) (define (unification expr1 expr2) (unific (cons expr1 (cons expr2 '())) '()) ) ; (unification '(p a ?x (f (g ?y))) '(p ?z (f ?z) (f ?u))) ; (unification '(p a u) '(p ?x ?z)) (define (num_regle r) (car r) ) (define (isvalide? r) (if (equal? (car (cdr r)) NOMBRE) #f #t ) ) (define (consequence r) (car (cdr (cdr r))) ) (define (antecedents r) (cdr (cdr (cdr r))) ) (define (get-antec n br) (antecedents (getregle n br)) ) (define (inlist? a l) (cond ( (not (list? l)) #f) ( (<= (length l) 0) #f) ( (equal? (car l) a) #t) (else (inlist? a (cdr l))) ) ) (define (display-faits faits) (if (null? faits) #f (begin (display " ") (display (car faits)) (display-faits (cdr faits)) ) ) ) (define (display-buts bf) (begin (display "La liste des faits a montrer devient:\n (") (display-faits bf) (display " )\n\n") ) ) (define (display-regle r) (begin (display " SI ") (display-faits (antecedents r)) (display "\n ALORS ") (display (consequence r)) (display "\n") ) ) (define (dans-bfo fait) (begin (display fait) (display " est une observation elle est donc verifiee.\n") ) ) (define (display-application n br) (begin (display "Application de la regle ") (display (num_regle n)) (display ":\n") (display-regle n) (display "\n") ) ) (define (display-but but) (begin (display "Application du but ") (display but) (display "\n\n") ) ) (define (getregle n l) (cond ((null? l) #f) ((equal? n (num_regle (car l))) (car l)) (else (getregle n (cdr l))) ) ) (define (cherche-regles fait br) (cond ( (null? br) '()) ( (not (isvalide? (car br))) (cherche-regles fait (cdr br))) (else ; (let ( (pgu (unification (consequence (car br)) fait)) ) (let* ( (renompgu (creer-pgu (cherche-variable (car br) '()))) (pgu (unification (applique-pgu (consequence (car br)) renompgu) fait)) (conseq (applique-pgu (car br) renompgu)) ) (begin ;(display "Unification entre ") ;(display (car br)) ;(display " et ") ;(display fait) ;(display " donne ") ;(display pgu) ;(display "\n") (if (equal? pgu '()) (cherche-regles fait (cdr br)) (cons (list conseq (append pgu renompgu)) (cherche-regles fait (cdr br)) ) ) ) ) ) ) ) (define (cherche-buts fait br) ;(begin ;(display "Appel de cherche-buts: \n") (cond ( (null? br) '()) (else ;(begin ;(display (car br)) ;(display fait) ;(display (unification (car br) fait)) ;(display "\n") (let ( (pgu (unification (car br) fait)) ) (if (equal? pgu '()) (cherche-buts fait (cdr br)) (cons (list (car br) pgu) (cherche-buts fait (cdr br)) ) ) ) ;) ) ;) ) ) (define (incrementereg n l) (cond ((null? l) '()) ((= n (num_regle (car l))) (cons (cons n (cons (+ 1 (car (cdr (car l)))) (cons (consequence (car l)) (antecedents (car l))))) (cdr l))) (else (if (= (length l) 1) l (cons (car l) (incrementereg n (cdr l))))) ) ) (define (some f l a1 a2 a3 a4) (cond ( (not (list? l)) #f ) ( (null? l) #f ) (else (or (f (car l) a1 a2 a3 a4) (begin (display "Il semble que nous devons faire un backtrack ici.\n") (some f (cdr l) a1 a2 a3 a4) ) ) ) ) ) ;(define ; (getsym) ; (string->symbol (symbol->string (generate-uninterned-symbol '?x))) ;) ; guile: ; (gensym "?x") ; ; (4 0 (gd-parent-de ?x8 ?x10) (parent-de ?x8 ?x9) (parent-de ?x9 ?x10)) (define toto '(4 0 (gd-parent-de ?x8 ?x10) (parent-de ?x8 ?x9) (parent-de ?x9 ?x10))) (define (ajout-si-nouveau var liste) (cond ( (null? liste) (cons var '())) ( (equal? var (car liste)) liste ) (else (cons (car liste) (ajout-si-nouveau var (cdr liste)))) ) ) (ajout-si-nouveau '?x1 (ajout-si-nouveau '?x2 '())) (define (aplat l) (cond ( (not (list? l)) (cons l '()) ) ( (= (length l) 0) '() ) ( (= (length l) 1) (aplat (car l)) ) (else (append (aplat (car l)) (aplat (cdr l)) )) ) ) (define (inlist? a l) (cond ( (not (list? l)) #f) ( (<= (length l) 0) #f) ( (equal? (car l) a) #t) (else (inlist? a (cdr l))) ) ) (define (ensemble-atome liste) (let ( (l (aplat liste)) ) (cond ( (not (list? l)) (cons l '()) ) ( (<= (length l) 0) '() ) ( (inlist? (car l) (cdr l)) (ensemble-atome (cdr l)) ) (else (cons (car l) (ensemble-atome (cdr l)))) ) ) ) (define (cherche-variable regle liste) (cond ( (null? regle) liste) ( (list? (car regle)) (ensemble-atome (append (cherche-variable (car regle) liste) (cherche-variable (cdr regle) liste) ) ) ) ( (terme:variable? (car regle)) (ajout-si-nouveau (car regle) (cherche-variable (cdr regle) liste)) ) (else (cherche-variable (cdr regle) liste)) ) ) (cherche-variable toto '()) (define (creer-pgu liste) (cond ( (null? liste) '()) (else (cons (gensym "?xn") (cons (car liste) (creer-pgu (cdr liste))))) ) ) (define (applique-pgu faits pgu) (if (null? pgu) faits (applique-pgu (remplace (car (cdr pgu)) (car pgu) faits) (cdr (cdr pgu)) ) ) ) (applique-pgu '((parent-de ?x ?y) (parent-de ?x ?z)) '(Oura ?x)) (remplace '?x 'Oura '((parent-de ?x ?y) (parent-de ?x ?z))) ; ; nliste a pour format: ; '(regle pgu regle2 pgu2 regle3 pgu3 ...) (define (apply-regle nliste br bf bfo vpgu) (begin (display-application (car nliste) br) (let* ( (regle (car nliste)) (pgu (car (cdr nliste))) ; Il faut modifier la nouvelle liste de buts. (nouvelle-lb (append (cdr bf) (applique-pgu (antecedents regle) pgu) ) ) (nouvelle-br (incrementereg (num_regle regle) br)) ) (c-ar nouvelle-br nouvelle-lb bfo (cons pgu vpgu)) ) ) ) (define (apply-buts nliste br bf bfo vpgu) (begin (display-but (car nliste)) (let* ( (regle (car nliste)) (pgu (car (cdr nliste))) (nouvelle-lb (applique-pgu (cdr bf) pgu)) (nouvelle-br br) ) (c-ar nouvelle-br nouvelle-lb bfo (cons pgu vpgu)) ) ) ) (define (c-ar br lb bfo pgu) (begin (display-buts lb) ; 1er cas: liste des buts vide (cond ( (null? lb) (begin (display "fin\nLe pgu est: ") (display pgu) (display "\n") ; pgu #f ) ) ; 2nd cas: 1er but dans les faits observes. ( (inlist? (car lb) bfo) (begin (dans-bfo (car lb)) (c-ar br (cdr lb) bfo pgu) ) ) ; 3eme cas: prochain but, on cherche les prochaines regles, some dessus ; et voila. (else (let ( (regles-app (cherche-regles (car lb) br)) (buts-app (cherche-buts (car lb) bfo)) ) ;(begin ;(display "buts applicables: ") ;(display buts-app) ;(display "\n"); (or (some apply-regle regles-app br lb bfo pgu) (some apply-buts buts-app bfo lb bfo pgu) ) ;) ) ) ) ) ) (display "\n\n") (display "\n\n") (display "\n\n") ; (c-ar base_regles '((frere-de Ouranos Zeus)) base_faits) (c-ar base_regles '((gd-parent-de Cronos Pollux)) base_faits '()) (c-ar base_regles '((gd-parent-de Cronos ?x)) base_faits '()) (c-ar base_regles '((frere-de ?X ?Y)) base_faits '())