Category : Files from Magazines
Archive   : AIOCT86.ZIP
Filename : INSIDE2.LTG
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*)))
Very nice! Thank you for this wonderful archive. I wonder why I found it only now. Long live the BBS file archives!
This is so awesome! 😀 I’d be cool if you could download an entire archive of this at once, though.
But one thing that puzzles me is the “mtswslnkmcjklsdlsbdmMICROSOFT” string. There is an article about it here. It is definitely worth a read: http://www.os2museum.com/wp/mtswslnk/