home *** CD-ROM | disk | FTP | other *** search
/ Simtel MSDOS 1992 December / simtel1292_SIMTEL_1292_Walnut_Creek.iso / msdos / aijournl / ai_oct86.arc / INSIDE1.LTG < prev    next >
Text File  |  1986-07-16  |  4KB  |  108 lines
  1.  
  2.  
  3. LISTING 1 
  4.  
  5.  
  6. ;;; Production System.  Copyright Raul E. Valdes-Perez, 1986.  All Rights Reserved.
  7. ;;; terminology and conventions
  8. ;;; () failure 
  9. ;;; (nil) match without bindings
  10. ;;; (((v 3) (w 5))) bindings
  11. ;;; ((((v 3) (w 5))) (((v 4) (w 7)))) all-bindings
  12. ;;; ((v 3) (w 5)) list of pairs
  13.  
  14. ;;; match pattern with a fact subject to bindings
  15. (defun match (pattern fact bindings)
  16.   (cond ((and (null pattern) (null fact)) bindings)
  17.     ((or (null pattern) (null fact)) nil)
  18.     ((variable? pattern) (reconcile (cadr pattern) fact bindings))
  19.     ((and (atom pattern) (atom fact) (eq pattern fact) bindings))
  20.     ((or (atom pattern) (atom fact)) nil)
  21.     (t (prog (new-bindings)
  22.          (setq new-bindings (match (car pattern) (car fact) bindings))
  23.          (return
  24.           (cond ((null new-bindings) nil)
  25.             (t (match (cdr pattern) (cdr fact) new-bindings))))))))
  26.  
  27. ;;; pattern and fact are single items;  are matching under many possible
  28. ;;; bindings e.g. ( (((foo 3) (v 1))) (((foo 4))) (nil) )
  29. ;;; returns updated all-bindings
  30. (defun match-bindings (pattern fact all-bindings)
  31.   (prog (new-bindings)
  32.     (setq new-bindings (match pattern fact '(nil)))
  33.     (return (cond ((null new-bindings) nil)
  34.               (t (filter-bindings all-bindings (car new-bindings)))))))
  35.  
  36. ;;; returns updated (by pattern) all-bindings
  37. (defun match-facts (pattern facts all-bindings)
  38.   (cond ((null facts) nil)
  39.     (t (prog (new-bindings)
  40.          (setq new-bindings
  41.                (match-bindings
  42.             pattern (get (car facts) 'datum) all-bindings))
  43.          (return
  44.           (cond ((null new-bindings)
  45.              (match-facts pattern (cdr facts) all-bindings))
  46.             (t (cons (car new-bindings)
  47.                  (match-facts
  48.                   pattern (cdr facts) all-bindings)))))))))
  49.  
  50. ;;; returns all-bindings, after matching all patterns
  51. (defun match-patterns (patterns facts all-bindings)
  52.   (cond ((null all-bindings) nil)
  53.     ((null patterns) all-bindings)
  54.     ((match-patterns 
  55.       (cdr patterns) è      facts
  56.       (match-facts (car patterns) facts all-bindings)))))
  57.  
  58. (defun match-rule (rule)
  59.   (match-patterns (get rule 'patterns) *facts* '((nil))))
  60.  
  61. ;;; *** auxiliary functions ***
  62.  
  63. ;;; select those bindings in <bindings> which are compatible with <list-pairs>
  64. ;;; and does a merge
  65. (defun filter-bindings (all-bindings list-pairs)
  66.   (cond ((null all-bindings) nil)
  67.     ((compatible? (caar all-bindings) list-pairs)
  68.      (cons (list (merge-pairs (caar all-bindings) list-pairs))
  69.            (filter-bindings (cdr all-bindings) list-pairs)))
  70.     (t (filter-bindings (cdr all-bindings) list-pairs))))
  71.  
  72. ;;; returns t or nil
  73. (defun compatible? (pairs1 pairs2)
  74.   (cond ((null pairs1))
  75.     ((assoc (caar pairs1) pairs2)
  76.      (and (equal (cdr (assoc (caar pairs1) pairs2))
  77.              (cdar pairs1))
  78.           (compatible? (cdr pairs1) pairs2)))
  79.     ((compatible? (cdr pairs1) pairs2))))
  80.     
  81. ;;; assumes that the two lists of pairs are compatible
  82. (defun merge-pairs (pairs1 pairs2)
  83.  (append pairs1 (merge-pairs2 pairs1 pairs2)))
  84.  
  85. ;;; collects the pairs in pairs2 that aren't in pairs1
  86. (defun merge-pairs2 (pairs1 pairs2)
  87.   (cond ((null pairs2) nil)
  88.     ((assoc (caar pairs2) pairs1) ;if there, skip it because they
  89.      (merge-pairs2 pairs1 (cdr pairs2))) ;are already compatible
  90.     (t (cons (car pairs2)
  91.          (merge-pairs2 pairs1 (cdr pairs2))))))
  92.  
  93. (defun reconcile (variable value bindings)
  94.   (prog (temp)
  95.     (setq temp (assoc variable (car bindings)))
  96.     (return
  97.      (cond ((null temp) (add-binding variable value bindings))
  98.            ((equal value (cadr temp)) bindings)
  99.            (t nil)))))
  100.           
  101. (defun variable? (pattern)
  102.   (and (listp pattern) (eq (car pattern) '*var*)))
  103.  
  104. (defun add-binding (variable value bindings)
  105.   (list (cons (cons variable value) (car bindings))))
  106.  
  107.  
  108.