;;;-*- Mode: Lisp; Package: USER; Base: 10 -*-) ;-------------------------------------------------------------------------- ; YACY ; Yet Another Conversion of Yaps ; This one is being perpetrated by Hans Tallis at Mitre-Washington. ; I'm taking Joe Kartje's Mitre-Bedford Zetalisp version and making it ; single-source-code runnable under both Zeta and Franz. 7/11/85 ; This is being tested on Franz release 38.91 and Zeta release 5.2. ; Under Franz, YAPS likes to load the defstruct and loop packages; otherwise, ; this file is self-contained. ; Under Zeta, the compiler likes to complain about redefining functions, ; since I load in this file before compiling (to get those macros in); just ; bear with me please. Mostly it's the defstruct-produced functions. ; For the Casual User, the only remarkable change is that some YAPS functions ; have been renamed so as not to step on Franz: ; unbreak-->unpbreak (actually this is for parallelism with pbreak) ; remove -->y-remove ; If you don't call any internal functions, these should be the only changes ; you notice. For more details, see below. (terpri) (princ "YACY: remove=>y-remove unbreak=>unpbreak trace=>yapstrace untrace=>yapsuntrace") (terpri) ;-------------------------------------------------------------------------- ; Here is a list of changes. Some have been rearranged since their original ; introduction, so the numbering is out of order. Sorry. ; 5. added the defvar stuff for lexically scoped Lambda Zeta. #+Franz (declare (special *rules-fired* ; guess *root* ; root of discrimination net *fcts* ; list of facts in data base, ordered by cycle number ; in descending order *rules* ; names of all active rules in the system *strategy* *test-list* ; list of (test . vars) *conflict-set* ; list of bindings that completely match some rule, ; in order of domination *cycle* ; current fact number *binding* ; bound to binding that is currently firing *halt* ; t iff execution should be halted after current cycle *trace* *pbreaks* ; names of production rules that will currently ; cause a break *last-pbreak* ; last binding to cause a break *fatal-error* *debug* )) #+LispM(defvar *rules-fired* nil "guess") #+LispM(defvar *root*) ; nil "root of discrimination net"; can't be bound since ; we need y-init to ; fire #+LispM(defvar *fcts* nil "list of facts in data base, ordered by cycle number in descending order") #+LispM(defvar *rules* nil "names of all active rules in the system") #+LispM(defvar *strategy* nil) #+LispM(defvar *test-list* nil "list of (test . vars)") #+LispM(defvar *conflict-set* nil "list of bindings that completely match some rule, in order of domination") #+LispM(defvar *cycle* nil "current fact number") #+LispM(defvar *binding*) ;"bound to binding that is currently firing";similar to ;*root* above #+LispM(defvar *halt* nil "t iff execution should be halted after current cycle") #+LispM(defvar *trace* nil) #+LispM(defvar *pbreaks* nil "names of production rules that will currently cause a break") #+LispM(defvar *last-pbreak* nil "last binding to cause a break") #+LispM(defvar *fatal-error* nil) #+LispM(defvar *debug* nil) ; 6. Franz needs to keep macros #+Franz(declare (macros t)) ; 38.Another speed hack; cuts down a bit on traceability during stacktrace #+Franz(sstatus translink on) #+Franz(setq displace-macros t) ; 4. loading in macros; WARNING LispM is overly specific #+Franz(eval-when (compile) (load 'yaps.l)) #+LispM(eval-when (compile) (load "splvax:disk1:[hans.yaps]yaps.l")) ; 2. printline is altered to work with both lisps. #+Franz(declare (special B TT N)) #+Franz(defmacro tabulate nil `(tyo 9)) #+LispM(defmacro tabulate nil `(princ (ascii 137))) (defmacro printline (&rest lst) ;B gives a blank, TT gives a tab, N gives a new line, else princ the argument `(prog nil (terpri) ,@(do ((prlst lst (cdr prlst)) (r1) (ptr)) ((null prlst) r1) (setq ptr (car prlst)) (cond ((stringp ptr) (setq r1 (append r1 (list (list 'princ ptr))))) ((and (listp ptr) (fdefinedp (car ptr))) (setq r1 (append r1 (list (list 'princ ptr))))) ((atom ptr) (selectq ptr (B (setq r1 (append r1 (list (list 'princ '" "))))) (TT (setq r1 (append r1 (list (list 'tabulate))))) (N (setq r1 (append r1 (list (list 'terpri ))))) (t (setq r1 (append r1 (list (list 'princ ptr))))))) ((numberp (cadr ptr)) (setq r1 (append r1 (do ((i (cadr ptr) (sub1 i)) (r2)) ((zerop i) r2) (selectq (car ptr) (B (setq r2 (append r2 (list (list 'princ '" "))))) (TT (setq r2 (append r2 (list (list 'tabulate))))) (N (setq r2 (append r2 (list (list 'terpri))))) (t (break "Error: undefined function in printline"))))))) (t (break "Printline can't hanldle this.")))))) ; 2a.Small hitch: this line from printline: ; ((and (listp ptr) (fdefinedp (car ptr))) ; isn't returning true from Lambda.release.1 compiler ; when we try to printline something like ; (fact-cycle node); in general, the macros defined by the defstructs ; don't appear to return t for (fdefinedp). Thank you, LMI. ; This is such a crock that I'm going to ignore it for now, but I'm ; mad about it. Simply get ready on that 'resume' key when compiled ; under lambda.release.1. ; 1. merged yapsutil and yapshacks into this file. Required renaming ; 'checkfatal' to 'y-checkfatal' to avoid stepping on a Liszt compiler ; function. ; Here is yapshacks: ;this guy needs to be in here (defmacro y-if (&rest form) ((lambda (clause result) (mapc #'(lambda (itm) (cond ((eq itm 'then)) ((eq itm 'else) (tconc result (car clause)) (setq clause (tconc nil t))) ((eq itm 'elseif) (tconc result (car clause)) (setq clause (ncons nil))) (t (tconc clause itm)))) (cdr form)) (cons 'cond (car (cond ((car clause) (tconc result (car clause))) (t result))))) (tconc nil (car form)) (ncons nil))) ; Here is yapsutil: I changed checkfatal to y-checkfatal (defun y-checkfatal (rulename) (y-if *fatal-error* (rp rulename) (printline "Rule cannot be added to system"))) ; 3. added concat definition for Zeta #+LispM(defun concat (&rest lst) (loop for x in lst with symbol initially (setq symbol "") do (setq symbol (string-append symbol (format nil "~A" x))) finally (return (intern symbol)))) ; 7. $$FAIL is not referenced, at least in that case, so I'm converting ; it to lower case for Franz's case-sensitive sake. ; 8. Franz and Zeta reverse the argument order for throw/*throw and ; catch/*catch, so these need to be defined specially. ; 8a.Dig this shit: Lambda release 1. follows Franz's ordering of ; arguments; release 2. follows Zeta's ordering. Nice! ; Lambda 2 appears to have (feature common) which release 1 doesn't. #+Franz(defmacro attempt (x) `(*catch 'LBattempt ,x)) #+Franz(defun fail nil (*throw 'LBattempt '$$fail)) #+LispM(cond ((or (status feature common)(status feature symbolics)) (progn ; for Lambda r. 2 and symbolics (defun fail nil (throw 'LBattempt '$$fail)) (defmacro attempt (x) `(catch 'LBattempt ,x)))) (t (progn ; for Lambda r. 1 (defmacro attempt (x) `(catch ,x 'LBattempt)) (defun fail nil (throw '$$fail 'LBattempt))))) ; 11.For strings, Zeta's string-equal == equal #+Franz(putd 'string-equal (getd 'equal)) ; 12.Whose ego was at stake here, I don't know #+Franz(putd 'get-pname (getd 'get_pname)) ; 13.The substring functions reference from 1 and 0 in Franz and Zeta: ; also, Zeta gives the end position; Franz likes the length #+Franz(defun y-substring (string begin &optional (end (1- (length string)))) (substring string (1+ begin) (- end begin))) #+LispM(defmacro y-substring (&rest x) `(substring ,@x)) ; 14.Some more Zeta compatibility functions #+Franz(putd 'fdefinition (getd 'getd)) #+Franz(putd 'fdefinedp (getd 'getd)) ; 15.Changed add-fact to run both ways. See below. ; 18.(cr) is just the minimal (cadad..r) function; it is already ; defined in franz, but not in Zeta #+LispM(defun cr (x) x) ; 20.Note: both Symbolics and Lambda carry the LispM feature. Just thought ; you'd like to know. ; 22.Only some of the defstructs need to have their names in the ; first position. Trying to track them down... ; These need :named-something: bind-node, join-node, rule, not-node ; These don't : net-node, binding, fact ; What I think I'll do is use hunks in Franz, and define an accessing ; function for getting at the name of the thing. Grep for "bad defstruct" ; below. #+Franz(defmacro my-defstruct-name (x) `(cdr ,x)) ;for :named-hunk's #+LispM(defmacro my-defstruct-name (x) `(aref ,x 0)) ;for :named-array's ; 23.Here is the first significant change to yaps: I'm going to bind rule ; definitions to the associated rule name. This should be transparent for ; the average yaps user. It just so happens there is a system here at ; Mitre Washington that likes to have this done. It seems harmless. ; Below, grep for "jrd harmless". It only happens when run on the ; Symbolics. ; 24.The next set of changes are other incidental items. ; All of the (for) constructs were converted to (loop for) forms. The ; former required loading in special for package (uomutil); Franz now ; has loops built in. ; 25.The allocate call (from y-init) disappeared; I'll put it back ; in for Franz's use only; grep for 'allocate' below. ; 26.the (bcdp) call has been translated for Zeta into ; (typep x :compiled-function) ; 26a.Lambda..release.1 doesn't like this, changing to ; (typep x ':compiled-function) ; 27.*facts* became *fcts* ; 28.*rules-fired* is new to me ; 29.*halt* gets initialized now ; 30.*fatal-error* gets initialized now ; 31.The old (for) package would automatically collect into $$val; this now ; needs to be explicitly specified ; 32.buildp was taken out of commission; it is now repaired. ; 33.The current struct package doesn't create the 'with-' functions, ; so we have to access structure components explicitly ; 34.All over the place Joe replaced ; (struct-type lhs-node) with (car lhs-node)--hope this still works ; 35.Zeta needs a tconc: #+LispM(defun tconc (ptr itm) ((lambda (newcell) (cond ((null ptr) (cons newcell newcell)) ((list ptr) (cond ((car ptr) (rplacd (cdr ptr) newcell) (rplacd ptr newcell)) (t (rplaca ptr newcell) (rplacd ptr newcell)))) (t (cons newcell newcell)))) (cons itm nil))) ; 37.I see now Maryland has discovered the naming problem with trace. ; So, it's off to yapstrace and yapsuntrace. ; 39.For some reason Maryland wrapped the (run) code in a (let with ; *binding*) which effectively hides *binding* later on in the Lambda ; release 2 environment (lexical). So I'm taking out that clause. ; Grep for 'with garbage' below: (process-nots) and (run) ; 40.I'm tired of hearning the Symbolics complain about redefining functions ; so I'm taking out the warnings. Grep for 'just-warn' below. ; 41.Lambda.release.2 complains about 'warn' being stepped on, so YAPS's Warn ; becomes yapsWarn. ;-------------------------------------------------------------------------- ; CHANGES -- Hans Tallis 8/8/84 ; These were designed to 'clean up' yaps: to keep it from stepping on ; standard Franz functions. ; many of these apply to defstruct as well ; 2. yaps's insert --> y-insert ; 4. unbreak --> unpbreak ; 5. yaps's untrace --> y-untrace;but not any more --hct 7/11/85 ; 6. yaps's trace --> y-trace;but not any more --hct 7/11/85 ; 7. yaps's remove --> y-remove ; 8. yaps's fact --> y-fact;but not any more --hct 7/11/85 ; 9. init --> y-init ; 11. for-uom --> for ; 14. if --> y-if ;-------------------------------------------------------------------------- ; ; YAPS: Yet Another Production System ; ; written by Liz Allen, Univ of Maryland ; ; YAPS is a production system based on a discrimination net similar ; to the net used by OPS5 written Forgey. YAPS runs at comparable ; speeds with OPS5 and allows more flexibility in tests allowed on ; the left hand side of productions and in the right hand side actions. ; ; A YAPS User's Manual is available: TR-1146 Univ of Maryland Computer ; Science Center ; ;-------------------------------------------------------------------------- ; Defstruct definitions ;-------------------------------------------------------------------------- #+Symbolics(eval-when (compile) (setq hct-old-inhibit-fdefine-warnings inhibit-fdefine-warnings) (setq inhibit-fdefine-warnings ':just-warn)) (defstruct (net-node :conc-name) binding-nodes ; bind-nodes that need no more checks path ; atom like c..r assoc-branch ; list of (value . net-node) else-branch) ; don't care branch (defstruct (bind-node :conc-name #+Franz (:type :named-hunk) #+LispM (:type :named-array)) pattern vars ; variables that appear in pattern test-list ; tests that must be passed involving only vars ; appearing in this pattern next-node ; either a join-node, the rule matched, or a not-node join-how ; if next-node is a join, either 'left or 'right net-link) ; to net-node parent (defstruct (join-node :conc-name #+Franz (:type :named-hunk) #+LispM (:type :named-array)) left-bindings ; 'none if this has bindings feeding from only ; the right side right-bindings vars ; variables bound at this point test-list ; to join a left binding to a right binding, ; these tests must return t next-node) ; either a join-node, the rule matched, or a not-node (defstruct (not-node :conc-name #+Franz (:type :named-hunk) #+LispM (:type :named-array)) blocked-bindings not-bindings all-vars test-list rule) (defstruct (binding :conc-name ) fact-list ; list of facts already joined var-list ; list of (var . value) back-link ; to parent join node, to rule these facts completely ; match, or to not-node age-list) ; list of fact ages in descending order (defstruct (fact :conc-name) cycle value bindings) (defstruct (rule :conc-name #+Franz (:type :named-hunk) #+LispM (:type :named-array)) name lhs nots tests bind-nodes ; all bind-nodes used in this rule not-nodes) #+Symbolics(eval-when (compile) (setq inhibit-fdefine-warnings hct-old-inhibit-fdefine-warnings)) ;-------------------------------------------------------------------------- ; Error routines ;-------------------------------------------------------------------------- (defmacro Errorx (&rest msg) `(progn (printline "Error: " ,@msg) (setq *fatal-error* t))) (defmacro yapsWarn (&rest msg) `(printline "Warning: " ,@msg)) (defmacro Debug (&rest msg) `(y-if *debug* (printline ,@msg) (break))) ;-------------------------------------------------------------------------- ; YAPS initialization ;-------------------------------------------------------------------------- (defun y-init nil (setsyntax '|^| 'macro #'(lambda nil (cons '|^| (read)))) #+Franz(allocate 'hunk2 50) (setq *root* (make-net-node path 'car) *rules-fired* nil *fcts* nil *cycle* 0.0 *conflict-set* nil *strategy* 'goal *trace* t *pbreaks* nil *last-pbreak* nil *rules* nil *debug* nil *halt* nil *fatal-error* nil )) (eval-when (eval load) (or (boundp '*root*) (y-init))) ;-------------------------------------------------------------------------- ; user functions to handle production rules ;-------------------------------------------------------------------------- (defmacro p (name &rest rule) ;jrd harmless (?) modification #+Symbolics(set name (cons 'p (cons name (copytree rule)))) (attempt (let (lhs nots (tests (loop for x in (cdr (memq 'test rule)) until (eq x '-->) collect x)) (rhs (cdr (memq '--> rule)))) (loop for x in rule while (and (neq x '-->) (neq x 'test)) unless (and (eq (car x) '|~|) (push x nots)) collect x into $$val finally (setq lhs $$val)) (y-if (not (atom name)) (Errorx "Missing rule name") (fail)) (y-if (null rhs) (Errorx "Missing rhs") (fail)) `(progn 'compile (add-rule ',name ',lhs ',nots ',tests) (and *trace* (printline TT "defining rhs")) (defun ,(concat '|RHS-| name) ,(getvars lhs) ,@rhs))))) (defun buildp (name rule) #+Franz(funcall 'p `(p ,name ,@rule)) #+LispM(eval (macroexpand `(p ,name ,@rule)))) (defun rp (&rest lst) (loop for name in lst do (remove-old-rule (get name 'rule)) (remprop name 'rule) (setq *rules* (delq name *rules* 1)))) (defun printp (&rest names) (loop with rule and rhs for r in names do (setq rule (get r 'rule)) (cond (rule (printline "(p " r) (loop for x in (rule-lhs rule) do (printline TT x)) (and (rule-nots rule) (loop for x in (rule-nots rule) do (printline TT x))) (and (rule-tests rule) (loop for x in (cdr (rule-tests rule)) initially (printline " test" TT (car (rule-tests rule))) do (printline TT x))) (setq rhs (fdefinition (concat '|RHS-| r))) (cond (#+LispM(typep rhs ':compiled-function) #+Franz(bcdp rhs) (printline " -->" TT "The rhs is compiled")) (t (loop for x in (cdddr rhs) initially (printline " -->" TT (caddr rhs)) do (printline TT x)))) (printline TT ")")) (t (printline r " is not a rule"))))) (defun allp nil (loop for r in (reverse *rules*) initially (printline "Active production rules") do (printline TT r))) ;-------------------------------------------------------------------------- ; How to add a new production to the system ;-------------------------------------------------------------------------- (defun add-rule (name lhs nots tests) (let ((old (get name 'rule)) *fatal-error*) (cond ((and old (equal lhs (rule-lhs old)) (equal nots (rule-nots old)) (equal tests (rule-tests old)) (null *debug*)) (and *trace* (printline name ":" N TT "already have lhs"))) (old (and *trace* (printline name ":" N TT "compiling new lhs")) (remove-old-rule old) (add-new-rule name lhs nots tests)) (t (and *trace* (printline name ":" N TT "compiling lhs")) (push name *rules*) (add-new-rule name lhs nots tests))) (y-checkfatal name))) (defun add-new-rule (name lhs nots tests) (let (lhs-node lhs-vars new-rule) (setq *test-list* (loop for x in tests collect (cons x (getvars x))) new-rule (make-rule name name lhs lhs nots nots tests tests) lhs-node (add-patterns lhs new-rule)) (selectq ;(car lhs-node);should be a bad place for defstructs (my-defstruct-name lhs-node) (bind-node (setf (bind-node-next-node lhs-node) new-rule) (setq lhs-vars (bind-node-vars lhs-node))) (join-node (setf (join-node-next-node lhs-node) new-rule) (setq lhs-vars (join-node-vars lhs-node))) (t nil)) (process-nots nots new-rule lhs-vars) (remove-bind-tests lhs-node) (check-test-list) (putprop name new-rule 'rule))) (defun process-nots (nots rule lhs-vars) (loop with ;*test-list* and ;with garbage pats and not-node for x in nots do (loop for y on (cdr x) until (y-if (eq (car y) 'with) (setq *test-list* (cdr y)) t) collect (car y) into $$val finally (setq pats $$val)) (loop for tst in *test-list* collect (cons tst (getvars tst)) into $$val finally (setq *test-list* $$val)) (setq not-node (add-patterns pats rule)) (remove-bind-tests not-node) (setq not-node (add-not-node not-node rule lhs-vars)) (check-test-list) collect not-node into $$val finally (setf (rule-not-nodes rule) $$val))) (defun add-patterns (pats rule) (let ((bind-nodes (loop for p in pats collect (add-to-net p))) node) (setf (rule-bind-nodes rule) (nconc (rule-bind-nodes rule) bind-nodes)) (loop for b in (cdr bind-nodes) initially (setq node (car bind-nodes)) do (setq node (join-together node b))) node)) (defun check-test-list nil (and *test-list* (loop for tx in *test-list* collect (car *test-list*) into $$val finally (yapsWarn "These tests contain variables not on the lhs:" N TT $$val)))) ;-------------------------------------------------------------------------- ; How to remove an old rule from the system ;-------------------------------------------------------------------------- (defun remove-old-rule (rule) (loop with node for bnd in (rule-bind-nodes rule) do (setq node (bind-node-net-link bnd)) (setf (net-node-binding-nodes node) (delq bnd (net-node-binding-nodes node) 1)) (setq node (bind-node-next-node bnd)) (selectq ;(car node);bad defstruct place (my-defstruct-name node) (join-node (remove-bdgs (join-node-left-bindings node)) (remove-bdgs (join-node-right-bindings node))) (not-node (remove-bdgs (not-node-blocked-bindings node)) (remove-bdgs (not-node-not-bindings node))) (t nil))) (loop for bdg in *conflict-set* unless (eq rule (binding-back-link bdg)) collect bdg into $$val finally (setq *conflict-set* $$val))) (defun remove-bdgs (bdgs) (loop for bdg in bdgs do (loop for f in (binding-fact-list bdg) do (setf (fact-bindings f) (delq bdg (fact-bindings f) 1))))) ;-------------------------------------------------------------------------- ; Munging the RETE net: adding novel rule clauses ;-------------------------------------------------------------------------- (defun add-to-net (pattern) (let ((path-list (getpaths pattern)) ; getpaths returns (path-list . vars) vars node new-bind-node) (setq vars (cdr path-list)) (setq path-list (car path-list)) (loop with path-pair and next initially (setq node *root*) while (setq next (cond ((null path-list) nil) ((setq path-pair (assq (net-node-path node) path-list)) (setq path-list (delq path-pair path-list 1)) (cond ((cdr (assq (cdr path-pair) (net-node-assoc-branch node)))) (t (push path-pair path-list) nil))) ((net-node-else-branch node)) (t (setf (net-node-else-branch node) (make-net-node path (caar path-list))) node))) do (setq node next)) (loop with new-node for path-pair in path-list do (setq new-node (make-net-node)) (alter-net-node node path (car path-pair) assoc-branch (cons (cons (cdr path-pair) new-node) (net-node-assoc-branch node))) (setq node new-node)) (setq new-bind-node (make-bind-node pattern pattern vars vars test-list (loop for tst in *test-list* when (allmemq (cdr tst) vars) collect (car tst)) net-link node )) (setf (net-node-binding-nodes node) (cons new-bind-node (net-node-binding-nodes node))) new-bind-node)) (defun join-together (n1 n2) ; n1 is either a bind-node or a join-node; n2 is a bind-node (let ((new-join-node (make-join-node)) vars) (selectq ;(car n1); here is one bad defstruct spot (my-defstruct-name n1) (bind-node (setf (bind-node-next-node n1) new-join-node) (setf (bind-node-join-how n1) 'left) (setq vars (bind-node-vars n1)) (loop with save for tst in (bind-node-test-list n1) do (and (setq save (assoc tst *test-list*)) (setq *test-list* (delq save *test-list* 1))))) (join-node (setf (join-node-next-node n1) new-join-node) (setq vars (join-node-vars n1))) (t nil)) (loop for v in (bind-node-vars n2) unless (memq v vars) collect v into $$val finally (setq vars (append vars $$val))) (setf (bind-node-next-node n2) new-join-node) (setf (bind-node-join-how n2) 'right) (setf (join-node-vars new-join-node) vars) (loop with save for tst in (bind-node-test-list n2) do (and (setq save (assoc tst *test-list*)) (setq *test-list* (delq save *test-list* 1)))) (loop for tst in *test-list* when (allmemq (cdr tst) vars) do (setq *test-list* (delq tst *test-list*)) and collect (car tst) into $$val finally (setf (join-node-test-list new-join-node) $$val)) new-join-node)) (defun add-not-node (n rule vars) ; n is either a bind-node or a join-node (let ((new-not-node (make-not-node rule rule))) (selectq ;(car n); bad defstruct place (my-defstruct-name n) (bind-node (setf (bind-node-next-node n) new-not-node) (setq vars (append vars (bind-node-vars n)))) (join-node (setf (join-node-next-node n) new-not-node) (setq vars (append vars (join-node-vars n)))) (t nil)) (setf (not-node-all-vars new-not-node) vars) (loop for tst in *test-list* when (allmemq (cdr tst) vars) do (setq *test-list* (delq tst *test-list*)) and collect (car tst) into $$val finally (setf (not-node-test-list new-not-node) $$val)) new-not-node)) (defun remove-bind-tests (node) (and (eq ;(car node) (my-defstruct-name node) 'bind-node) (loop with save for tst in (bind-node-test-list node) do (and (setq save (assoc tst *test-list*)) (setq *test-list* (delq save *test-list* 1)))))) ;-------------------------------------------------------------------------- ; Running the system: more user functions ;-------------------------------------------------------------------------- (defun run (&optional n) (loop with ;*binding* and ;with garbage removed --hct rule-name ;and *halt* while (and *conflict-set* (not (eq n 0)) (not *halt*)) do (and (numberp n) (setq n (sub1 n))) (setq *binding* (pop *conflict-set*) rule-name (rule-name (binding-back-link *binding*)) ) (and *trace* (loop for f in (binding-fact-list *binding*) initially (printline "Running rule " rule-name) (printline TT "Facts used:") do (printline (TT 2) (fact-cycle f) " " (fact-value f)))) (putprop rule-name (binding-var-list *binding*) 'bindings) (setq *rules-fired* (cons rule-name *rules-fired*)) (checkpbreak rule-name) (remove-bdgs (ncons *binding*)) (apply (concat '|RHS-| rule-name) (loop for x in (binding-var-list *binding*) collect (cdr x))) (and *trace* (printline)) finally (and *trace* (null *conflict-set*) (printline "No rules currently in the conflict set")))) (defun halt () (setq *halt* t)) (defun checkpbreak (r) (cond ((and (memq r *pbreaks*) (not (eq *last-pbreak* *binding*))) (printline "Break point at rule: " r) (cond ((or (fdefinedp 'lispbreak) (get 'lispbreak 'autoload)) (eval `(let ,@(loop for x in (binding-var-list *binding*) collect `(,(car x) ',(cdr x))) (lispbreak)))) (t (push *binding* *conflict-set*) (setq *last-pbreak* *binding*) (break)))) (t (setq *last-pbreak* nil)))) (defmacro fact (&rest x) `(add-fact ,(quotify x))) (defun loadfacts (lst) (loop for x in lst do (add-fact x))) ;-------------------------------------------------------------------------- ; How to add new facts to the system ;-------------------------------------------------------------------------- (defun add-fact (x) (setq *cycle* (add1 *cycle*)) (and *trace* (printline TT "Adding fact:" TT *cycle* B x)) (let ((new-fact (make-fact cycle *cycle* value x ))) (push new-fact *fcts*) (loop with node = *root* and lstx = (list x) and val and next and stk and path while node do (loop for b in (net-node-binding-nodes node) do (add-binding new-fact b)) (setq val #+LispM ;as per comment 15. (and (setq path (net-node-path node)) (condition-case () (apply path lstx) (error (cxxr (string-reverse (get-pname path)) x)))) #+Franz ;as per comment 15. (and (net-node-path node) (apply (net-node-path node) lstx)) next (and val (cdr (assq val (net-node-assoc-branch node)))) node (cond (next (and (net-node-else-branch node) (push (net-node-else-branch node) stk)) next) ((net-node-else-branch node)) (t (pop stk))))))) (defun add-binding (fact bind-node) (let ((var-list (unify (bind-node-pattern bind-node) (fact-value fact))) new-binding) (y-if (and (not (eq var-list '$$fail)) (run-tests (bind-node-vars bind-node) var-list (bind-node-test-list bind-node))) (setq new-binding (make-binding fact-list (list fact) var-list var-list back-link (bind-node-next-node bind-node))) (add-occurrences new-binding (ncons fact)) (selectq ;(car (bind-node-next-node bind-node));bad defstruct place? (my-defstruct-name (bind-node-next-node bind-node)) (join-node (add-binding2 new-binding (bind-node-next-node bind-node) (bind-node-join-how bind-node))) (rule (check-not-nodes new-binding (bind-node-next-node bind-node))) (not-node (add-block new-binding (bind-node-next-node bind-node))) (t nil))))) (defun add-binding2 (binding join-node how) ; how is 'left or 'right (loop for cmp in (selectq how (left (setf (join-node-left-bindings join-node) (cons binding (join-node-left-bindings join-node))) (join-node-right-bindings join-node)) (right (setf (join-node-right-bindings join-node) (cons binding (join-node-right-bindings join-node))) (join-node-left-bindings join-node)) (t nil)) with var-lst and next and join-binding do (setq var-lst (selectq how (left (join-bindings binding cmp (join-node-vars join-node) (join-node-test-list join-node))) (right (join-bindings cmp binding (join-node-vars join-node) (join-node-test-list join-node))) (t nil))) when (not (eq var-lst '$$fail)) do (setq next (join-node-next-node join-node)) (setq join-binding (make-binding fact-list (selectq how (left (append (binding-fact-list binding) (binding-fact-list cmp))) (right (append (binding-fact-list cmp) (binding-fact-list binding))) (t nil)) var-list var-lst back-link next)) (add-occurrences join-binding (binding-fact-list join-binding)) (selectq ;(car next);another bad defstruct place (my-defstruct-name next) (rule (check-not-nodes join-binding next)) (not-node (add-block join-binding next)) (join-node (add-binding2 join-binding next 'left)) nil))) (defun check-not-nodes (binding rule) (loop for not-node in (rule-not-nodes rule) thereis (loop for cmp in (not-node-not-bindings not-node) with var-list do (setq var-list (join-bindings binding cmp (not-node-all-vars not-node) (not-node-test-list not-node))) thereis (y-if (not (eq var-list '$$fail)) (setf (binding-back-link binding) not-node) (setf (not-node-blocked-bindings not-node) (cons binding (not-node-blocked-bindings not-node))))) finally ; did not fail (progn (setf (binding-back-link binding) rule) (return (add-conflict-set binding))))) (defun add-block (binding not-node) (setf (not-node-not-bindings not-node) (cons binding (not-node-not-bindings not-node))) (loop for cmp in *conflict-set* unless (y-if (and (eq (not-node-rule not-node) (binding-back-link cmp)) (not (eq (join-bindings cmp binding (not-node-all-vars not-node) (not-node-test-list not-node)) '$$fail))) (setf (binding-back-link cmp) not-node) (setf (not-node-blocked-bindings not-node) (cons cmp (not-node-blocked-bindings not-node)))) collect cmp into $$val finally (setq *conflict-set* $$val))) (defun join-bindings (b1 b2 vars test-list) (loop for x in (binding-var-list b2) with var-pair and var-list unless (progn (setq var-pair (assq (car x) (binding-var-list b1))) (and var-pair (not (equal (cdr var-pair) (cdr x))) (return '$$fail)) var-pair) collect x into $$val finally (setq var-list (append (binding-var-list b1) $$val)) (y-if (run-tests vars var-list test-list) then (return var-list) else (return '$$fail)))) (defun run-tests (vars var-lst test-list) (or (null test-list) (apply `(lambda ,vars (and ,@test-list)) (loop for v in var-lst collect (cdr v))))) (defun add-occurrences (binding fct-lst) (loop for f in fct-lst do (setf (fact-bindings f) (cons binding (fact-bindings f))))) ;-------------------------------------------------------------------------- ; The following functions sort the conflict set according to the requested ; strategy. By default, the system sorts the conflict set by the ages of ; the newest goals. ;-------------------------------------------------------------------------- (defun directed-strategy (&optional (x 'goal)) (cond ((eq x *strategy*)) (t (setq *strategy* x) (resort-conflict-set)))) (defun age-only-strategy nil (cond ((null *strategy*)) (t (setq *strategy* nil) (resort-conflict-set)))) (defun prstrategy nil (cond (*strategy* (printline "(directed-strategy " '*strategy* ")")) (t (printline "(age-only-strategy)")))) (defun resort-conflict-set nil (loop for b in *conflict-set* do (setf (binding-age-list b) (get-ages (binding-fact-list b))) finally (return (sort *conflict-set* 'cmp-ages)))) (defun add-conflict-set (b) (setf (binding-age-list b) (get-ages (binding-fact-list b))) (setq *conflict-set* (y-insert b *conflict-set* 'cmp-ages))) (defun get-ages (fact-list) (cond (*strategy* (loop for f in fact-list with lst1 and lst2 do (cond ((eq (car (fact-value f)) *strategy*) (push (fact-cycle f) lst1)) (t (push (fact-cycle f) lst2))) finally (return (cons (sort lst1 'greaterp) (sort lst2 'greaterp))))) (t (loop for f in fact-list collect (fact-cycle f) into $$val finally (return (sort $$val 'greaterp)))))) (defun cmp-ages (b1 b2) (cond (*strategy* (let ((cmp1 (cmp-lsts (car (binding-age-list b1)) (car (binding-age-list b2))))) (cond ((eq cmp1 'eq) (cmp-lsts (cdr (binding-age-list b1)) (cdr (binding-age-list b2)))) (t cmp1)))) (t (cmp-lsts (binding-age-list b1) (binding-age-list b2))))) (defun cmp-lsts (lst1 lst2) (loop for n1 in lst1 and n2 in lst2 do (cond ((greaterp n1 n2) (return t)) ((greaterp n2 n1) (return nil))) finally (return (cond (n1 t) (n2 nil) (t 'eq))))) ;-------------------------------------------------------------------------- ; Remove facts from the data base. ;-------------------------------------------------------------------------- (defun y-remove (&rest lst) (cond ((and (boundp '*binding*) *binding*) (loop for x in lst do (remove-fact (nth (sub1 x) (binding-fact-list *binding*))))) (t (printline "Use 'rm' when not in the scope of a rhs") nil))) (defun rm (&rest lst) (y-if (eq (car lst) '*) then (loop for f in *fcts* do (remove-fact f)) else (loop for cycle in lst do (loop for f in *fcts* thereis (y-if (eq (fact-cycle f) cycle) (remove-fact f) t))))) (defun remove-fact (f) (and *trace* (printline TT "Removing: " TT (fact-cycle f) " " (fact-value f))) (setq *fcts* (delq f *fcts* 1)) (loop for b in (fact-bindings f) with back-link and bdg-lst do (setq back-link (binding-back-link b)) (selectq ;(car back-link);bad defstruct place (my-defstruct-name back-link) (rule (setq *conflict-set* (delq b *conflict-set* 1))) (join-node (setf (join-node-left-bindings back-link) (delq b (join-node-left-bindings back-link) 1)) (setf (join-node-right-bindings back-link) (delq b (join-node-right-bindings back-link) 1))) (not-node (cond ((memq b (not-node-not-bindings back-link)) (setf (not-node-not-bindings back-link) (delq b (not-node-not-bindings back-link) 1)) (setq bdg-lst (not-node-blocked-bindings back-link)) (setf (not-node-blocked-bindings back-link) nil) (loop for bdg in bdg-lst do (check-not-nodes bdg (not-node-rule back-link)))) (t (setf (not-node-blocked-bindings back-link) (delq b (not-node-blocked-bindings back-link) 1))))) (t nil)) (remove-bdg b f))) (defun remove-bdg (b f) (loop for ff in (binding-fact-list b) unless (eq ff f) do (setf (fact-bindings ff) (delq b (fact-bindings ff) 1)))) ;-------------------------------------------------------------------------- ; More user functions: querying data base state ;-------------------------------------------------------------------------- (defun db nil (loop for f in (reverse *fcts*) initially (printline "Cycle" TT "Fact") do (printline (fact-cycle f) " " TT (fact-value f)))) (defun cs nil (loop for b in *conflict-set* for i from 1 initially (printline "Number" TT "Name") do (printline i "." TT (rule-name (binding-back-link b))))) (defun rmcs (&rest lst) (loop for b in *conflict-set* for i from 1 unless (memq i lst) collect b into $$val finally (progn (setq *conflict-set* $$val) nil))) (defun matches (&rest lst) (loop for b in *conflict-set* for i from 1 when (or (null lst) (memq (binding-back-link b) lst)) do (loop for f in (binding-fact-list b) initially (printline "Facts matched by rule " (binding-back-link b) ", binding number " i) do (printline TT (fact-cycle f) " " (fact-value f))))) (defun refresh (&rest lst) (let (lst2) (cond ((and lst *binding*) (loop for x in lst with f and flst = (binding-fact-list *binding*) do (remove-fact (setq f (nth (sub1 x) flst))) collect (fact-value f) into $$val finally (setq lst2 $$val))) (lst (printline "Use 'ref' when not in the scope of a rhs")) (t (loop for f in (nreverse *fcts*) do (remove-fact f) collect (fact-value f)into $$val finally (setq lst2 $$val)))) (loop for f in lst2 do (add-fact f)))) (defun ref (&rest cycles) (let (lst) (cond (cycles (loop for cycle in cycles do (loop for f in *fcts* thereis (y-if (eq (fact-cycle f) cycle) (remove-fact f) (push (fact-value f) lst)) finally ; fact not found (printline cycle " is not a cycle for a fact in" " the database")))) (t (loop for f in (nreverse *fcts*) do (remove-fact f) (push (fact-value f) lst)))) (loop for f in (nreverse lst) do (add-fact f)))) ;-------------------------------------------------------------------------- ; Debugging facilities: yapstrace, breakpoints ;-------------------------------------------------------------------------- (defun yapstrace nil (setq *trace* t)) (defun yapsuntrace nil (setq *trace* nil)) (defun pbreak (&rest lst) (loop for p in lst unless (memq p *pbreaks*) do (push p *pbreaks*))) (defun unpbreak (&rest lst) (loop for p in *pbreaks* unless (memq p lst) collect p into $$val finally (progn (setq *pbreaks* $$val) nil))) (defun prbreaks nil (loop for p in *pbreaks* initially (printline "Current break points:") do (printline TT p))) ;-------------------------------------------------------------------------- ; Utility functions ;-------------------------------------------------------------------------- (declare (special *paths* *vars*)) (defun getpaths (x) ; getpaths returns (path-list . vars) where path-list is (path . atom) (let ((*paths* (ncons nil)) (*vars* (ncons nil))) (getpaths2 x nil) (rplacd *paths* (car *vars*)))) (defun getpaths2 (x sofar) (cond ((null x)) ((eq x '-)) ((varp x) (or (memq x (car *vars*)) (tconc *vars* x))) ((atom x) (tconc *paths* (cons (loop for x in sofar with path initially (setq path 'c) do (setq path (concat path x)) finally (return (concat path 'r))) x))) (t (getpaths2 (car x) (cons 'a sofar)) (getpaths2 (cdr x) (cons 'd sofar))))) (defun varp (x) (and (symbolp x) (string-equal (y-substring (get-pname x) 0 1) "-"))) (defun getvars (x) (let ((*vars* (ncons nil))) (getvars2 x) (car *vars*))) (defun getvars2 (x) (cond ((eq x '-)) ((varp x) (or (memq x (car *vars*)) (tconc *vars* x))) ((atom x)) (t (getvars2 (car x)) (getvars2 (cdr x))))) (defun unify (pat fact) (let (*vars*) (cond ((eq (attempt (unify2 pat fact)) '$$fail) '$$fail) (t (nreverse *vars*))))) (defun unify2 (pat fact) (let (bnd) (cond ((eq pat '-)) ((varp pat) (setq bnd (assq pat *vars*)) (cond ((and bnd (equal (cdr bnd) fact))) (bnd (fail)) (t (push (cons pat fact) *vars*)))) ((numberp pat) (or (and (numberp fact) (zerop (difference pat fact))) (fail))) ((eq pat fact)) ((atom pat) (fail)) (t (unify2 (car pat) (car fact)) (unify2 (cdr pat) (cdr fact)))))) (defun allmemq (lst1 lst2) (loop for x in lst1 always (memq x lst2))) (defun quotify (x) (cond ((varp x) x) ((atom x) `',x) ((eq (car x) '|^|) (cdr x)) (t (loop for y on x with tail collect (cond ((atom y) (setq tail y) (setq y nil) (y-if (varp tail) then tail else `',tail)) (t (quotify (car y)))) into $$val finally (y-if tail then (return `(list* ,@$$val)) else (return `(list ,@$$val))))))) (defun y-insert (x lst fcn) (cond ((null lst) (ncons x)) ((apply fcn (list x (car lst))) (cons x lst)) (t (loop for y in (cdr lst) for back on lst do (y-if (apply fcn (list x y)) (rplacd back (cons x (cdr back))) (return lst)) finally ; x belongs at the end (progn (rplacd back (ncons x)) (return lst)))))) (defmacro <> (&rest x) `(not (equal ,@x))) (defun cxxr (path-string x) (cond ((string-equal (y-substring path-string 0 1) "r") (cxxr (y-substring path-string 1) x)) ((string-equal (y-substring path-string 0 1) "d") (and (listp x) (cxxr (y-substring path-string 1) (cdr x)))) ((string-equal (y-substring path-string 0 1) "a") (and (listp x) (cxxr (y-substring path-string 1) (car x)))) ((string-equal (y-substring path-string 0 1) "c") x))) ;--------------------------------------------------------------------------