Copy Link
Add to Bookmark
Report
AIList Digest Volume 5 Issue 023
AIList Digest Friday, 30 Jan 1987 Volume 5 : Issue 23
Today's Topics:
Code - AI Expert Magazine Sources (Part 4 of 22)
----------------------------------------------------------------------
Date: 19 Jan 87 03:36:40 GMT
From: imagen!turner@ucbvax.Berkeley.EDU (D'arc Angel)
Subject: AI Expert Magazine Sources (Part 4 of 22)
X
X
X;This version of cmp-p is used when compiling patterns on the
X;righthand side in which we want variable bindings consistent
X;with variable bindings on the LHS. Effectively, the RHS
X;pattern is just treated as a continuation of the LHS
X;pattern, except, of course, that the results of the RHS
X;pattern match will not affect the firing of the production.
X(defun ipm-cmp-p-recursive (name matrix)
X (prog (m bakptrs srhs frhs)
X (push-global-variables '*cmp-p-context-stack* '*matrix*
X '*feature-count* '*ce-count*
X '*vars* '*ce-vars*
X '*rhs-bound-vars* '*rhs-bound-ce-vars*
X '*last-branch* '*last-node*)
X (prepare-lex matrix)
X(setq *rhs-bound-vars* nil)
X(setq *rhs-bound-ce-vars* nil)
X (setq m (rest-of-p))
X l1 (and (end-of-p) (\%error '|no '-->' in production| m))
X (cmp-prin)
X (setq bakptrs (cons *last-branch* bakptrs))
X (or (eq '--> (peek-lex)) (go l1))
X (lex)
X(setq srhs (rest-of-p)) ; get righthand side
X(if (setq frhs (cdr (memq '<-- srhs)))
(setq srhs (remove-frhs srhs)))
X(ipm-check-rhs srhs)
X;note, we change the structure of the &query node to have a tail
X;component. This is the action to take on a failed pattern match
X (link-new-node (list '&query
X *feature-count*
X name
X (encode-dope)
X (encode-ce-dope)
X (cons 'progn srhs)
X (cons 'progn frhs)))
X (putprop name (cdr (nreverse bakptrs)) 'backpointers)
X(putprop name matrix 'production)
X (putprop name *last-node* 'topnode)
X(pop-global-variables *cmp-p-context-stack*)
X))
X
X;Extract failed pattern match rhs actions from production.
X(defun remove-frhs(rhs)
X (do ((lis nil (append lis (list inp)))
X(inp (car rhs) (car rhs)))
X ((eq inp '<--)
X(return lis))
X (setq rhs (cdr rhs))
X ))
X
X;;Modified version of OPS5 cmp-p, compiles pattern match and links
X;&query node into Rete net. If pmatch occurs in the righthand side of the
; rule, then
X;nodes are linked to tree generated by rule's LHS.
X(defun ipm-cmp-p (name matrix)
X (prog (m bakptrs srhs frhs)
X (prepare-lex matrix)
X (excise-p name)
X (setq bakptrs nil)
X (setq *pcount* (1+ *pcount*))
X (setq *feature-count* 0.)
X(setq *ce-count* 0)
X (setq *vars* nil)
X (setq *ce-vars* nil)
X(setq *rhs-bound-vars* nil)
X(setq *rhs-bound-ce-vars* nil)
X (setq *last-branch* nil)
X (setq m (rest-of-p))
X l1 (and (end-of-p) (\%error '|no '-->' in production| m))
X (cmp-prin)
X (setq bakptrs (cons *last-branch* bakptrs))
X (or (eq '--> (peek-lex)) (go l1))
X (lex)
X(setq srhs (rest-of-p)) ; get righthand side
X(if (setq frhs (cdr (memq '<-- srhs)))
X (setq srhs (remove-frhs srhs)))
X(ipm-check-rhs srhs)
X;note, we change the structure of the &query node to have a tail
X;component. This is the action to take on a failed pattern match
X (link-new-node (list '&query
*feature-count*
X name
X (encode-dope)
X (encode-ce-dope)
X (cons 'progn srhs)
X (cons 'progn frhs)))
X(terpri)
X (putprop name (cdr (nreverse bakptrs)) 'backpointers)
X(putprop name matrix 'production)
X (putprop name *last-node* 'topnode)))
X
X;Modified OPS5 code, sets *compiling-rhs* variable.
X(defun check-rhs (rhs)
X (setq *compiling-rhs* t)
X (mapc (function check-action) rhs)
X (setq *compiling-rhs* nil))
X
X
X;rhs part to be evaluated upon pattern match failure
X
X(defun frhs-part (pnode) (car (last pnode)))
X
X;;returns value of last expression in RHS
X(defun query (qname)
X (ipm-eval-query qname (car (get qname 'pmatches))))
X
X;IPM-EVAL-QUERY: Given a pointer to a query and the associated data,
; this function
X;sets up the appropriate environment to evaluate the RHS of the pattern match.
X;This is a modified eval-rhs from OPS5.
X
X(defun ipm-eval-query (pname data)
X (let ((node (get pname 'topnode))
X (ans nil)
X (saved nil))
X (if (setq saved *in-rhs*) ;in case of recursive call,save system state and
X (save-system-state)) ;set saved flag
X (setq *data-matched* data)
X (setq *p-name* pname)
X (setq *last* nil)
X (setq node (get pname 'topnode))
X (ipm-init-var-mem (var-part node))
X (ipm-init-var-nmatches pname)
X (ipm-init-ce-var-mem (ce-var-part node))
X (setq *in-rhs* t)
X (setq ans
X (if (neq *NMATCHES* 0) ;if match failed, execute failpart, if any
X(eval (rhs-part node))
X(eval (frhs-part node)) ))
X (setq *in-rhs* nil)
X (if saved
X (restore-system-state))
X ans
X))
X
X;map-query is just like query, except that we are performing the
;eval operation for each match. Therefore, some of the initialization
X;must be factored out of ipm-eval-map-query.
X(defun map-query(qname)
X (let* ((node (get qname 'topnode))
X (ans nil)
X (saved nil))
X (if (setq saved *in-rhs*) ;in case of recursive call,save system state and
X (save-system-state)) ;set saved flag
X (setq *p-name* qname)
X (setq *last* nil)
X (setq ans
X (if (> (length (get qname 'pmatches)) 0)
X (mapcar '(lambda(qinstance)
X (ipm-eval-map-query qname qinstance node))
X (get qname 'pmatches))
X (eval (frhs-part node)) ))
X (if saved
X (restore-system-state))
X ans))
X
X(defun ipm-eval-map-query (qname data node)
X (let ((ans))
X (setq *data-matched* data)
X (setq node (get qname 'topnode))
X (ipm-init-var-mem (var-part node))
X (ipm-init-var-nmatches qname)
X (ipm-init-ce-var-mem (ce-var-part node))
X (setq *in-rhs* t)
X (setq ans (eval (rhs-part node)))
X (setq *in-rhs* nil)
X ans
X ))
X
X
X;the variable &nmatches is bound to the number of production
X;matches in each query. Useful for counting applications and
X;deciding if any matches succeeded.
X
X(defun ipm-init-var-nmatches(pname)
X (setq *NMATCHES* (length (get pname 'pmatches)))
X (setq *variable-memory* ;remove previous number of matches
X (remove (assoc '\<NMATCHES\> *variable-memory*) *variable-memory*))
X (setq *variable-memory* ;set up &NMATCHES environ. variable
X (cons (cons '\<NMATCHES\> *NMATCHES*)
X*variable-memory*)))
X
X;More modified OPS5 code. Initializes the variable and ce-variable bindings
X;to be consistent with the results of the pattern match.
X(defun ipm-init-var-mem (vlist)
X (prog (v ind r)
X(or *in-rhs* ;if we're in rhs, then global is already set
X (setq *variable-memory* nil))
X top (and (atom vlist) (return nil))
X (setq v (car vlist))
X (setq ind (cadr vlist))
(setq vlist (cddr vlist))
X (setq r (gelm *data-matched* ind))
X (setq *variable-memory* (cons (cons v r) *variable-memory*))
X (go top)))
X
X(defun ipm-init-ce-var-mem (vlist)
X (prog (v ind r)
X(or *in-rhs* ;if we're in rhs, then global is already set
X (setq *ce-variable-memory* nil))
X top (and (atom vlist) (return nil))
X (setq v (car vlist))
X (setq ind (cadr vlist))
X (setq vlist (cddr vlist))
X (setq r (ce-gelm *data-matched* ind))
X (setq *ce-variable-memory*
X (cons (cons v r) *ce-variable-memory*))
X (go top)))
X
X(defun save-system-state()
X (push-global-variables '*system-state-stack* '*ce-variable-memory*
'*data-matched*
X '*variable-memory* '*NMATCHES* '*p-name* '*in-rhs*))
X
X(defun restore-system-state()
X (pop-global-variables *system-state-stack*))
X
X;changed OPS5 code to accept &query
X(defun link-new-node (r)
X (cond ((not (member (car r) '(&query &p &mem &two &and ¬)))
X (setq *feature-count* (1+ *feature-count*))))
X (setq *virtual-cnt* (1+ *virtual-cnt*))
X (setq *last-node* (link-left *last-node* r)))
X
X(defun ipm-check-rhs (rhs)
X (setq *compiling-rhs* t)
X (mapc (function ipm-check-action) rhs)
X (setq *compiling-rhs* nil))
X
X(defun myreplace(x y)
X (rplaca x (car y))
X (rplacd x (cdr y)))
X
X;This check-action is called by pmatch or map-pmatch macros
X(defun ipm-check-action (x)
X (prog (a)
X (cond ((atom x)
X (%warn '|atomic action| x)
X (return nil)))
X (setq a (setq *action-type* (car x)))
X (cond ((eq a 'bind) (check-bind x))
X ((eq a 'query) nil) ;never happens?
X ((eq a 'map-query) nil) ;never happens?
X ;if we come across an unexpanded pmatch, expand and compile it.
X ;replace with result
X ((eq a 'pmatch) (myreplace x (eval x)))
X ((eq a 'map-pmatch) (myreplace x (eval x)))
((eq a 'cbind) (check-cbind x))
X ((eq a 'make) (check-make x))
X ((eq a 'modify) (check-modify x))
X ((eq a 'remove) (check-remove x))
X ((eq a 'write) (check-write x))
X ((eq a 'call) (check-call x))
X ((eq a 'halt) (check-halt x))
X ((eq a 'openfile) (check-openfile x))
X ((eq a 'closefile) (check-closefile x))
X ((eq a 'default) (check-default x))
X ((eq a 'build) (check-build x))
X (t nil) ;in a pmatch rhs, code is not restricted to OPS rhs actions.
X )))
X
X;This check action is just modified so that pmatch or map-pmatch
X;are acceptable right-hand sides.
X(defun check-action (x)
X (prog (a)
X (cond ((atom x)
X (%warn '|atomic action| x)
X (return nil)))
X (setq a (setq *action-type* (car x)))
X (cond ((eq a 'bind) (check-bind x))
X ((eq a 'query) nil) ;never happens
X ((eq a 'map-query) nil) ;never happens
X ;if we come across an unexpanded pmatch, expand and compile it.
X ;replace with result
X ((eq a 'pmatch) (myreplace x (eval x)))
X ((eq a 'map-pmatch) (myreplace x (eval x)))
X ((eq a 'cbind) (check-cbind x))
X ((eq a 'make) (check-make x))
X ((eq a 'modify) (check-modify x))
X ((eq a 'remove) (check-remove x))
X ((eq a 'write) (check-write x))
X ((eq a 'call) (check-call x))
X ((eq a 'halt) (check-halt x))
X ((eq a 'openfile) (check-openfile x))
X ((eq a 'closefile) (check-closefile x))
X ((eq a 'default) (check-default x))
X ((eq a 'build) (check-build x))
X (t (%warn '|undefined rhs action| a)))))
X
X
X;add-to-wm: modified to return timetag number of item added
X(defun add-to-wm (wme override)
X (prog (fa z part timetag port)
X (setq *critical* t)
X (setq *current-wm* (1+ *current-wm*))
X (and (> *current-wm* *max-wm*) (setq *max-wm* *current-wm*))
X (setq *action-count* (1+ *action-count*))
X (setq fa (wm-hash wme))
X (or (memq fa *wmpart-list*)
X (setq *wmpart-list* (cons fa *wmpart-list*)))
X (setq part (get fa 'wmpart*))
X (cond (override (setq timetag override))
(t (setq timetag *action-count*)))
X (setq z (cons wme timetag))
X (putprop fa (cons z part) 'wmpart*)
X (record-change '=>wm *action-count* wme)
X (match 'new wme)
X (setq *critical* nil)
X (cond ((and *in-rhs* *wtrace*)
X (setq port (trace-file))
X (terpri port)
X (princ '|=>wm: | port)
X (ppelm wme port)))
X (and *in-rhs* *mtrace* (setq *madeby*
X (cons (cons wme *p-name*) *madeby*)))
X (return timetag)))
X
X(defun &old (&rest a) nil) ;a null function used for deleting node
X
X
X;MAKESYM: Does the same thing as gensym, but allows a symbol to be passed, so
X; the resulting symbol is meaningful.
X(defun makesym(x)
X (prog(numb)
X (and (not (setq numb (get x '$cntr)))
X (setq numb 0))
X (putprop x (add1 numb) '$cntr)
X (return (concat x numb))))
X
X;CONCAT: Make a symbol from a number of symbols
X(defun concat(&rest x)
X (do ((lst x (cdr lst))
X (strng nil))
X ((null lst)
X (intern strng))
X (setq strng (concatenate 'string strng (princ-to-string (car lst))))
X ))
X
X;A general purpose gensym function. Input is
X; [atom], output is [atom]N, where N is a unique integer.
X; ie. (newsym baz) ==> baz1
X; (newsym baz) ==> baz2, etc.
X
X(defmacro newsym(x)
X `(makesym ',x))
X
X
X(defun exquery()
X (mapc #'(lambda(q) (eval `(excise ,q))) *qnames*)
X (setq *qnames* nil))
X
X;The following is a minimal test for the opsmods programs.
X;To use it, uncomment it, and load it. The code should load without
X;blowing up. Complaints about atomic actions in RHS are OK, ignore them.
X;Type
X;(setup)
X;(cs) -- foo and baz should be in the conflict set.
;Type (run 1), the program should print out a list of blocks.
X;(run) should continue until only chartreuse blocks are left.
X;While simple, this code tests for nested use of pattern matches,
; recursive calls,
X;and use of pmatch in the rhs of OPS productions.
X;(i-g-v)
X;(literalize block a b c)
X
X
X;(p baz
X; { <a> (block ^a <colour> ) }
X; (block ^a <> <colour>)
X; -->
X; (pmatch (block ^a <> <colour> )
X; -->
X; (find-block-colors ?<colour> )
X; (oremove <a> ))
X; (make block ^a chartreuse))
X
X;Test for recursive use of pmatch. (find-block-colors uses map-pmatch and
X;appears in a RHS of another pmatch)
X;(defun rtest(a )
X; ?(pmatch (args a )
X; (block ^a <a> <numb>)
X; -->
X; (find-block-colors 'green)
X; (format t "Block color ~a is ~a~%" ?<a> ?<numb>)))
X
X;(defun find-block-colors (color)
X; ?(map-pmatch (args color)
X; (block ^a <color> <numb>)
X; -->
X; (format t "~%Find-block-colors ~a ~a~%" ?<color> ?<numb>)))
X
X;(defun setup()
X; (setq *in-rhs* nil)
X; (oremove *)
X; (make block ^a green 1)
X; (make block ^a green 2)
X; (make block ^a green 3)
X; (make block ^a green 4)
X; (make block ^a green 5)
X; (make block ^a red 6)
X; (make block ^a red 7)
X; (make block ^a yellow 8)
X; (make block ^a blue 9)
X; )
X
X
XCLSUP.LIS
X
X;Common Lisp Support Functions:
X;These functions are not defined in vanilla Common Lisp, but are used
X;in the OPSMODS.l code and in OPS5.
X
X(defun putprop(name val att)
X (setf (get name att) val))
X
X(defun memq(obj lis)
X (member obj lis :test #'eq))
X
X(defun fix(num)
X (round num))
X
X
X(defun assq(item alist)
X (assoc item alist :test #'eq))
X
X(defun ncons(x) (cons x nil))
X
X(defun neq(x y) (not (eq x y)))
X
X(defun delq(obj list)
X (delete obj list :test #'eq))
X
X(defmacro comment(&optional &rest x) nil) ;comment is a noop
X
X(defun plus(x y)
X (+ x y))
X
X(defun quotient(x y)
X (/ x y))
X
X(defun flatc(x)
X (length (princ-to-string x)))
X
X
X
XCOMMON.OPS
X
X; VPS2 -- Interpreter for OPS5
X;
X; Copyright (C) 1979, 1980, 1981
X; Charles L. Forgy, Pittsburgh, Pennsylvania
X
X
X
X; Users of this interpreter are requested to contact
X
X;
X; Charles Forgy
X; Computer Science Department
X; Carnegie-Mellon University
X; Pittsburgh, PA 15213
X; or
X; Forgy@CMUA
X;
X; so that they can be added to the mailing list for OPS5. The mailing list
X; is needed when new versions of the interpreter or manual are released.
X
X
X
X;;; Definitions
X
X#+ vax (defun putprop(name val att)
X (setf (get name att) val))
X
X
X
X(proclaim '(special *matrix* *feature-count* *pcount* *vars* *cur-vars*
X *curcond* *subnum* *last-node* *last-branch* *first-node*
X *sendtocall* *flag-part* *alpha-flag-part* *data-part*
X *alpha-data-part* *ce-vars* *virtual-cnt* *real-cnt*
X *current-token* *c1* *c2* *c3* *c4* *c5* *c6* *c7* *c8* *c9*
X *c10* *c11* *c12* *c13* *c14* *c15* *c16* *c17* *c18* *c19*
X *c20* *c21* *c22* *c23* *c24* *c25* *c26* *c27* *c28* *c29*
X *c30* *c31* *c32* *c33* *c34* *c35* *c36* *c37* *c38* *c39*
X *c40* *c41* *c42* *c43* *c44* *c45* *c46* *c47* *c48* *c49*
X *c50* *c51* *c52* *c53* *c54* *c55* *c56* *c57* *c58* *c59*
X *c60* *c61* *c62* *c63* *c64* *record-array* *result-array*
X *max-cs* *total-cs* *limit-cs* *cr-temp* *side*
X *conflict-set* *halt-flag* *phase* *critical*
X *cycle-count* *total-token* *max-token* *refracts*
X *limit-token* *total-wm* *current-wm* *max-wm*
X *action-count* *wmpart-list* *wm* *data-matched* *p-name*
X *variable-memory* *ce-variable-memory*
X *max-index* ; number of right-most field in wm element
X *next-index* *size-result-array* *rest* *build-trace* *last*
X *ptrace* *wtrace* *in-rhs* *recording* *accept-file* *trace-file*
X *mtrace* *madeby* ; used to trace and record makers of elements
X *write-file* *record-index* *max-record-index* *old-wm*
X *record* *filters* *break-flag* *strategy* *remaining-cycles*
X *wm-filter* *rhs-bound-vars* *rhs-bound-ce-vars* *ppline*
X *ce-count* *brkpts* *class-list* *buckets* *action-type*
X *literals* ;stores literal definitions
X *pnames* ;stores production names
X *externals* ;tracks external declarations
X *vector-attributes* ;list of vector-attributes
X ))
X
X;(declare (localf ce-gelm gelm peek-sublex sublex
X; eval-nodelist sendto and-left and-right not-left not-right
X; top-levels-eq add-token real-add-token remove-old
X; remove-old-num remove-old-no-num removecs insertcs dsort
X; best-of best-of* conflict-set-compare =alg ))
X
X
X;;; Functions that were revised so that they would compile efficiently
X
X
X;* The function == is machine dependent\!
X;* This function compares small integers for equality. It uses EQ
X;* so that it will be fast, and it will consequently not work on all
X;* Lisps. It works in Franz Lisp for integers in [-128, 127]
X
X
X;(defun == (&rest z) (= (cadr z) (caddr z)))
X(defun == (x y) (= x y))
X
X; =ALG returns T if A and B are algebraicly equal.
X
X(defun =alg (a b) (= a b))
X
X(defmacro fast-symeval (&rest z)
X `(cond ((eq ,(car z) '*c1*) *c1*)
X ((eq ,(car z) '*c2*) *c2*)
X ((eq ,(car z) '*c3*) *c3*)
X ((eq ,(car z) '*c4*) *c4*)
X ((eq ,(car z) '*c5*) *c5*)
X ((eq ,(car z) '*c6*) *c6*)
X ((eq ,(car z) '*c7*) *c7*)
X (t (eval ,(car z))) ))
X
X; getvector and putvector are fast routines for using one-dimensional
X; arrays. these routines do no checking; they assume
X; 1. the array is a vector with 0 being the index of the first
X; element
X; 2. the vector holds arbitrary list values
X;defun versions are useful for tracing
X
X; Example call: (putvector array index value)
X
X(defmacro putvector (array_ref ind var)
X `(setf (aref ,array_ref ,ind) ,var))
X
X;(defun putvector (array_ref ind var)
X; (setf (aref array_ref ind) var))
X
X; Example call: (getvector name index)
X
X;(defmacro getvector(&rest z)
X; (list 'cxr (caddr z) (cadr z)))
X
X(defmacro getvector(array_ref ind)
X `(aref ,array_ref ,ind))
X
X;(defun getvector (array_ref ind)
X ; (aref array_ref ind))
X
X(defun ce-gelm (x k)
X (prog nil
X loop (and (== k 1.) (return (car x)))
X (setq k (1- k))
X (setq x (cdr x))
X (go loop)))
X
X; The loops in gelm were unwound so that fewer calls on DIFFERENCE
X; would be needed
X
X(defun gelm (x k)
X (prog (ce sub)
X (setq ce (floor (/ k 10000)))
X (setq sub (- k (* ce 10000)))
X celoop (and (== ce 0) (go ph2))
X (setq x (cdr x))
X (and (== ce 1) (go ph2))
X (setq x (cdr x))
X (and (== ce 2) (go ph2))
X (setq x (cdr x))
X (and (== ce 3) (go ph2))
X (setq x (cdr x))
X (and (== ce 4) (go ph2))
X (setq ce (- ce 4))
X (go celoop)
X ph2 (setq x (car x))
X subloop (and (== sub 0) (go finis))
X (setq x (cdr x))
X (and (== sub 1) (go finis))
X (setq x (cdr x))
X (and (== sub 2) (go finis))
X (setq x (cdr x))
X (and (== sub 3) (go finis))
X (setq x (cdr x))
X (and (== sub 4) (go finis))
X (setq x (cdr x))
X (and (== sub 5) (go finis))
X (setq x (cdr x))
X (and (== sub 6) (go finis))
X (setq x (cdr x))
X (and (== sub 7) (go finis))
X (setq x (cdr x))
X (and (== sub 8) (go finis))
X (setq sub (- sub 8))
X (go subloop)
X finis (return (car x))))
X
X
------------------------------
End of AIList Digest
********************
