home *** CD-ROM | disk | FTP | other *** search
/ No Fragments Archive 10: Diskmags / nf_archive_10.iso / MAGS / SMARTMAG / V2.MSA / XADVISOR.STQ_XADVISOR.LSP < prev    next >
Lisp/Scheme  |  2003-12-17  |  7KB  |  168 lines
  1. ;***************************************************************************
  2. ;*                                                                         *
  3. ;*  XADVISOR.  Written by Christopher F. Chabris.  December 1985           *
  4. ;*       (June 1986: adapted from Franz Lisp to ST XLisp 1.5b)             *
  5. ;*                                                                         *
  6. ;*  START magazine, Fall 1986.      Copyright 1986 by Antic Publishing.    *
  7. ;*                                                                         *
  8. ;***************************************************************************
  9. ;
  10. ; A generic production-system interpreter/"expert system" capable of
  11. ;  both forward and backward chaining inference.
  12.  
  13.  
  14. ; Function ADVISE is a large front-end function used to invoke the production-
  15. ;  system interpreter for the first time.  After initializing the environment
  16. ;  in global variables, it will call either BACKWARDS or FORWARDS to proceed
  17. ;  depending on the arguments and options passed by the user.
  18.  
  19. (defun advise (context goal &rest options)
  20.   (setq i-flag (member 'interactive options)
  21.         proven context
  22.         disproven nil)
  23.   (cond ((and (null goal) (not (null context)))
  24.          (let ((advice (car (forwards (reverse rulebase) nil))))
  25.               (terpri)
  26.               (princ "I ")
  27.               (princ (car advice))))
  28.         (t
  29.          (let ((advice (backwards goal)))
  30.               (terpri)
  31.               (cond ((eq advice t)
  32.                      (princ "I ")
  33.                      (princ (car goal)))
  34.                     ((eq advice nil)
  35.                      (princ "I do not ")
  36.                      (princ (car goal)))
  37.                     (t
  38.                      (princ "I ")
  39.                      (princ (car advice)))))))
  40.   (princ ".")
  41.   (terpri)
  42.   'OK)
  43.  
  44.  
  45. ; Function PREPARE will load a rule set from the specified file into global
  46. ;  variable rulebase and put the rules in the same order as in the file.
  47.  
  48. (defun prepare (rulefile)
  49.   (setq rulebase nil)
  50.   (load rulefile)
  51.   (setq rulebase (reverse rulebase))
  52.   (setq inconclusive-message
  53.         '("cannot give any advice based on the given context"))
  54.   'OK)
  55.  
  56.  
  57. ; Macro IF adds a rule to the knowledge base in global variable rulebase.
  58. ; [Written to accomodate rule file format, replaces built-in IF]
  59.  
  60. (defmacro if (conditions actions)
  61.   (list 'setq
  62.         'rulebase
  63.         (list 'cons (list 'quote (list conditions actions)) 'rulebase)))
  64.  
  65.  
  66. ; Function BACKWARDS attempts to backward-chain from a given action, trying
  67. ;  to determine if it or all its conditions are (or can be) satisfied.  If no
  68. ;  action is specified, function TRYALL will be called to attempt to backward
  69. ;  chain from each terminal action.  The first to be satisified is returned.
  70.  
  71. (defun backwards (action)
  72.   (cond ((null action)
  73.          (try-all rulebase))
  74.         ((member action proven :test 'equal) t)
  75.         ((member action disproven :test 'equal) nil)
  76.         (t (let ((condition-sets (conditions action rulebase)))
  77.                 (cond ((null condition-sets)
  78.                        (cond (i-flag (ask-user action))))
  79.                       (t (backwards-aux action condition-sets)))))))
  80.  
  81. (defun try-all (rules-left)
  82.   (cond ((null rules-left)
  83.          inconclusive-message)
  84.         (t (let ((action (cadar rules-left)))
  85.                 (cond ((not (terminal action rulebase))
  86.                        (try-all (cdr rules-left)))
  87.                       (t (cond ((backwards action) action)
  88.                                (t (try-all (cdr rules-left))))))))))
  89.  
  90. (defun backwards-aux (action condition-sets)
  91.   (cond ((null condition-sets) nil)
  92.         ((assert (car condition-sets))
  93.          (setq proven (cons action proven))
  94.          t)
  95.         (t (backwards-aux action (cdr condition-sets)))))
  96.  
  97.  
  98. ; Function FORWARDS attempts to forward chain given the current context.  In
  99. ;  the current implementation, it assumes all rules are ordered according to
  100. ;  their "priority," and it will return a stream of all terminal actions
  101. ;  whose conditions have been satisfied.
  102.  
  103. (defun forwards (rules-left answer-stream)
  104.   (cond ((null rules-left)
  105.          (cond ((null answer-stream)
  106.                 (list inconclusive-message))
  107.                (t answer-stream)))
  108.         (t (let ((action (cadar rules-left)))
  109.                 (cond ((and (not (member action proven :test 'equal))
  110.                             (true (caar rules-left)))
  111.                        (setq proven (cons action proven))
  112.                        (cond ((terminal action rulebase)
  113.                               (forwards (reverse rulebase)
  114.                                         (cons action answer-stream)))
  115.                              (t (forwards (reverse rulebase)
  116.                                           answer-stream))))
  117.                       (t (forwards (cdr rules-left)
  118.                                    answer-stream)))))))
  119.  
  120.  
  121. ; Utility functions for inference engine:
  122. ;  ASSERT returns t if all actions passed in condition-set can be satisfied;
  123. ;  CONDITIONS returns a list of sets of conditions that will satisfy an action;
  124. ;  ASK-USER returns the user's declaration of the (un)truth of a condition;
  125. ;  TRUE returns t if every condition in condition-set is already proven;
  126. ;  TERMINAL returns t if a given action is "terminal" -- that is, if it does
  127. ;           not appear in any sets of conditions anywhere in the rulebase.
  128.  
  129. (defun assert (condition-set)
  130.   (cond ((null condition-set) t)
  131.         ((backwards (car condition-set))
  132.          (assert (cdr condition-set)))))
  133.  
  134. (defun conditions (action rules-left)
  135.   (cond ((null rules-left) nil)
  136.         ((equal action (cadar rules-left))
  137.          (cons (caar rules-left)
  138.                (conditions action (cdr rules-left))))
  139.         (t (conditions action (cdr rules-left)))))
  140.  
  141. (defun ask-user (action)
  142.   (terpri)
  143.   (princ "Is it true that:")
  144.   (terpri)
  145.   (princ " ")
  146.   (princ action)
  147.   (princ "?")
  148.   (let ((answer (read)))
  149.        (cond ((member answer '(y yes Y Yes))
  150.               (setq proven (cons action proven)) t)
  151.              ((member answer '(n no N No))
  152.               (setq disproven (cons action disproven)) nil)
  153.              (t
  154.               (princ "Answer (y)es or (n)o, please!")
  155.               (terpri)
  156.               (ask-user action)))))
  157.  
  158. (defun true (condition-set)
  159.   (cond ((null condition-set) t)
  160.         ((member (car condition-set) proven :test 'equal)
  161.          (true (cdr condition-set)))))
  162.  
  163. (defun terminal (action rules-left)
  164.   (cond ((null rules-left) t)
  165.         ((not (member action (caar rules-left) :test 'equal))
  166.          (terminal action (cdr rules-left)))))
  167.  
  168.