;from the google cache search: "clisp purtprop plist"
;It appears that Clisp does not have either put or putprop
;You can define these youself, as follows:
(defun put (symbol indicator newvalue)
 (setf (get symbol indicator) newvalue)
)
(defun putprop (symbol newvalue indicator)
 (setf (get symbol indicator) newvalue)
)
;end

(setq regles-personnes '(
	(R1 	si (on-a-fait-le-mit)
	    	alors (on-est-intelligent))
	(R2 	si (on-a-ete-battu-par-ses-parents)
	    	alors (on-est-nevrose))
	(R3 	si (on-est-nevrose
			on-est-frustre)
	    	alors (on-est-anxieux))
	(R4 	si (il-y-a-le-feu
			on-est-dans-un-batiment)
	    	alors (on-est-en-danger))
	(R5 	si (on-est-en-danger
			on-est-intelligent)
	    	alors (on-est-anxieux))
	(R6 	si (un-chien-mechant-approche)
	    	alors (il-y-a-menace))
	(R7 	si (il-y-a-menace)
	    	alors (on-est-en-danger))
	)
)

(setq regles-animaux '(
	(R1 	si (a-des-poils)	    							alors (est-un-mamifere))
	(R2 	si (donne-du-lait)	    							alors (est-un-mamifere))
	(R3 	si (a-des-plumes)	    							alors (est-un-oiseau))
	(R4 	si (vole donne-des-oeufs)    							alors (est-un-oiseau))
	(R5 	si (mange-viande)	    							alors (est-un-carnivore))
	(R6 	si (a-des-dents-pointues a-des-griffes a-des-yeux-frontaux)	    		alors (est-un-cranivore))
	(R7 	si (est-un-mamifere a-des-sabots)						alors (est-ongule))
	(R8  	si (est-un-mamifere est-un-ruminant)						alors (est-ongule))
	(R9 	si (est-un-mamifere a-une-couleur-fauve est-un-carnivore)			alors (est-un-guepard))
	(R10 	si (est-un-mamifere a-une-couleur-fauve est-un-carnivore a-des-rayures-noires)	alors (est-un-tigre))
	(R11 	si (a-des-taches-noires a-de-longues-pattes est-ongule a-un-long-cou)		alors (est-une-girafe))
	(R12 	si (a-des-rayures-noires est-ongule)						alors (est-un-zebre))
	(R13 	si (a-un-long-cou est-un-oiseau ne-vole-pas est-noir-et-blanc)			alors (est-une-autruche))
	(R14 	si (ne-vole-pas est-un-oiseau est-noir-et-blanc nage)				alors (est-un-pingouin))
	(R15	si(est-un-oiseau vole-bien)							alors (est-un-albatros))
	)
)
(setq carriere '(
 (R1 si (fait_bonnes_etudes papa_a_entreprise) 				alors (herite))
 (R2 si (herite est_ambitieux) 						alors (est_directeur_dentreprise))
 (R3 si (herite veut_vie_famille) 					alors (est_cadre))
 (R4 si (est_ambitieux fait_bonnes_etudes cree_son_entrep) 		alors (est_directeur_dentreprise))
 (R5 si (fait_bonnes_etudes cv_retenu) 					alors (est_cadre))
 (R6 si (est_directeur_dentreprise veut_vie_famille) 			alors (est_cadre))
 (R7 si (est_cadre travail_beaucoup est_ambitieux est_tres_chanceux) 	alors (est_directeur_dentreprise))
 (R8 si (fait_peu_detudes travail_beaucoup cv_retenu) 			alors (est_executant))
 (R9 si (fait_peut_detudes adepte_de_la_procrastination)		alors (est_sans_emploi))
 (R10 si (fait_beaucoup_detudes adepte_de_la_procrastination)		alors (est_sans_emploi))
 (R10 si (est_executant travail_beaucoup) 				alors (est_cadre))
 (R11 si (fait_peut_detudes adepte_de_la_procrastination)		alors (est_sans_emploi))

)
)

