; Partie I: representations

;
; Representation de bases de faits

(define base_faits '(rhizome fleur graine 1-cotyledone))

(define base_faits1
  '(
    rhizome
    fleur
    graine
    1-cotyledone
   )
)

(define base_faits2
  '(
     non_plante
     non_fleur
     non_feuille
   )
)

;
;
; Representation d'une base de regles
;
; '(regle_num (a1 a2 a3) c1)

(define base_regles
  '(
    (1 #t phanerogame fleur graine)
    (2 #t sapin phanerogame graine-nue)
    (3 #t monocotyledone phanerogame 1-cotyledone)
    (4 #t dicotyledone phanerogame 2-cotyledone)
    (5 #t muguet monocotyledone rhizome)
    (6 #t anemone dicotyledone)
    (7 #t lilas monocotyledone non_rhizome) 
    (8 #t cryptogame feuille fleur)
    (9 #t mousse cryptogame non_racine)
    (10 #t fougere cryptogame racine)
    (11 #t thallophyte non_feuille plante)
    (12 #t algue thallophyte chlorophylle)
    (13 #t champignon thallophyte non_chlorophylle)
    (14 #t colibacille non_feuille non_fleur non_plante)
  )
)

; Partie II: fonctions de base


; A partir d'une regle, retourne le numero de la regle
(define
  (num_regle r)
  (car r)
)

; A partir d'une regle, retourne si la regle est encore valide ou non
(define
  (isvalide? r)
  (car (cdr r))
)

; A partir d'une regle, retourne le but de la regle.
(define
  (consequence r)
  (car (cdr (cdr r)))
)

; A partir d'une regle, retourne les antecedents des regles.
(define
  (antecedents r)
  (cdr (cdr (cdr r)))
)

; A part d'un element 'a et d'une liste l, retourne vrai si l'element
; 'a est dans la liste l, sinon faux. 
(define
  (inlist? a l)
    (cond ( (not (list? l)) #f)
          ( (<=  (length l) 0) #f)
          ( (equal? (car l) a) #t)
          (else (inlist? a (cdr l)))
    )
)

; Fonctions de gestion d'ensembles (tp1)
;
; Ces fonctions ont ete reprises juste pour utiliser ens-inclus?
;

; Retourne la liste des atomes contenus dans sa liste d'argument.
; Necessaire pour ensemble-atome.
(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)) ))
  ) 
)

; Retourne l'ensemble des atomes contenus dans sa liste d'arguments.
; Necessaire pour supprime-doubles (utilise dans ens-inter)
(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))))
    )
  )
)

; Supprimer les doubles
(define
  (supprime-doubles l)
  (ensemble-atome l)
)

; Intersection d'ensemble: Renvoit un ensemble issus de 2 ensembles.
(define
  (ens-inter k l)
  (let ( (l1 (supprime-doubles k)) (l2 (supprime-doubles l)) )
    (cond ( (<= (length l1) 0) '())
          ( (not (inlist? (car l1) l2)) (ens-inter (cdr l1) l2) )
          (else (cons (car l1) (ens-inter (cdr l1) l2)) )
    )
  )
)

; Partie III: fonctions avancees


; ---------------------------------------------------------------------
; nom: ens-inclus?
; role: Retourne #t (vrai) si l'ensemble p est inclu dans l'ensemble l.
; signature: ensemble * ensemble -> booleen
; parametre en entree: 2 listes
; sortie:              booleen
; fonctions appelantes: applique-regles, c-a
; fonctions appelees:   ens-inter, length
; ---------------------------------------------------------------------
(define
  (ens-inclus? p l)
  (if (= (length p) (length (ens-inter p l)))
    #t
    #f
  )
)

(define
  (affiche-trouve num conseq)
  (begin
    (display "Je demontre avec la regle ")
    (display num)
    (display " le fait: ")
    (display conseq)
    (display "\n")
  )
)

; ---------------------------------------------------------------------
; nom: applique-regles
; role: Prend une base de regles et une base de faits.
;       Elle va appliquer chaque regles si c'est possible:
;          * le fait produit n'est pas dans la base de fait;
;          * les faits de departs sont dans la base de faits.
;       Si elle ne peut pas appliquer la regle, on appelle applique-regles
;       recursivement sur la meme base de faits mais avec la base de regle
;       moins la regle testee.
;
;       A la fin, on renvoit #f si on ne trouve rien.
; signature: base faits * base regles -> num de regle ou '()
; parametres:
;      bf - base de faits
;      br - base de regles
; sortie: le numero de la regle si succes, sinon #f 
; fonctions appelantes: applique-regles, c-a
; fonctions appellees:  null?, isvalide?, ens-inclus?, antecedents, 
;                       consequence, num_regle, car, cdr 
; ---------------------------------------------------------------------
(define
  (applique-regles bf br)
  ; Si il n'y a plus de regle dans la base de faits.
  (if (null? br)
      ; On renvoit faux.
      #f
      ; sinon, on prend la premiere regle
      (if (and 
            ; 1/ la regle n'a pas ete invalidee.
            (isvalide? (car br))
            ; 1/BIS le fait productible n'est pas dans la base de fait
            ;           (not (inlist? (consequence (car br)) bf))
            ; 2/ on peut produire le fait productible.
            (ens-inclus? (antecedents (car br)) bf)
          )
          (begin
            (affiche-trouve (num_regle (car br)) (consequence (car br)))
            (num_regle (car br))
          )
          ; sinon, on lance applique-regles sur la meme base de faits
          ; et base de regle moins celle juste testee 
          (applique-regles bf (cdr br))
      )
  )
)

; ---------------------------------------------------------------------
; nom: getregle
; role: A partir de la base de regles, retourne la regle dont le num
;       est donne.
; signature: num regle * base regle -> regle
; parametre en entree:
;       n: numero de la regle
;       l: base de regles
; sortie:
;       la regle si succes, #f sinon.
; fonctions appelantes: c-a
; fonctions appellees: null?, equal?, num_regle, car, cdr, getregle
; ---------------------------------------------------------------------
(define
  (getregle n l)
  (cond ((null? l) #f)
        ((equal? n (num_regle (car l))) (car l))
        (else (getregle n (cdr l)))
  )
)

; ---------------------------------------------------------------------
; nom: invalidereg
; role: A partir de la base de regles et du numero de regle,
;       reconstruit la regle a invalidifiee, reconnue par son numero
; signature: num regle * base regle -> base regle
; parametres en entree:
;       n: numero de regle
;       l: base de regles
; sortie: la base de regle modifiee
; fonctions appelantes: c-a 
; fonctions appellees: num_regle, cons, consequence, antecedent,
;                      null?, lenght, car, invalidereg, cdr
; ---------------------------------------------------------------------
(define
  (invalidereg n l)
  (cond ((null? l) '())
        ((= n (num_regle (car l))) (cons (cons n (cons #f 
                                                       (cons (consequence (car l))
                                                       (antecedents (car l)))))
                                         (cdr l)))
        (else (if (= (length l) 1) l (cons (car l) (invalidereg n (cdr l)))))
  )
)

; ---------------------------------------------------------------------
; nom: c-a
; role: algo chainage-avant
;       attention: une regle ne peut etre utilisee que pour produire un fait
;       qui n'est pas dans la base de faits.
; signature: base faits * base regles * faits -> booleen
; parametres en entree:
;       base-faits: la base de faits
;       base-regles: la base de regles
;       faits: les faits a demontrer (une liste)
; sortie: booleen, si les faits sont demontrables ou pas.
; fonctions appelantes: chainage-avant 
; fonctions appellees:  applique-regles, null?, consequence, getregle,
;                       invalidereg, ens-inclus?, c-a
; ---------------------------------------------------------------------
(define
  (c-a base-faits base-regles faits)
  ; On cherche un nouvel element a produire dans la base de faits.
  (let ((l (applique-regles base-faits base-regles)))
       ; Si applique-regles renvoit false, c'est qu'on ne peut plus rien
       ; deduire.
       (cond ( (null? l) #f) 
             (else 
               (let (
                      ; Nouvelle base de faits, avec le fait trouve de la derniere application
                      (base-faits (cons (consequence (getregle l base-regles)) base-faits))
                      ; Nouvelle base de regle, avec la regle invalidee.
                      (base-regles (invalidereg l base-regles))
                    )
                    (if (ens-inclus? faits base-faits)
                        #t 
                        (c-a base-faits base-regles faits)
                    )

               ); fin let base-faits;
             )
       )
  )
)

; affiche les differents faits
(define
  (display-faits faits)
  (if (null? faits) '()
      (begin
        (display (car faits))
        (display ", ")
        (display-faits (cdr faits))
      )
  )
)

; affiche "Les faits ... sont vrais".
(define
  (display-faits-vrais faits)
  (begin
    (display "Les faits ")
    (display-faits faits)
    (display "sont vrais.\n")
  )
)

; ---------------------------------------------------------------------
; nom: chainage-avant
; role: fonction principale pour le chainage avant: lance c-a et 
;       les fonctions pour les affichages des resultats.
; ---------------------------------------------------------------------
(define
  (chainage-avant base-faits base-regles faits)
  (begin
    (if (c-a base-faits base-regles faits)
        (display-faits-vrais faits)
        (display "La resolution est impossible: base de regles epuisee.\n")
    )
  )
)


; Partie IV: Quelques exemples.


; Resolvable
(display "\n\n")
(display "(chainage-avant base_faits1 base_regles '(muguet monocotyledone))\n\n")
(chainage-avant base_faits1 base_regles '(muguet monocotyledone))
(display "\n\n")
;
; Non resolvable
(display "(chainage-avant base_faits2 base_regles '(mousse colibacille))\n\n")
(chainage-avant base_faits2 base_regles '(mousse colibacille))
(display "\n\n")
;
; Exemple sujet
(display "(chainage-avant '(rhizome fleur graine 1-cotyledone) base_regles '(muguet))\n\n")
(chainage-avant '(rhizome fleur graine 1-cotyledone) base_regles '(muguet))