Copy Link
Add to Bookmark
Report
AIList Digest Volume 5 Issue 026
AIList Digest Friday, 30 Jan 1987 Volume 5 : Issue 26
Today's Topics:
Code - AI Expert Magazine Sources (Part 7 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 7 of 22)
X
X(defun and-left (outs mem tests)
X (prog (fp dp memdp tlist tst lind rind res)
X (setq fp *flag-part*)
X (setq dp *data-part*)
X fail (and (null mem) (return nil))
X (setq memdp (car mem))
X (setq mem (cdr mem))
X (setq tlist tests)
X tloop (and (null tlist) (go succ))
X (setq tst (car tlist))
X (setq tlist (cdr tlist))
X (setq lind (car tlist))
X (setq tlist (cdr tlist))
X (setq rind (car tlist))
X (setq tlist (cdr tlist))
X ;the next line differs in and-left & -right
X (setq res (funcall tst (gelm memdp rind) (gelm dp lind)))
X (cond (res (go tloop))
X (t (go fail)))
X succ ;the next line differs in and-left & -right
X (sendto fp (cons (car memdp) dp) 'left outs)
X (go fail)))
X
X(defun and-right (outs mem tests)
X (prog (fp dp memdp tlist tst lind rind res)
X (setq fp *flag-part*)
X (setq dp *data-part*)
X fail (and (null mem) (return nil))
X (setq memdp (car mem))
X (setq mem (cdr mem))
X (setq tlist tests)
X tloop (and (null tlist) (go succ))
X (setq tst (car tlist))
X (setq tlist (cdr tlist))
X (setq lind (car tlist))
X (setq tlist (cdr tlist))
X (setq rind (car tlist))
X (setq tlist (cdr tlist))
X ;the next line differs in and-left & -right
X (setq res (funcall tst (gelm dp rind) (gelm memdp lind)))
X (cond (res (go tloop))
X (t (go fail)))
X succ ;the next line differs in and-left & -right
X (sendto fp (cons (car dp) memdp) 'right outs)
X (go fail)))
X
X
X(defun teqb (new eqvar)
X (cond ((eq new eqvar) t)
X ((not (numberp new)) nil)
X ((not (numberp eqvar)) nil)
X ((=alg new eqvar) t)
X (t nil)))
X
X(defun tneb (new eqvar)
X (cond ((eq new eqvar) nil)
X ((not (numberp new)) t)
X ((not (numberp eqvar)) t)
X ((=alg new eqvar) nil)
X (t t)))
X
X(defun tltb (new eqvar)
X (cond ((not (numberp new)) nil)
X ((not (numberp eqvar)) nil)
X ((greaterp eqvar new) t)
X (t nil)))
X
X(defun tgtb (new eqvar)
X (cond ((not (numberp new)) nil)
X ((not (numberp eqvar)) nil)
X ((greaterp new eqvar) t)
X (t nil)))
X
X(defun tgeb (new eqvar)
X (cond ((not (numberp new)) nil)
X ((not (numberp eqvar)) nil)
X ((not (greaterp eqvar new)) t)
X (t nil)))
X
X(defun tleb (new eqvar)
X (cond ((not (numberp new)) nil)
X ((not (numberp eqvar)) nil)
X ((not (greaterp new eqvar)) t)
X (t nil)))
X
X(defun txxb (new eqvar)
X (cond ((numberp new)
X (cond ((numberp eqvar) t)
X (t nil)))
X (t
X (cond ((numberp eqvar) nil)
X (t t)))))
X
X
X(defun &p (rating name var-dope ce-var-dope rhs)
X (prog (fp dp)
X (cond (*sendtocall*
X (setq fp *flag-part*)
X (setq dp *data-part*))
X (t
X (setq fp *alpha-flag-part*)
X (setq dp *alpha-data-part*)))
X (and (member fp '(nil old)) (removecs name dp))
X (and fp (insertcs name dp rating))))
X
X(defun &old (a b c d e) nil) ;a null function used for deleting node
X
X(defun ¬ (outs lmem rpred tests)
X (cond ((and (eq *side* 'right) (eq *flag-part* 'old)) nil)
X ((eq *side* 'right) (not-right outs (car lmem) tests))
X (t (not-left outs (memory-part rpred) tests lmem))))
X
X(defun not-left (outs mem tests own-mem)
X (prog (fp dp memdp tlist tst lind rind res c)
X (setq fp *flag-part*)
X (setq dp *data-part*)
X (setq c 0.)
X fail (and (null mem) (go fin))
X (setq memdp (car mem))
X (setq mem (cdr mem))
X (setq tlist tests)
X tloop (and (null tlist) (setq c (1+ c)) (go fail))
X (setq tst (car tlist))
X (setq tlist (cdr tlist))
X (setq lind (car tlist))
X (setq tlist (cdr tlist))
X (setq rind (car tlist))
X (setq tlist (cdr tlist))
X ;the next line differs in not-left & -right
X (setq res (funcall tst (gelm memdp rind) (gelm dp lind)))
X (cond (res (go tloop))
X (t (go fail)))
X fin (add-token own-mem fp dp c)
X (and (== c 0.) (sendto fp dp 'left outs))))
X
X(defun not-right (outs mem tests)
X (prog (fp dp memdp tlist tst lind rind res newfp inc newc)
X (setq fp *flag-part*)
X (setq dp *data-part*)
X (cond ((not fp) (setq inc -1.) (setq newfp 'new))
X ((eq fp 'new) (setq inc 1.) (setq newfp nil))
X (t (return nil)))
X fail (and (null mem) (return nil))
X (setq memdp (car mem))
X (setq newc (cadr mem))
X (setq tlist tests)
X tloop (and (null tlist) (go succ))
X (setq tst (car tlist))
X (setq tlist (cdr tlist))
X (setq lind (car tlist))
X (setq tlist (cdr tlist))
X (setq rind (car tlist))
X (setq tlist (cdr tlist))
X ;the next line differs in not-left & -right
X (setq res (funcall tst (gelm dp rind) (gelm memdp lind)))
X (cond (res (go tloop))
X (t (setq mem (cddr mem)) (go fail)))
X succ (setq newc (+ inc newc))
X (rplaca (cdr mem) newc)
X (cond ((or (and (== inc -1.) (== newc 0.))
X (and (== inc 1.) (== newc 1.)))
X (sendto newfp memdp 'right outs)))
X (setq mem (cddr mem))
X (go fail)))
X
X
X
X;;; Node memories
X
X
X(defun add-token (memlis flag data-part num)
X (prog (was-present)
X (cond ((eq flag 'new)
X (setq was-present nil)
X (real-add-token memlis data-part num))
X ((not flag)
X (setq was-present (remove-old memlis data-part num)))
X ((eq flag 'old) (setq was-present t)))
X (return was-present)))
X
X(defun real-add-token (lis data-part num)
X (setq *current-token* (1+ *current-token*))
X (cond (num (rplaca lis (cons num (car lis)))))
X (rplaca lis (cons data-part (car lis))))
X
X(defun remove-old (lis data num)
X (cond (num (remove-old-num lis data))
X (t (remove-old-no-num lis data))))
X
X(defun remove-old-num (lis data)
X (prog (m next last)
X (setq m (car lis))
X (cond ((atom m) (return nil))
X ((top-levels-eq data (car m))
X (setq *current-token* (1- *current-token*))
X (rplaca lis (cddr m))
X (return (car m))))
X (setq next m)
X loop (setq last next)
X (setq next (cddr next))
X (cond ((atom next) (return nil))
X ((top-levels-eq data (car next))
X (rplacd (cdr last) (cddr next))
X (setq *current-token* (1- *current-token*))
X (return (car next)))
X (t (go loop)))))
X
X(defun remove-old-no-num (lis data)
X (prog (m next last)
X (setq m (car lis))
X (cond ((atom m) (return nil))
X ((top-levels-eq data (car m))
X (setq *current-token* (1- *current-token*))
X (rplaca lis (cdr m))
X (return (car m))))
X (setq next m)
X loop (setq last next)
X (setq next (cdr next))
X (cond ((atom next) (return nil))
X ((top-levels-eq data (car next))
X (rplacd last (cdr next))
X (setq *current-token* (1- *current-token*))
X (return (car next)))
X (t (go loop)))))
X
X
X
X;;; Conflict Resolution
X;
X;
X; each conflict set element is a list of the following form:
X; ((p-name . data-part) (sorted wm-recency) special-case-number)
X
X(defun removecs (name data)
X (prog (cr-data inst cs)
X (setq cr-data (cons name data))
X (setq cs *conflict-set*)
X loop1 (cond ((null cs)
X (record-refract name data)
X (return nil)))
X (setq inst (car cs))
X (setq cs (cdr cs))
X (and (not (top-levels-eq (car inst) cr-data)) (go loop1))
X (setq *conflict-set* (delete inst *conflict-set* :test #'eq))))
X
X(defun insertcs (name data rating)
X (prog (instan)
X (and (refracted name data) (return nil))
X (setq instan (list (cons name data) (order-tags data) rating))
X (and (atom *conflict-set*) (setq *conflict-set* nil))
X (return (setq *conflict-set* (cons instan *conflict-set*)))))
X
X(defun order-tags (dat)
X (prog (tags)
X (setq tags nil)
X l1 (and (atom dat) (go l2))
X (setq tags (cons (creation-time (car dat)) tags))
X (setq dat (cdr dat))
X (go l1)
X l2 (cond ((eq *strategy* 'mea)
X (return (cons (car tags) (dsort (cdr tags)))))
X (t (return (dsort tags))))))
X
X; destructively sort x into descending order
X
X(defun dsort (x)
X (prog (sorted cur next cval nval)
X (and (atom (cdr x)) (return x))
X loop (setq sorted t)
X (setq cur x)
X (setq next (cdr x))
X chek (setq cval (car cur))
X (setq nval (car next))
X (cond ((> nval cval)
X (setq sorted nil)
X (rplaca cur nval)
X (rplaca next cval)))
X (setq cur next)
X (setq next (cdr cur))
X (cond ((not (null next)) (go chek))
X (sorted (return x))
X (t (go loop)))))
X
X(defun conflict-resolution nil
X (prog (best len)
X (setq len (length *conflict-set*))
X (cond ((> len *max-cs*) (setq *max-cs* len)))
X (setq *total-cs* (+ *total-cs* len))
X (cond (*conflict-set*
X (setq best (best-of *conflict-set*))
X (setq *conflict-set* (delete best *conflict-set* :test #'eq))
X (return (pname-instantiation best)))
X (t (return nil)))))
X
X(defun best-of (set) (best-of* (car set) (cdr set)))
X
X(defun best-of* (best rem)
X (cond ((not rem) best)
X ((conflict-set-compare best (car rem))
X (best-of* best (cdr rem)))
X (t (best-of* (car rem) (cdr rem)))))
X
X(defun remove-from-conflict-set (name)
X (prog (cs entry)
X l1 (setq cs *conflict-set*)
X l2 (cond ((atom cs) (return nil)))
X (setq entry (car cs))
X (setq cs (cdr cs))
X (cond ((eq name (caar entry))
X (setq *conflict-set* (delete entry *conflict-set* :test #'eq))
X (go l1))
X (t (go l2)))))
X
X(defun pname-instantiation (conflict-elem) (car conflict-elem))
X
X(defun order-part (conflict-elem) (cdr conflict-elem))
X
X(defun instantiation (conflict-elem)
X (cdr (pname-instantiation conflict-elem)))
X
X
X(defun conflict-set-compare (x y)
X (prog (x-order y-order xl yl xv yv)
X (setq x-order (order-part x))
X (setq y-order (order-part y))
X (setq xl (car x-order))
X (setq yl (car y-order))
X data (cond ((and (null xl) (null yl)) (go ps))
X ((null yl) (return t))
X ((null xl) (return nil)))
X (setq xv (car xl))
X (setq yv (car yl))
X (cond ((> xv yv) (return t))
X ((> yv xv) (return nil)))
X (setq xl (cdr xl))
X (setq yl (cdr yl))
X (go data)
X ps (setq xl (cdr x-order))
X (setq yl (cdr y-order))
X psl (cond ((null xl) (return t)))
X (setq xv (car xl))
X (setq yv (car yl))
X (cond ((> xv yv) (return t))
X ((> yv xv) (return nil)))
X (setq xl (cdr xl))
X (setq yl (cdr yl))
X (go psl)))
X
X
X(defun conflict-set nil
X (prog (cnts cs p z best)
X (setq cnts nil)
X (setq cs *conflict-set*)
X l1 (and (atom cs) (go l2))
X (setq p (caaar cs))
X (setq cs (cdr cs))
X (setq z (assoc p cnts :test #'eq))
X (cond ((null z) (setq cnts (cons (cons p 1.) cnts)))
X (t (rplacd z (1+ (cdr z)))))
X (go l1)
X l2 (cond ((atom cnts)
X (setq best (best-of *conflict-set*))
X (terpri)
X (return (list (caar best) 'dominates))))
X (terpri)
X (princ (caar cnts))
X (cond ((> (cdar cnts) 1.)
X (princ '| (|)
X (princ (cdar cnts))
X (princ '| occurrences)|)))
X (setq cnts (cdr cnts))
X (go l2)))
X
X
X
X;;; WM maintaining functions
X;
X; The order of operations in the following two functions is critical.
X; add-to-wm order: (1) change wm (2) record change (3) match
X; remove-from-wm order: (1) record change (2) match (3) change wm
X; (back will not restore state properly unless wm changes are recorded
X; before the cs changes that they cause) (match will give errors if
X; the thing matched is not in wm at the time)
X
X
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 (member fa *wmpart-list* :test #'eq)
X (setq *wmpart-list* (cons fa *wmpart-list*)))
X (setq part (get fa 'wmpart*))
X (cond (override (setq timetag override))
X (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
X; remove-from-wm uses eq, not equal to determine if wme is present
X
X(defun remove-from-wm (wme)
X (prog (fa z part timetag port)
X (setq fa (wm-hash wme))
X (setq part (get fa 'wmpart*))
X (setq z (assoc wme part :test #'eq))
X (or z (return nil))
X (setq timetag (cdr z))
X (cond ((and *wtrace* *in-rhs*)
X (setq port (trace-file))
X (terpri port)
X (princ '|<=wm: | port)
X (ppelm wme port)))
X (setq *action-count* (1+ *action-count*))
X (setq *critical* t)
X (setq *current-wm* (1- *current-wm*))
X (record-change '<=wm timetag wme)
X (match nil wme)
X (putprop fa (delete z part :test #'eq) 'wmpart* )
X (setq *critical* nil)))
X
X; mapwm maps down the elements of wm, applying fn to each element
X; each element is of form (datum . creation-time)
X
X(defun mapwm (fn)
X (prog (wmpl part)
X (setq wmpl *wmpart-list*)
X lab1 (cond ((atom wmpl) (return nil)))
X (setq part (get (car wmpl) 'wmpart*))
X (setq wmpl (cdr wmpl))
X (mapc fn part)
X (go lab1)))
X
X(defmacro wm (&rest a)
X `(progn
X (mapc (function (lambda (z) (terpri) (ppelm z t)))
X (get-wm ',a))
X nil) )
X
X(defun get-wm (z)
X (setq *wm-filter* z)
X (setq *wm* nil)
X (mapwm (function get-wm2))
X (prog2 nil *wm* (setq *wm* nil)))
X
X(defun get-wm2 (elem)
X (cond ((or (null *wm-filter*) (member (cdr elem) *wm-filter*))
X (setq *wm* (cons (car elem) *wm*)))))
X
X(defun wm-hash (x)
X (cond ((not x) '<default>)
X ((not (car x)) (wm-hash (cdr x)))
X ((symbolp (car x)) (car x))
X (t (wm-hash (cdr x)))))
X
X(defun creation-time (wme)
X (cdr (assoc wme (get (wm-hash wme) 'wmpart*) :test #'eq)))
X
X(defun rehearse nil
X (prog nil
X (setq *old-wm* nil)
X (mapwm (function refresh-collect))
X (mapc (function refresh-del) *old-wm*)
X (mapc (function refresh-add) *old-wm*)
X (setq *old-wm* nil)))
X
X(defun refresh-collect (x) (setq *old-wm* (cons x *old-wm*)))
X
X(defun refresh-del (x) (remove-from-wm (car x)))
X
X(defun refresh-add (x) (add-to-wm (car x) (cdr x)))
X
X(defun trace-file ()
X (prog (port)
X (setq port t)
X (cond (*trace-file*
X (setq port ($ofile *trace-file*))
X (cond ((null port)
X (%warn '|trace: file has been closed| *trace-file*)
X (setq port t)))))
X (return port)))
X
X
X;;; Basic functions for RHS evaluation
X
X(defun eval-rhs (pname data)
X (prog (node port)
X (cond (*ptrace*
X (setq port (trace-file))
X (terpri port)
X (princ *cycle-count* port)
X (princ '|. | port)
X (princ pname port)
X (time-tag-print data port)))
X (setq *data-matched* data)
X (setq *p-name* pname)
X (setq *last* nil)
X (setq node (get pname 'topnode))
X (init-var-mem (var-part node))
X (init-ce-var-mem (ce-var-part node))
X (begin-record pname data)
X (setq *in-rhs* t)
X (eval (rhs-part node))
X (setq *in-rhs* nil)
X (end-record)))
X
X(defun time-tag-print (data port)
X (cond ((not (null data))
X (time-tag-print (cdr data) port)
X (princ '| | port)
X (princ (creation-time (car data)) port))))
X
X(defun init-var-mem (vlist)
X (prog (v ind r)
X (setq *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 (gelm *data-matched* ind))
X (setq *variable-memory* (cons (cons v r) *variable-memory*))
X (go top)))
X
------------------------------
End of AIList Digest
********************
