home *** CD-ROM | disk | FTP | other *** search
/ Liren Large Software Subsidy 9 / 09.iso / e / e070 / 5.ddi / EXPLORER / VIEWER / CHAINING.P < prev    next >
Encoding:
Text File  |  1984-10-13  |  4.0 KB  |  104 lines
  1. ;;;; This file contains the forward-chaining, rule-based,
  2. ;;;; expert-system program.
  3.  
  4. ;;; This section contains the key stream-processing procedures.
  5.  
  6. (DEFUN FILTER-ASSERTIONS (PATTERN INITIAL-A-LIST)
  7.   (DO ((ASSERTIONS ASSERTIONS (REST ASSERTIONS))
  8.        (A-LIST-STREAM (MAKE-EMPTY-STREAM)))
  9.       ((NULL ASSERTIONS) A-LIST-STREAM)
  10.     (LET ((NEW-A-LIST (MATCH PATTERN (FIRST ASSERTIONS) INITIAL-A-LIST)))
  11.       (COND (NEW-A-LIST (SETQ A-LIST-STREAM
  12.                               (ADD-TO-STREAM NEW-A-LIST A-LIST-STREAM)))))))
  13.  
  14. (DEFUN FILTER-A-LIST-STREAM (PATTERN A-LIST-STREAM)
  15.   (COND ((EMPTY-STREAM-P A-LIST-STREAM) (MAKE-EMPTY-STREAM))
  16.         (T (COMBINE-STREAMS
  17.             (FILTER-ASSERTIONS PATTERN (FIRST-OF-STREAM A-LIST-STREAM))
  18.             (FILTER-A-LIST-STREAM PATTERN (REST-OF-STREAM A-LIST-STREAM))))))
  19.  
  20. (DEFUN CASCADE-THROUGH-PATTERNS (PATTERNS A-LIST-STREAM)
  21.   (COND ((NULL PATTERNS) A-LIST-STREAM)
  22.         (T (FILTER-A-LIST-STREAM (FIRST PATTERNS)
  23.                                  (CASCADE-THROUGH-PATTERNS (REST PATTERNS)
  24.                                                            A-LIST-STREAM)))))
  25. (DEFUN SPREAD-THROUGH-THENS (RULE-NAME IFS THENS A-LIST)
  26.   (DO ((THENS THENS (REST THENS))
  27.        (ACTION-STREAM (MAKE-EMPTY-STREAM)))
  28.       ((NULL THENS) ACTION-STREAM)
  29.     (LET ((IFS (REPLACE-VARIABLES IFS A-LIST))
  30.           (THENS (REPLACE-VARIABLES THENS A-LIST)))
  31.       (COND ((REMEMBER-THENS THENS)
  32.              (REPORT-ACTION RULE-NAME IFS THENS)
  33.              (SETQ ACTION-STREAM (COMBINE-STREAMS THENS ACTION-STREAM)))))))
  34.  
  35. (DEFUN REMEMBER-THENS (THENS)
  36.   (DO ((THENS THENS (REST THENS))
  37.        (SWITCH NIL))
  38.       ((NULL THENS) SWITCH)
  39.     (WHEN (REMEMBER (FIRST THENS)) (SETF SWITCH T))))
  40.  
  41. (DEFUN REPORT-ACTION (RULE-NAME IFS THENS)
  42.   (FORMAT T "~%Rule ~a asserts: ~a" RULE-NAME (FIRST THENS))
  43.   (MAPCAR #'(LAMBDA (E) (FORMAT T "~%     ~a" E)) (REST THENS))
  44.   (FORMAT T "~%     because: ~a" (FIRST IFS))
  45.   (MAPCAR #'(LAMBDA (E) (FORMAT T "~%              ~a" E)) (REST IFS)))
  46.  
  47. (DEFUN REPLACE-VARIABLES (S A-LIST)
  48.   (COND ((ATOM S) S)
  49.         ((MEMBER (FIRST S) '(< >))
  50.          (SECOND (ASSOC (PATTERN-VARIABLE S) A-LIST)))  
  51.         (T (CONS (REPLACE-VARIABLES (FIRST S) A-LIST)
  52.                  (REPLACE-VARIABLES (REST S) A-LIST)))))
  53.  
  54. (DEFUN FEED-TO-THENS (RULE-NAME IFS THENS A-LIST-STREAM)
  55.   (COND ((EMPTY-STREAM-P A-LIST-STREAM) (MAKE-EMPTY-STREAM))
  56.         (T (COMBINE-STREAMS
  57.             (SPREAD-THROUGH-THENS RULE-NAME
  58.                                   IFS THENS
  59.                                   (FIRST-OF-STREAM A-LIST-STREAM))
  60.             (FEED-TO-THENS RULE-NAME
  61.                            IFS THENS
  62.                            (REST-OF-STREAM A-LIST-STREAM))))))
  63.  
  64. (DEFUN USE-RULE (RULE)
  65.   (LET* ((RULE-NAME (SECOND RULE))
  66.          (IFS (REVERSE (REST (THIRD RULE))))
  67.          (THENS (REST (THIRD (REST RULE))))   ;GCLISP does not have FOURTH.
  68.          (A-LIST-STREAM (CASCADE-THROUGH-PATTERNS
  69.                          IFS
  70.                          (ADD-TO-STREAM NIL (MAKE-EMPTY-STREAM))))
  71.          (ACTION-STREAM (FEED-TO-THENS RULE-NAME IFS THENS A-LIST-STREAM)))
  72.     (NOT (EMPTY-STREAM-P ACTION-STREAM))))
  73.  
  74. (DEFUN FORWARD-CHAIN ()
  75.   (DO ((RULES-TO-TRY RULES (REST RULES-TO-TRY))
  76.        (NO-PROGRESS T))
  77.       ((AND (NULL RULES-TO-TRY) NO-PROGRESS)
  78.        (FORMAT T "~%Nothing more can be done."))
  79.     (WHEN (NULL RULES-TO-TRY)
  80.           (SETQ RULES-TO-TRY RULES NO-PROGRESS T)
  81.           (FORMAT T "~%Making another pass through the rules..."))
  82.     (WHEN (USE-RULE (FIRST RULES-TO-TRY)) (SETQ NO-PROGRESS NIL))))
  83.  
  84. ;;; These section containts the access procedures.
  85.  
  86. (DEFUN COMBINE-STREAMS (S1 S2) (APPEND S1 S2))
  87.  
  88. (DEFUN ADD-TO-STREAM (E S) (CONS E S))
  89.  
  90. (DEFUN FIRST-OF-STREAM (S) (FIRST S))
  91.  
  92. (DEFUN REST-OF-STREAM (S) (REST S))
  93.  
  94. (DEFUN EMPTY-STREAM-P (S) (NULL S))
  95.  
  96. (DEFUN MAKE-EMPTY-STREAM () NIL)
  97.  
  98. ;;; This procedure puts new assertions on the assertion list.
  99.  
  100. (DEFUN REMEMBER (NEW)
  101.   (COND ((MEMBER NEW ASSERTIONS :TEST 'EQUAL) NIL)
  102.         (T (SETQ ASSERTIONS (CONS NEW ASSERTIONS)) NEW)))
  103.  
  104.