LISTING 2 

;;; Production System.  Copyright Raul E. Valdes-Perez, 1986.  All Rights Reserved.
;;; property list of rule:
;;;   patterns, assert, delete, good-all-bindings, best-bindings
;;; property list of fact:
;;; datum, origin

(defun run ()
  (prog (eligible-rules rule-to-fire)
	loop
	(pr "matching rules")
	(mapcar '(lambda (rule) 
		   (putprop rule 
			    (remove-useless-bindings rule (match-rule rule))
			    'good-all-bindings)) *rules*)
	(setq eligible-rules (collect-eligible-rules *rules*))
	(cond ((null eligible-rules) (return nil)))
	(setq rule-to-fire (resolve-conflict eligible-rules))
	(pr "firing the rule ...") (see-rule rule-to-fire)
	(execute-rule rule-to-fire)
	(go loop)))

;;; returns rules that are eligible for firing
(defun collect-eligible-rules (rules)
  (cond ((null rules) nil)
	((get (car rules) 'good-all-bindings)
	 (cons (car rules) (collect-eligible-rules (cdr rules))))
	(t (collect-eligible-rules (cdr rules)))))

;;; filters out useless bindings
(defun remove-useless-bindings (rule all-bindings)
  (cond ((null all-bindings) nil)
	;could also check for deleting facts which are not present
	((asserts-only-duplicates? (get rule 'assert) (car all-bindings))
	 (remove-useless-bindings rule (cdr all-bindings)))
	(t (cons (car all-bindings) 
		 (remove-useless-bindings rule (cdr all-bindings))))))

(defun asserts-only-duplicates? (assertions bindings)
  (not (member 'nil
	       (mapcar 'datum-present? (bind-assertions assertions bindings)))))

(defun execute-rule (rule)
  (setq *facts* 
	(delete-data
	 (bind-assertions (get rule 'delete) (get rule 'best-bindings))
	 *facts*))
  (mapcar
   '(lambda (new-datum)
      (print "adding fact: ") (pr new-datum)
      (add-fact new-datum rule))
   (bind-assertions (get rule 'assert) (get rule 'best-bindings))))

Š(defun delete-data (data facts)
  (cond ((null facts) nil)
	((member 
	   't (mapcar 
		'(lambda (datum) (equal datum (get (car facts) 'datum)))
		data))
	 (print "deleting fact: ") (pr (get (car facts) 'datum))
	 (delete-data data (cdr facts)))
	(t (cons (car facts) (delete-data data (cdr facts))))))
			    
;;; returns the single rule and sets best-bindings on the property list
(defun resolve-conflict (rules)
  (prog (rule)
	(setq rule (most-specific (car rules) (cdr rules)))
	(putprop rule (car (get rule 'good-all-bindings)) 'best-bindings)
	(return rule)))

(defun most-specific (best rest)
  (cond ((null rest) best)
	((> (length (get best 'patterns)) (length (get (car rest) 'patterns)))
	 (most-specific best (cdr rest)))
	(t (most-specific (car rest) (cdr rest)))))
  
(defun see-rule (rule)
  (pr "LHS")
  (mapcar 'pr (get rule 'patterns))
  (pr "RHS")
  (mapcar 'pr (get rule 'assert))
  (pr "with bindings")
  (pr (get rule 'best-bindings)))

(defun pr (obj)
  (print obj) (terpri))

(defun datum-present? (datum)
  (datum-present2? datum *facts*))

(defun datum-present2? (datum facts)
  (cond ((null facts) nil)
	((equal datum (get (car facts) 'datum)))
	(t (datum-present2? datum (cdr facts)))))

(defun bind-assertions (assertions bindings)
  (mapcar '(lambda (assertion)
	     (bind-assertion assertion (car bindings))) assertions))

(defun bind-assertion (assertion pairs)
  (cond ((null assertion) nil)
	((use? (car assertion)) 
	 (cons (cdr (assoc (cadar assertion) pairs))
	       (bind-assertion (cdr assertion) pairs)))
	(t (cons (car assertion) (bind-assertion (cdr assertion) pairs)))))

(defun use? (u-item)
  (and (listp u-item) (eq (car u-item) '*use*)))