home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / xl21hos2.zip / IFTHEN.LSP < prev    next >
Text File  |  1995-12-27  |  7KB  |  245 lines
  1. ; -*-Lisp-*-
  2. ;
  3. ; If then rules - mini expert from Ch. 18 of Winston and Horn
  4. ; Written using recursion without progs
  5. ; Added function 'how' to explain deductions
  6. ;
  7. ; Use:
  8. ;    After loading type (deduce). It will make all the deductions
  9. ;    given the list fact. If you want to know how it deduced something
  10. ;    type (how '(a deduction)) for example (how '(animal is tiger))
  11. ;    and so on.
  12.  
  13.  
  14.  
  15. ; rules data base
  16.  
  17. (setq rules
  18.       '((rule identify1
  19.           (if (animal has hair))
  20.           (then (animal is mammal)))
  21.     (rule identify2
  22.           (if (animal gives milk))
  23.           (then (animal is mammal)))
  24.     (rule identify3
  25.           (if (animal has feathers))
  26.           (then (animal is bird)))
  27.     (rule identify4
  28.           (if (animal flies)
  29.           (animal lays eggs))
  30.           (then (animal is bird)))
  31.     (rule identify5
  32.           (if (animal eats meat))
  33.           (then (animal is carnivore)))
  34.     (rule identify6
  35.           (if (animal has pointed teeth)
  36.           (animal has claws)
  37.           (animal has forward eyes))
  38.           (then (animal is carnivore)))
  39.     (rule identify7
  40.           (if (animal is mammal)
  41.           (animal has hoofs))
  42.           (then (animal is ungulate)))
  43.     (rule identify8
  44.           (if (animal is mammal)
  45.           (animal chews cud))
  46.           (then (animal is ungulate)
  47.             (even toed)))
  48.     (rule identify9
  49.           (if (animal is mammal)
  50.           (animal is carnivore)
  51.           (animal has tawny color)
  52.           (animal has dark spots))
  53.           (then (animal is cheetah)))
  54.     (rule identify10
  55.           (if (animal is mammal)
  56.           (animal is carnivore)
  57.           (animal has tawny color)
  58.           (animal has black stripes))
  59.           (then (animal is tiger)))
  60.     (rule identify11
  61.           (if (animal is ungulate)
  62.           (animal has long neck)
  63.           (animal has long legs)
  64.           (animal has dark spots))
  65.           (then (animal is giraffe)))
  66.     (rule identify12
  67.           (if (animal is ungulate)
  68.           (animal has black stripes))
  69.           (then (animal is zebra)))
  70.     (rule identify13
  71.           (if (animal is bird)
  72.           (animal does not fly)
  73.           (animal has long neck)
  74.           (animal has long legs)
  75.           (animal is black and white))
  76.           (then (animal is ostrich)))
  77.     (rule identify14
  78.           (if (animal is bird)
  79.           (animal does not fly)
  80.           (animal swims)
  81.           (animal is black and white))
  82.           (then (animal is penguin)))
  83.     (rule identify15
  84.           (if (animal is bird)
  85.           (animal flys well))
  86.           (then (animal is albatross)))))
  87. ; utility functions
  88. (defun squash(s)
  89.        (cond ((null s) ())
  90.          ((atom s) (list s))
  91.          (t (append (squash (car s))
  92.             (squash (cdr s))))))
  93.  
  94. (defun p(s)
  95.        (princ (squash s)))
  96.  
  97. ; functions
  98.  
  99. ; function to see if an item is a member of a list
  100.  
  101. (defun member(item list)
  102.        (cond((null list) ())    ; return nil on end of list
  103.         ((equal item (car list)) list) ; found
  104.         (t (member item (cdr list))))) ; otherwise try rest of list
  105.  
  106. ; put a new fact into the facts data base if it is not already there
  107.  
  108. (defun remember(newfact)
  109.        (cond((member newfact facts) ())    ; if present do nothing
  110.         (t ( setq facts (cons newfact facts)) newfact)))
  111.  
  112. ; is a fact there in the facts data base
  113.  
  114. (defun recall(afact)
  115.        (cond ((member afact facts) afact)    ; it is here
  116.          (t ())))                ; no it is'nt
  117.  
  118. ; given a rule check if all the if parts are confirmed by the facts data base
  119.  
  120. (defun testif(iflist)
  121.        (cond((null iflist) t)    ; all satisfied
  122.         ((recall (car iflist)) (testif (cdr iflist))) ; keep searching
  123.                                       ; if one is ok
  124.         (t ())))                    ; not in facts DB
  125.  
  126. ; add the then parts of the rules which can be added to the facts DB
  127. ; return the ones that are added
  128.  
  129. (defun usethen(thenlist addlist)
  130.        (cond ((null thenlist) addlist) ; all exhausted
  131.          ((remember (car thenlist))
  132.          (usethen (cdr thenlist) (cons (car thenlist) addlist)))
  133.          (t (usethen (cdr thenlist) addlist))))
  134.  
  135. ; try a rule
  136. ; return t only if all the if parts are satisfied by the facts data base
  137. ; and at lest one then ( conclusion ) is added to the facts data base
  138.  
  139. (defun tryrule(rule &aux ifrules thenlist addlist)
  140.        (setq ifrules (cdr(car(cdr(cdr rule)))))
  141.        (setq thenlist (cdr(car(cdr(cdr(cdr rule))))))
  142.        (setq addlist '())
  143.        (cond (( testif ifrules)
  144.           (cond ((setq addlist (usethen thenlist addlist))
  145.              (p (list "Rule " (car(cdr rule)) "\n\tDeduced " addlist "\n\n"))
  146.              (setq ruleused (cons rule ruleused))
  147.              t)
  148.             (t ())))
  149.          (t ())))
  150.  
  151. ; step through one iteration if the forward search
  152. ; looking for rules that can be deduced from the present fact data base
  153.  
  154. (defun stepforward( rulelist)
  155.        (cond((null rulelist) ())    ; all done
  156.         ((tryrule (car rulelist)) t)
  157.         ( t (stepforward(cdr rulelist)))))
  158.  
  159. ; stepforward until you cannot go any further
  160.  
  161. (defun deduce()
  162.       (cond((stepforward rules) (deduce))
  163.        (t t)))
  164.  
  165. ; function to answer if a fact was used to come to a certain conclusion
  166. ; uses the ruleused list cons'ed by tryrule to answer
  167.  
  168. (defun usedp(rule)
  169.        (cond ((member rule ruleused) t)    ; it has been used
  170.          (t () )))            ; no it hasnt
  171.  
  172. ; function to answer how a fact was deduced
  173.  
  174. (defun how(fact)
  175.        (how2 fact ruleused nil))
  176.  
  177. (defun how2(fact rulist found)
  178.        (cond ((null rulist)    ; if the rule list exhausted
  179.           (cond (found t)   ; already answered the question return t
  180.             ((recall fact) (p (list fact " was a given fact\n")) t) ;known fact
  181.             (t (p (list fact " -- not a fact!\n")) ())))
  182.           
  183.           ((member fact (thenpart (car rulist)))     ; if rulist not empty
  184.            (setq found t)    ; and fact belongs to the then part of a rule
  185.            (p (list fact " was deduced because the following were true\n"))
  186.            (printifs (car rulist))
  187.            (how2 fact (cdr rulist) found))
  188.           (t (how2 fact (cdr rulist) found))))
  189.  
  190. ; function to return the then part of a rule
  191.  
  192. (defun thenpart(rule)
  193.        (cdr(car(cdr(cdr(cdr rule))))))
  194.  
  195. ; function to print the if part of a given rule
  196.  
  197. (defun printifs(rule)
  198.        (pifs (cdr(car(cdr(cdr rule))))))
  199.  
  200. (defun pifs(l)
  201.     (cond ((null l) ())
  202.           (t (p (list "\t" (car l) "\n"))
  203.          (pifs (cdr l)))))
  204.  
  205.  
  206. ; initial facts data base
  207. ; Uncomment one or make up your own
  208. ; Then run 'deduce' to find deductions
  209. ; Run 'how' to find out how it came to a certain deduction
  210.  
  211. ;(setq facts
  212. ;      '((animal has dark spots)
  213. ;    (animal has tawny color)
  214. ;    (animal eats meat)
  215. ;    (animal has hair)))
  216.  
  217. (setq facts
  218.       '((animal has hair)
  219.     (animal has pointed teeth)
  220.     (animal has black stripes)
  221.     (animal has claws)
  222.     (animal has forward eyes)
  223.     (animal has tawny color)))
  224.  
  225.  
  226. (setq rl1
  227.           '(rule identify14
  228.           (if (animal is bird)
  229.           (animal does not fly)
  230.           (animal swims)
  231.           (animal is black and white))
  232.           (then (animal is penguin))))
  233.  
  234. (setq rl2
  235.         '(rule identify10
  236.           (if (animal is mammal)
  237.           (animal is carnivore)
  238.           (animal has tawny color)
  239.           (animal has black stripes))
  240.           (then (animal is tiger))))
  241.  
  242. ; Initialization
  243. (expand 10)
  244. (setq ruleused nil)
  245.