Category : Files from Magazines
Archive   : AIOCT86.ZIP
Filename : INSIDE1.LTG

 
Output of file : INSIDE1.LTG contained in archive : AIOCT86.ZIP


LISTING 1


;;; Production System. Copyright Raul E. Valdes-Perez, 1986. All Rights Reserved.
;;; terminology and conventions
;;; () failure
;;; (nil) match without bindings
;;; (((v 3) (w 5))) bindings
;;; ((((v 3) (w 5))) (((v 4) (w 7)))) all-bindings
;;; ((v 3) (w 5)) list of pairs

;;; match pattern with a fact subject to bindings
(defun match (pattern fact bindings)
(cond ((and (null pattern) (null fact)) bindings)
((or (null pattern) (null fact)) nil)
((variable? pattern) (reconcile (cadr pattern) fact bindings))
((and (atom pattern) (atom fact) (eq pattern fact) bindings))
((or (atom pattern) (atom fact)) nil)
(t (prog (new-bindings)
(setq new-bindings (match (car pattern) (car fact) bindings))
(return
(cond ((null new-bindings) nil)
(t (match (cdr pattern) (cdr fact) new-bindings))))))))

;;; pattern and fact are single items; are matching under many possible
;;; bindings e.g. ( (((foo 3) (v 1))) (((foo 4))) (nil) )
;;; returns updated all-bindings
(defun match-bindings (pattern fact all-bindings)
(prog (new-bindings)
(setq new-bindings (match pattern fact '(nil)))
(return (cond ((null new-bindings) nil)
(t (filter-bindings all-bindings (car new-bindings)))))))

;;; returns updated (by pattern) all-bindings
(defun match-facts (pattern facts all-bindings)
(cond ((null facts) nil)
(t (prog (new-bindings)
(setq new-bindings
(match-bindings
pattern (get (car facts) 'datum) all-bindings))
(return
(cond ((null new-bindings)
(match-facts pattern (cdr facts) all-bindings))
(t (cons (car new-bindings)
(match-facts
pattern (cdr facts) all-bindings)))))))))

;;; returns all-bindings, after matching all patterns
(defun match-patterns (patterns facts all-bindings)
(cond ((null all-bindings) nil)
((null patterns) all-bindings)
((match-patterns
(cdr patterns)
Š facts
(match-facts (car patterns) facts all-bindings)))))

(defun match-rule (rule)
(match-patterns (get rule 'patterns) *facts* '((nil))))

;;; *** auxiliary functions ***

;;; select those bindings in which are compatible with
;;; and does a merge
(defun filter-bindings (all-bindings list-pairs)
(cond ((null all-bindings) nil)
((compatible? (caar all-bindings) list-pairs)
(cons (list (merge-pairs (caar all-bindings) list-pairs))
(filter-bindings (cdr all-bindings) list-pairs)))
(t (filter-bindings (cdr all-bindings) list-pairs))))

;;; returns t or nil
(defun compatible? (pairs1 pairs2)
(cond ((null pairs1))
((assoc (caar pairs1) pairs2)
(and (equal (cdr (assoc (caar pairs1) pairs2))
(cdar pairs1))
(compatible? (cdr pairs1) pairs2)))
((compatible? (cdr pairs1) pairs2))))

;;; assumes that the two lists of pairs are compatible
(defun merge-pairs (pairs1 pairs2)
(append pairs1 (merge-pairs2 pairs1 pairs2)))

;;; collects the pairs in pairs2 that aren't in pairs1
(defun merge-pairs2 (pairs1 pairs2)
(cond ((null pairs2) nil)
((assoc (caar pairs2) pairs1) ;if there, skip it because they
(merge-pairs2 pairs1 (cdr pairs2))) ;are already compatible
(t (cons (car pairs2)
(merge-pairs2 pairs1 (cdr pairs2))))))

(defun reconcile (variable value bindings)
(prog (temp)
(setq temp (assoc variable (car bindings)))
(return
(cond ((null temp) (add-binding variable value bindings))
((equal value (cadr temp)) bindings)
(t nil)))))

(defun variable? (pattern)
(and (listp pattern) (eq (car pattern) '*var*)))

(defun add-binding (variable value bindings)
(list (cons (cons variable value) (car bindings))))




  3 Responses to “Category : Files from Magazines
Archive   : AIOCT86.ZIP
Filename : INSIDE1.LTG

  1. Very nice! Thank you for this wonderful archive. I wonder why I found it only now. Long live the BBS file archives!

  2. This is so awesome! 😀 I’d be cool if you could download an entire archive of this at once, though.

  3. 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/