(setq regles-dinosaures '(
	(R1	si (bassin-de-reptile)						alors (est-saurischien))
	(R2 	si (est-saurischien possede-4-orteils-griffus-dont-ergot)	alors (est-theropode))
	(R3 	si (est-theropode possede-sailli-osseuse)			alors (est-ceratosaure))
	(R4 	si (est-carnivore est-theropode long-de-3m)			alors (est-herrerasaure))
	(R5 	si (est-theropode long-de-plus-de-5m pese-entre-400kg-1000kg)	alors (est-dilophosaure))
	(R6	si (est-theropode dent-jusqua-18cm)				alors (est-tyrannosaure))
	(R7	si (est-theropode pese-2tonnes)					alors (est-allosaure))
	(R8 	si (est-theropode peut-courir-a-60kmh)				alors (est-velociraptor))
	(R9	si (est-saurischien est-bipede squelette-retrouve-en-mongolie)	alors (est-segnosaure))
	(R10 	si (est-saurischien possede-petite-tete est-herbivore)		alors (est-sauropodomorphe))
	(R11 	si (est-sauropodomorphe a-vecu-entre-trias-et-jurassique)	alors (est-prosauropode))
	(R12 	si (est-prosauropode pese-27kg)					alors (est-anchisaure))
	(R13	si (est-prosauropode pese-jusqua-4tonnes)			alors (est-plateosaurus))
	(R14	si (est-sauropodomorphe long-cou-longue-queue)			alors (est-sauropode))
	(R15 	si (est-sauropode pese-plus-de-30tonnes)			alors (est-brachiosaure))
	(R16 	si (est-sauropode pese-moins-de-12tonnes)			alors (est-diplodocus))
	(R17 	si (bassin-similaire-oiseau)					alors (est-ornithischien))
	(R18 	si (dos-cuirasse)						alors (est-thyreophore))
	(R19 	si (est-thyreophore machoire-termine-par-bec)			alors (est-scelidosaure))
	(R20 	si (est-thyreophore dents-en-forme-de-feuilles)			alors (est-fabrosaure))
	(R21 	si (est-thyreophore cerveau-taille-noix)			alors (est-stegosaure))
	(R22 	si (est-thyreophore queue-en-massue)				alors (est-euoplocephale))
	(R23 	si (est-ornithischien crane-prolonge-ou-bouclier-osseux)	alors (est-marginocephale))
	(R24	si (est-marginocephale crane-en-dome)				alors (est-prenocephale))
	(R25	si (est-marginocephale possede-3-cornes)			alors (est-triceratops))
	(R26	si (est-ornithischien pieds-similaires-oiseaux)			alors (est-ornithopode))
	(R27 	si (est-ornithopode dents-similaires-iguanes)			alors (est-iguanodon))
	(R28	si (est-ornithopode bec-de-canard)				alors (est-hadrosaure))
	)
)
(setq regles 'regles-personnes) ; par défaut on choisi "regles-personne"
(setq heuristique 'prems) ; par défaut on choisira prems (première règle qui est choisie)

(defun partie_gauche_regle (r)(caddr r)) ;test ok
(defun partie_droite_regle (r) (cadr(cdddr r))) ;test ok
(defun nom_regle (r)(car r)) ; test ok

(defun appliquee?_regle (r)(get (nom_regle r) 'appliquee)) ;test ok
(defun marquer_appliquee_regle(r)(putprop (nom_regle r) 't 'appliquee));test ok

(defun r_concluent_sur_prop (p) (get p 'concl)) ; on est intelligent alors R1
(defun terminal?_prop (p)(null (r_concluent_sur_prop p)))

(defun demandable?_prop (p)(get p 'demandable))
(defun marquer_demandable_prop (p)(putprop p t 'demandable))
(defun marquer_demandable_liste_de_prop (lp)(mapc 'marquer_demandable_prop lp))

(defun recherchee?_prop (p)(get p 'recherchee))
(defun marquer_recherchee_prop (p)(putprop p 't 'recherchee))

(defun vraie?_prop (p)(get p 'vraie))
(defun marquer_vraie_prop (p)(putprop p t 'vraie))
(defun faux?_prop (p) (and (recherchee?_prop p)
			(not (vraie?_prop p)))
			)

(defun presentee?_prop (p)(get p 'presentee))
(defun marquer_presentee_prop (p)(putprop p t 'presentee))
(defun poser_question_prop (p)
	(terpri)
	(princ "Est-ce vraie:")
	(princ p)
	(princ " ?")
	(terpri)
)

(defun somme (pred liste)
  (cond
    ((null liste) nil)
    ((apply pred (list(car liste)))(car liste))
    (t (somme pred (cdr liste)))
  )
)

(defun vraie?_pg(liste_de_prop)
  (not (member nil (mapcar 'vraie?_prop liste_de_prop)))
)

;*********************************DEBUT*********************************************
(defun commencer()
  (princ "****** Moteur d'inference ***********")
  (chx_base_regle)
  (chx_heuristique)
  (chx_chainage)
)

(defun chx_chainage ()
  (terpri)
  (princ " Quel type de chainage souhaitez vous?")
  (terpri)
  (princ "1 : Arriere")
  (terpri)
  (princ "2 : Avant")
  (terpri)
  (setq reponse (read))
  (cond ((equal reponse '1)(probleme))
        ((equal reponse '2)(chainer_avant))
	(t (princ "erreur de saisie") (chx_chainage))
  )
)
(defun chx_heuristique ()
  (terpri)
  (princ " Quelle heuristique souhaitez vous?")
  (terpri)
  (princ "1 : Prendre la premiere regle")
  (terpri)
  (princ "2 : Prendre la regle qui aura le moins de premisses")
  (terpri)
  (setq reponse (read))
  (cond ((equal reponse '1)(setq heuristique 'prems))
        ((equal reponse '2)(setq heuristique 'moins_de_premisse))
	(t (princ "erreur de saisie") (chx_heuristique))
  )
)

(defun chx_base_regle ()
  (terpri)
  (princ " Quel base de regles souhaitez vous?")
  (terpri)
  (princ "1 : Regles d'une Personne")
  (terpri)
  (princ "2 : Regles des Annimaux")
  (terpri)
  (princ "3 : Regles des Dinosaures")
  (terpri)
  (princ "4 : Regles de la Carriere")
  (terpri)
  (setq reponse (read))
  (cond ((equal reponse '1)(setq regles regles-personnes))
        ((equal reponse '2)(setq regles regles-animaux))
	((equal reponse '3)(setq regles regles-dinosaures))
        ((equal reponse '4)(setq regles carriere))
	(t (princ "erreur de saisie") (chx_base_regle)))
)


(defun aff_conclus()
;(princ propositions)
(afficher_liste(cons_liste_conclu propositions) 1)
)
(defun cons_liste_conclu(props)
  (cond
    ((null props)nil)
    ((or(terminal?_prop (car props)) (and(r_concluent_sur_prop (car props)) (member (car props) (cdr props))) ) (cons_liste_conclu (cdr props)))
    (t (cons (car props)(cons_liste_conclu (cdr props))) )
  )
)
    

(defun aff_pr_avant()
	;(princ propositions)
	(afficher_liste(supp_doublons propositions) 1)
)

(defun supp_doublons(props)
  (cond
    ((null props)nil)
    ( (member (car props) (cdr props) ) (supp_doublons (cdr props)) )
    (t (cons (car props)(supp_doublons (cdr props))) )
  )
)
    

(defun afficher_liste(lc i)
  (cond
    ((null lc)nil)
    (t
    	(princ i)
	(princ " : ")
  	(princ (car lc))  	
	(terpri)
  	(afficher_liste (cdr lc) (+ i 1) )
    )
   )
)
  
;************************************************************************


; compilation de la base de règles

(defun initialiser () ;semble ok test (question: c koi ces pas d'inférences?)
  (cond ((not (boundp 'regles))
  	(print '(vous n'avez pas donné de regles))
	(error)))
  (cond ((not (boundp 'propositions))(compile_regles)))
  (princ "voulez vous que j'affiche mes pas d'inférences ?")
  (terpri)
  (setq reponse (read))
  (cond ((member reponse '(o y oui))(setq md t))(t (setq md nil)))
  (mapc 'rafraichir_prop propositions)
  (mapc 'rafraichir_regle regles) ; erreur sur p

)

(defun compile_regles () ;semble ok
  (setq propositions nil)
  (mapc
    'compile_regle
    regles)
    'compilees
)
; proposition : S-expression (liste de tous les faits présents dans la base de règle)
(defun compile_regle(r) ; toujours une erreur avec ce que j'ai rajouté
  (mapc  
    #'(lambda (p)
       (setq propositions (cons p propositions)) ;erreur sur funcall sur la fonction à appliquer (En cours a été dit de rajouter member)
       (putprop p (cons r (get p 'concl)) 'concl)
     )
     (partie_droite_regle r)
  )
  (mapc #'(lambda (p) (setq propositions (cons p propositions))) ;fait un lambda de p sur la partie gauche.
  	  (partie_gauche_regle r)
  )
)

(defun rafraichir_prop (p) ; semble ok
 (remprop p 'recherchee)
 (remprop p 'vraie)
 (remprop p 'presentee)
)

(defun rafraichir_regle (r) ; semble ok
  (remprop (nom_regle r) 'appliquee)
)
;*************************************************************

(defun interface_demandable ()
    (aff_conclus)
    (princ "Donnez la liste de propiete non demandables (ex: (1 4 2 ...) ):")
    (terpri)
    (setq rep (read))
    (maj_propositions propositions (cons_liste_prop_concl rep))
)
(defun cons_liste_prop_concl(liste)
 (cond
     ((null liste) nil)
     (t (cons (nth (car liste)  (cons 'elt0 (cons_liste_conclu propositions)) ) (cons_liste_prop_concl (cdr liste)) ))
 )
)

(defun maj_propositions (p liste)
   (cond
    ((null p) nil)
    ((null(member (car p) liste)) (marquer_demandable_prop (car p))(maj_propositions (cdr p) liste) )
    (t (maj_propositions (cdr p) liste))
   )
)

;*************************************************************

; chainage arrière

(defun probleme ()
  (initialiser)
  (interface_demandable)
  (aff_conclus)
  (princ "Quel est la propriete que vous souhaitez demontrer (donnez son numéro) ?")
  (terpri)
  (setq rep (read))  
  (princ (nth rep (cons 'elt0 (cons_liste_conclu propositions)) ))
  (terpri)
  (etablir_prop (nth rep  (cons 'elt0(cons_liste_conclu propositions)) ))
  (presenter_resultats)

)

(defun etablir_prop (p)
  (cond
   ((recherchee?_prop p)
    (cond
     ((vraie?_prop p) t)
     (t nil)))
   ((terminal?_prop p)
    (marquer_recherchee_prop p)
    (questionner_et_conclure_prop p))
   ((demandable?_prop p)
    (cond((questionner_et_conclure_prop p) t)
    	 ((eq reponse '?)(inferer_prop p))
    )
   )
   (t
     (marquer_recherchee_prop p)
     (inferer_prop p)
   )
 )
)

(defun questionner_et_conclure_prop (p)
  (poser_question_prop p) 
  (setq reponse (read))
  (cond
    ((member reponse '(y yes oui o))
     (marquer_vraie_prop p)
      t)
    ((member reponse '(no ? non n))
      nil)
     (t
      (princ "repondez oui ou non ou ? (si vous ne savez pas)")
      (terpri)
      (questionner_et_conclure_prop (p))
     )
   )
)

(defun inferer_prop (p)
 (let
  ((liste_de_regles (r_concluent_sur_prop p)))
  ( inferer1 p liste_de_regles) 
 )
)

(defun inferer1 (p lisreg1)
  (cond
   ((null lisreg1)
     nil)
   (t (essaye_regle (funcall heuristique lisreg1))  ; modifié afin de pouvoir prendre plusieurs heuristiques possibles
      (cond
       ((vraie?_prop p) t)
       (t (inferer1 p (delete (funcall heuristique lisreg1) lisreg1) )) ; modifié pour supprimer la règle qui a été essayée
      )
   )
  )
)

(defun prems (listreg2)
  ;(princ listre2)
  ;(terpri)
  (car listreg2); on va tester la première règle.
)
(defun moins_de_premisse (listreg3)
  ;(princ "moins_de_premisse")
  ;(terpri)
  ;(princ listreg3)
  ;(terpri)
  (cond
    ((null (cdr listreg3)) (car listreg3))
    ((<(valuer(car listreg3)) (valuer (cadr listreg3))) (moins_de_premisse (cons (car listreg3) (cddr listreg3))) )
    (t (moins_de_premisse (cdr listreg3)))
  )
)

(defun valuer (Uneregle)
  ;(princ "valuer")
  ;(terpri)
  ;(princ Uneregle)
  ;(terpri)
  ;(setq reponse (read))
  (setq pg (partie_gauche_regle Uneregle))
  (cond
    ((null pg) 0)
    ((terminal?_prop (car pg)) (+ 1 (valuer (subst () pg Uneregle) ) ) )
    (t (valuer (moins_de_premisse (r_concluent_sur_prop (car pg)))))
  )
)

(defun essaye_regle (r)
  (cond ((and (boundp 'md) md)
  	 (princ "j'essaye la regle ")
	 (terpri)
	 (princ r)(terpri)))
  (cond
   ((appliquee?_regle r)nil) ;dejà appliquée? si oui ne fait rien
   (t
    (let ((v (etablir_partie_gauche_pg (partie_gauche_regle r))))
      (cond
       ((null v) nil) ; lapartie gauche est fausse? la regle echoue sinon les propositions de la partie droite sont marquées vraies
       (t (applique_partie_droite_pd (partie_droite_regle r)))
      )
      (marquer_appliquee_regle r) ; la règle ne peut plus être réutilisée
     )
   )
  )
)

(defun etablir_partie_gauche_pg (liste_de_prop)
  (cond
    ((somme 'faux?_prop liste_de_prop)nil) ; y a-t-il une prop deja connu fausse? si oui on s'arrête là et on rend nil
    (t (etablir_pg1_pg liste_de_prop))
  )
)

(defun etablir_pg1_pg (liste_de_prop)
  (cond
    ((null liste_de_prop) t)
    ((null (etablir_prop (car liste_de_prop))) nil)
    (t (etablir_pg1_pg (cdr liste_de_prop)))
  )
)

(defun applique_partie_droite_pd (lp) ;lp une liste de propositions
  (mapc 'marquer_vraie_prop lp) ;on les marque toutes a vrai
  (mapc 'montre_deduction_prop lp) ;eventuellement on montre ce que l'on fait
)

(defun montre_deduction_prop (p)
  (cond
   ((and (boundp 'md) md) ;l'atome md a-t-iil deja une valeur et est elle vraie?
    (print (list 'je 'deduis p))
   )
  )
)

; CHAINAGE AVANT

(defun chainer_avant ()
 (initialiser)
 (aff_pr_avant)
 (princ "Donnez la liste de propiete presente dans la base de fait (ex: (1 4 2 ...) ):")
 (terpri)
 (setq rep (read))
 (setq liste_de_prop (cons_liste_prop rep))

 (mapc 'marquer_vraie_prop liste_de_prop)
 (chainer_avant1)
 (presenter_resultats)
)

;***************cons liste de prop ******************
(defun cons_liste_prop(liste)
 (cond
     ((null liste) nil)
     (t (cons (nth (car liste)  (cons 'elt0 (supp_doublons propositions)) ) (cons_liste_prop (cdr liste)) ))
 )
)
;*****************************************************

(defun chainer_avant1 ()
  (setq rc (somme 'appliquer_regle regles))
  (cond
   ((null rc)())
   (t (chainer_avant1))
  )
)

(defun appliquer_regle (r)
 (cond
  ((appliquee?_regle r) nil) ;arrêter si deja appliqué
  ((vraie?_pg (partie_gauche_regle r)) ;allez y si partie gauche est vraie
   (marquer_appliquee_regle r)
   (cond ((and (boundp 'md) md) ;eventuellement pour montrer ce qui se passe
   	  (terpri)
	  (princ "j'applique la regle")
	  (terpri)
	  (princ r)(terpri)
	 )
   )
   (applique_partie_droite_pd (partie_droite_regle r))
   t)
 )
)

(defun presenter_resultats ()
 (terpri)(terpri)(terpri)
 (princ "Voici ce que j'en conclus")
 (terpri)
  (mapc
   'presenter_prop
   propositions)
  'Fin_d_execution
)

(defun presenter_prop (p)
  (cond
   ( (presentee?_prop p) nil)
   ( t (marquer_presentee_prop p)
       (cond
        ((vraie?_prop p)
	 (print (list p 'est 'vraie))
	)
	((faux?_prop p)
	 (print (list p 'est 'faux))
	)
	;(md (print (list '* p 'n'a 'pas 'été 'demandé)))
       )
    )
   )
)