home *** CD-ROM | disk | FTP | other *** search
/ ProfitPress Mega CDROM2 …eeware (MSDOS)(1992)(Eng) / ProfitPress-MegaCDROM2.B6I / MAGAZINE / MISC / AI_OCT86.ZIP / INSIDE2.LTG < prev    next >
Encoding:
Text File  |  1986-07-16  |  3.6 KB  |  109 lines
  1.  
  2. LISTING 2 
  3.  
  4. ;;; Production System.  Copyright Raul E. Valdes-Perez, 1986.  All Rights Reserved.
  5. ;;; property list of rule:
  6. ;;;   patterns, assert, delete, good-all-bindings, best-bindings
  7. ;;; property list of fact:
  8. ;;; datum, origin
  9.  
  10. (defun run ()
  11.   (prog (eligible-rules rule-to-fire)
  12.     loop
  13.     (pr "matching rules")
  14.     (mapcar '(lambda (rule) 
  15.            (putprop rule 
  16.                 (remove-useless-bindings rule (match-rule rule))
  17.                 'good-all-bindings)) *rules*)
  18.     (setq eligible-rules (collect-eligible-rules *rules*))
  19.     (cond ((null eligible-rules) (return nil)))
  20.     (setq rule-to-fire (resolve-conflict eligible-rules))
  21.     (pr "firing the rule ...") (see-rule rule-to-fire)
  22.     (execute-rule rule-to-fire)
  23.     (go loop)))
  24.  
  25. ;;; returns rules that are eligible for firing
  26. (defun collect-eligible-rules (rules)
  27.   (cond ((null rules) nil)
  28.     ((get (car rules) 'good-all-bindings)
  29.      (cons (car rules) (collect-eligible-rules (cdr rules))))
  30.     (t (collect-eligible-rules (cdr rules)))))
  31.  
  32. ;;; filters out useless bindings
  33. (defun remove-useless-bindings (rule all-bindings)
  34.   (cond ((null all-bindings) nil)
  35.     ;could also check for deleting facts which are not present
  36.     ((asserts-only-duplicates? (get rule 'assert) (car all-bindings))
  37.      (remove-useless-bindings rule (cdr all-bindings)))
  38.     (t (cons (car all-bindings) 
  39.          (remove-useless-bindings rule (cdr all-bindings))))))
  40.  
  41. (defun asserts-only-duplicates? (assertions bindings)
  42.   (not (member 'nil
  43.            (mapcar 'datum-present? (bind-assertions assertions bindings)))))
  44.  
  45. (defun execute-rule (rule)
  46.   (setq *facts* 
  47.     (delete-data
  48.      (bind-assertions (get rule 'delete) (get rule 'best-bindings))
  49.      *facts*))
  50.   (mapcar
  51.    '(lambda (new-datum)
  52.       (print "adding fact: ") (pr new-datum)
  53.       (add-fact new-datum rule))
  54.    (bind-assertions (get rule 'assert) (get rule 'best-bindings))))
  55. è(defun delete-data (data facts)
  56.   (cond ((null facts) nil)
  57.     ((member 
  58.        't (mapcar 
  59.         '(lambda (datum) (equal datum (get (car facts) 'datum)))
  60.         data))
  61.      (print "deleting fact: ") (pr (get (car facts) 'datum))
  62.      (delete-data data (cdr facts)))
  63.     (t (cons (car facts) (delete-data data (cdr facts))))))
  64.                 
  65. ;;; returns the single rule and sets best-bindings on the property list
  66. (defun resolve-conflict (rules)
  67.   (prog (rule)
  68.     (setq rule (most-specific (car rules) (cdr rules)))
  69.     (putprop rule (car (get rule 'good-all-bindings)) 'best-bindings)
  70.     (return rule)))
  71.  
  72. (defun most-specific (best rest)
  73.   (cond ((null rest) best)
  74.     ((> (length (get best 'patterns)) (length (get (car rest) 'patterns)))
  75.      (most-specific best (cdr rest)))
  76.     (t (most-specific (car rest) (cdr rest)))))
  77.   
  78. (defun see-rule (rule)
  79.   (pr "LHS")
  80.   (mapcar 'pr (get rule 'patterns))
  81.   (pr "RHS")
  82.   (mapcar 'pr (get rule 'assert))
  83.   (pr "with bindings")
  84.   (pr (get rule 'best-bindings)))
  85.  
  86. (defun pr (obj)
  87.   (print obj) (terpri))
  88.  
  89. (defun datum-present? (datum)
  90.   (datum-present2? datum *facts*))
  91.  
  92. (defun datum-present2? (datum facts)
  93.   (cond ((null facts) nil)
  94.     ((equal datum (get (car facts) 'datum)))
  95.     (t (datum-present2? datum (cdr facts)))))
  96.  
  97. (defun bind-assertions (assertions bindings)
  98.   (mapcar '(lambda (assertion)
  99.          (bind-assertion assertion (car bindings))) assertions))
  100.  
  101. (defun bind-assertion (assertion pairs)
  102.   (cond ((null assertion) nil)
  103.     ((use? (car assertion)) 
  104.      (cons (cdr (assoc (cadar assertion) pairs))
  105.            (bind-assertion (cdr assertion) pairs)))
  106.     (t (cons (car assertion) (bind-assertion (cdr assertion) pairs)))))
  107.  
  108. (defun use? (u-item)
  109.   (and (listp u-item) (eq (car u-item) '*use*)))