Copy Link
Add to Bookmark
Report
AIList Digest Volume 5 Issue 025
AIList Digest Friday, 30 Jan 1987 Volume 5 : Issue 25
Today's Topics:
Code - AI Expert Magazine Sources (Part 6 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 6 of 22)
X
X(defun field-name (num)
X (cond ((= num 1.) '*c1*)
X ((= num 2.) '*c2*)
X ((= num 3.) '*c3*)
X ((= num 4.) '*c4*)
X ((= num 5.) '*c5*)
X ((= num 6.) '*c6*)
X ((= num 7.) '*c7*)
X ((= num 8.) '*c8*)
X ((= num 9.) '*c9*)
X ((= num 10.) '*c10*)
X ((= num 11.) '*c11*)
X ((= num 12.) '*c12*)
X ((= num 13.) '*c13*)
X ((= num 14.) '*c14*)
X ((= num 15.) '*c15*)
X ((= num 16.) '*c16*)
X ((= num 17.) '*c17*)
X ((= num 18.) '*c18*)
X ((= num 19.) '*c19*)
X ((= num 20.) '*c20*)
X ((= num 21.) '*c21*)
X ((= num 22.) '*c22*)
X ((= num 23.) '*c23*)
X ((= num 24.) '*c24*)
X ((= num 25.) '*c25*)
X ((= num 26.) '*c26*)
X ((= num 27.) '*c27*)
X ((= num 28.) '*c28*)
X ((= num 29.) '*c29*)
X ((= num 30.) '*c30*)
X ((= num 31.) '*c31*)
X ((= num 32.) '*c32*)
X ((= num 33.) '*c33*)
X ((= num 34.) '*c34*)
X ((= num 35.) '*c35*)
X ((= num 36.) '*c36*)
X ((= num 37.) '*c37*)
X ((= num 38.) '*c38*)
X ((= num 39.) '*c39*)
X ((= num 40.) '*c40*)
X ((= num 41.) '*c41*)
X ((= num 42.) '*c42*)
X ((= num 43.) '*c43*)
X ((= num 44.) '*c44*)
X ((= num 45.) '*c45*)
X ((= num 46.) '*c46*)
X ((= num 47.) '*c47*)
X ((= num 48.) '*c48*)
X ((= num 49.) '*c49*)
X ((= num 50.) '*c50*)
X ((= num 51.) '*c51*)
X ((= num 52.) '*c52*)
X ((= num 53.) '*c53*)
X ((= num 54.) '*c54*)
X ((= num 55.) '*c55*)
X ((= num 56.) '*c56*)
X ((= num 57.) '*c57*)
X ((= num 58.) '*c58*)
X ((= num 59.) '*c59*)
X ((= num 60.) '*c60*)
X ((= num 61.) '*c61*)
X ((= num 62.) '*c62*)
X ((= num 63.) '*c63*)
X ((= num 64.) '*c64*)
X (t (%error '|condition is too long| (rest-of-ce)))))
X
X
X;;; Compiling variables
X;
X;
X;
X; *cur-vars* are the variables in the condition element currently
X; being compiled. *vars* are the variables in the earlier condition
X; elements. *ce-vars* are the condition element variables. note
X; that the interpreter will not confuse condition element and regular
X; variables even if they have the same name.
X;
X; *cur-vars* is a list of triples: (name predicate subelement-number)
X; eg: ( (<x> eq 3)
X; (<y> ne 1)
X; . . . )
X;
X; *vars* is a list of triples: (name ce-number subelement-number)
X; eg: ( (<x> 3 3)
X; (<y> 1 1)
X; . . . )
X;
X; *ce-vars* is a list of pairs: (name ce-number)
X; eg: ( (ce1 1)
X; (<c3> 3)
X; . . . )
X
X(defun var-dope (var) (assoc var *vars* :test #'eq))
X
X(defun ce-var-dope (var) (assoc var *ce-vars* :test #'eq))
X
X(defun cmp-var (test)
X (prog (old name)
X (setq name (sublex))
X (setq old (assoc name *cur-vars* :test #'eq))
X (cond ((and old (eq (cadr old) 'eq))
X (cmp-old-eq-var test old))
X ((and old (eq test 'eq)) (cmp-new-eq-var name old))
X (t (cmp-new-var name test)))))
X
X(defun cmp-new-var (name test)
X (setq *cur-vars* (cons (list name test *subnum*) *cur-vars*)))
X
X(defun cmp-old-eq-var (test old)
X (link-new-node (list (concat3 't test 's)
X nil
X (current-field)
X (field-name (caddr old)))))
X
X(defun cmp-new-eq-var (name old)
X (prog (pred next)
X (setq *cur-vars* (delete old *cur-vars* :test #'eq))
X (setq next (assoc name *cur-vars* :test #'eq))
X (cond (next (cmp-new-eq-var name next))
X (t (cmp-new-var name 'eq)))
X (setq pred (cadr old))
X (link-new-node (list (concat3 't pred 's)
X nil
X (field-name (caddr old))
X (current-field)))))
X
X(defun cmp-cevar nil
X (prog (name old)
X (setq name (lex))
X (setq old (assoc name *ce-vars* :test #'eq))
X (and old
X (%error '|condition element variable used twice| name))
X (setq *ce-vars* (cons (list name 0.) *ce-vars*))))
X
X(defun cmp-not nil (cmp-beta '¬))
X
X(defun cmp-nobeta nil (cmp-beta nil))
X
X(defun cmp-and nil (cmp-beta '&and))
X
X(defun cmp-beta (kind)
X (prog (tlist vdope vname vpred vpos old)
X (setq tlist nil)
X la (and (atom *cur-vars*) (go lb))
X (setq vdope (car *cur-vars*))
X (setq *cur-vars* (cdr *cur-vars*))
X (setq vname (car vdope))
X (setq vpred (cadr vdope))
X (setq vpos (caddr vdope))
X (setq old (assoc vname *vars* :test #'eq))
X (cond (old (setq tlist (add-test tlist vdope old)))
X ((not (eq kind '¬)) (promote-var vdope)))
X (go la)
X lb (and kind (build-beta kind tlist))
X (or (eq kind '¬) (fudge))
X (setq *last-branch* *last-node*)))
X
X(defun add-test (list new old)
X (prog (ttype lloc rloc)
X (setq *feature-count* (1+ *feature-count*))
X (setq ttype (concat3 't (cadr new) 'b))
X (setq rloc (encode-singleton (caddr new)))
X (setq lloc (encode-pair (cadr old) (caddr old)))
X (return (cons ttype (cons lloc (cons rloc list))))))
X
X; the following two functions encode indices so that gelm can
X; decode them as fast as possible
X
X(defun encode-pair (a b) (+ (* 10000. (1- a)) (1- b)))
X
X(defun encode-singleton (a) (1- a))
X
X(defun promote-var (dope)
X (prog (vname vpred vpos new)
X (setq vname (car dope))
X (setq vpred (cadr dope))
X (setq vpos (caddr dope))
X (or (eq 'eq vpred)
X (%error '|illegal predicate for first occurrence|
X (list vname vpred)))
X (setq new (list vname 0. vpos))
X (setq *vars* (cons new *vars*))))
X
X(defun fudge nil
X (mapc (function fudge*) *vars*)
X (mapc (function fudge*) *ce-vars*))
X
X(defun fudge* (z)
X (prog (a) (setq a (cdr z)) (rplaca a (1+ (car a)))))
X
X(defun build-beta (type tests)
X (prog (rpred lpred lnode lef)
X (link-new-node (list '&mem nil nil (protomem)))
X (setq rpred *last-node*)
X (cond ((eq type '&and)
X (setq lnode (list '&mem nil nil (protomem))))
X (t (setq lnode (list '&two nil nil))))
X (setq lpred (link-to-branch lnode))
X (cond ((eq type '&and) (setq lef lpred))
X (t (setq lef (protomem))))
X (link-new-beta-node (list type nil lef rpred tests))))
X
X(defun protomem nil (list nil))
X
X(defun memory-part (mem-node) (car (cadddr mem-node)))
X
X(defun encode-dope nil
X (prog (r all z k)
X (setq r nil)
X (setq all *vars*)
X la (and (atom all) (return r))
X (setq z (car all))
X (setq all (cdr all))
X (setq k (encode-pair (cadr z) (caddr z)))
X (setq r (cons (car z) (cons k r)))
X (go la)))
X
X(defun encode-ce-dope nil
X (prog (r all z k)
X (setq r nil)
X (setq all *ce-vars*)
X la (and (atom all) (return r))
X (setq z (car all))
X (setq all (cdr all))
X (setq k (cadr z))
X (setq r (cons (car z) (cons k r)))
X (go la)))
X
X
X
X;;; Linking the nodes
X
X(defun link-new-node (r)
X (cond ((not (member (car r) '(&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 link-to-branch (r)
X (setq *virtual-cnt* (1+ *virtual-cnt*))
X (setq *last-branch* (link-left *last-branch* r)))
X
X(defun link-new-beta-node (r)
X (setq *virtual-cnt* (1+ *virtual-cnt*))
X (setq *last-node* (link-both *last-branch* *last-node* r))
X (setq *last-branch* *last-node*))
X
X(defun link-left (pred succ)
X (prog (a r)
X (setq a (left-outs pred))
X (setq r (find-equiv-node succ a))
X (and r (return r))
X (setq *real-cnt* (1+ *real-cnt*))
X (attach-left pred succ)
X (return succ)))
X
X(defun link-both (left right succ)
X (prog (a r)
X (setq a (interq (left-outs left) (right-outs right)))
X (setq r (find-equiv-beta-node succ a))
X (and r (return r))
X (setq *real-cnt* (1+ *real-cnt*))
X (attach-left left succ)
X (attach-right right succ)
X (return succ)))
X
X(defun attach-right (old new)
X (rplaca (cddr old) (cons new (caddr old))))
X
X(defun attach-left (old new)
X (rplaca (cdr old) (cons new (cadr old))))
X
X(defun right-outs (node) (caddr node))
X
X(defun left-outs (node) (cadr node))
X
X(defun find-equiv-node (node list)
X (prog (a)
X (setq a list)
X l1 (cond ((atom a) (return nil))
X ((equiv node (car a)) (return (car a))))
X (setq a (cdr a))
X (go l1)))
X
X(defun find-equiv-beta-node (node list)
X (prog (a)
X (setq a list)
X l1 (cond ((atom a) (return nil))
X ((beta-equiv node (car a)) (return (car a))))
X (setq a (cdr a))
X (go l1)))
X
X; do not look at the predecessor fields of beta nodes; they have to be
X; identical because of the way the candidate nodes were found
X
X(defun equiv (a b)
X (and (eq (car a) (car b))
X (or (eq (car a) '&mem)
X (eq (car a) '&two)
X (equal (caddr a) (caddr b)))
X (equal (cdddr a) (cdddr b))))
X
X(defun beta-equiv (a b)
X (and (eq (car a) (car b))
X (equal (cddddr a) (cddddr b))
X (or (eq (car a) '&and) (equal (caddr a) (caddr b)))))
X
X; the equivalence tests are set up to consider the contents of
X; node memories, so they are ready for the build action
X
X;;; Network interpreter
X
X(defun match (flag wme)
X (sendto flag (list wme) 'left (list *first-node*)))
X
X; note that eval-nodelist is not set up to handle building
X; productions. would have to add something like ops4's build-flag
X
X(defun eval-nodelist (nl)
X (prog nil
X top (and (not nl) (return nil))
X (setq *sendtocall* nil)
X (setq *last-node* (car nl))
X (apply (caar nl) (cdar nl))
X (setq nl (cdr nl))
X (go top)))
X
X(defun sendto (flag data side nl)
X (prog nil
X top (and (not nl) (return nil))
X (setq *side* side)
X (setq *flag-part* flag)
X (setq *data-part* data)
X (setq *sendtocall* t)
X (setq *last-node* (car nl))
X (apply (caar nl) (cdar nl))
X (setq nl (cdr nl))
X (go top)))
X
X; &bus sets up the registers for the one-input nodes. note that this
X(defun &bus (outs)
X (prog (dp)
X (setq *alpha-flag-part* *flag-part*)
X (setq *alpha-data-part* *data-part*)
X (setq dp (car *data-part*))
X (setq *c1* (car dp))
X (setq dp (cdr dp))
X (setq *c2* (car dp))
X (setq dp (cdr dp))
X (setq *c3* (car dp))
X (setq dp (cdr dp))
X (setq *c4* (car dp))
X (setq dp (cdr dp))
X (setq *c5* (car dp))
X (setq dp (cdr dp))
X (setq *c6* (car dp))
X (setq dp (cdr dp))
X (setq *c7* (car dp))
X (setq dp (cdr dp))
X (setq *c8* (car dp))
X (setq dp (cdr dp))
X (setq *c9* (car dp))
X (setq dp (cdr dp))
X (setq *c10* (car dp))
X (setq dp (cdr dp))
X (setq *c11* (car dp))
X (setq dp (cdr dp))
X (setq *c12* (car dp))
X (setq dp (cdr dp))
X (setq *c13* (car dp))
X (setq dp (cdr dp))
X (setq *c14* (car dp))
X (setq dp (cdr dp))
X (setq *c15* (car dp))
X (setq dp (cdr dp))
X (setq *c16* (car dp))
X (setq dp (cdr dp))
X (setq *c17* (car dp))
X (setq dp (cdr dp))
X (setq *c18* (car dp))
X (setq dp (cdr dp))
X (setq *c19* (car dp))
X (setq dp (cdr dp))
X (setq *c20* (car dp))
X (setq dp (cdr dp))
X (setq *c21* (car dp))
X (setq dp (cdr dp))
X (setq *c22* (car dp))
X (setq dp (cdr dp))
X (setq *c23* (car dp))
X (setq dp (cdr dp))
X (setq *c24* (car dp))
X (setq dp (cdr dp))
X (setq *c25* (car dp))
X (setq dp (cdr dp))
X (setq *c26* (car dp))
X (setq dp (cdr dp))
X (setq *c27* (car dp))
X (setq dp (cdr dp))
X (setq *c28* (car dp))
X (setq dp (cdr dp))
X (setq *c29* (car dp))
X (setq dp (cdr dp))
X (setq *c30* (car dp))
X (setq dp (cdr dp))
X (setq *c31* (car dp))
X (setq dp (cdr dp))
X (setq *c32* (car dp))
X (setq dp (cdr dp))
X (setq *c33* (car dp))
X (setq dp (cdr dp))
X (setq *c34* (car dp))
X (setq dp (cdr dp))
X (setq *c35* (car dp))
X (setq dp (cdr dp))
X (setq *c36* (car dp))
X (setq dp (cdr dp))
X (setq *c37* (car dp))
X (setq dp (cdr dp))
X (setq *c38* (car dp))
X (setq dp (cdr dp))
X (setq *c39* (car dp))
X (setq dp (cdr dp))
X (setq *c40* (car dp))
X (setq dp (cdr dp))
X (setq *c41* (car dp))
X (setq dp (cdr dp))
X (setq *c42* (car dp))
X (setq dp (cdr dp))
X (setq *c43* (car dp))
X (setq dp (cdr dp))
X (setq *c44* (car dp))
X (setq dp (cdr dp))
X (setq *c45* (car dp))
X (setq dp (cdr dp))
X (setq *c46* (car dp))
X (setq dp (cdr dp))
X (setq *c47* (car dp))
X (setq dp (cdr dp))
X (setq *c48* (car dp))
X (setq dp (cdr dp))
X (setq *c49* (car dp))
X (setq dp (cdr dp))
X (setq *c50* (car dp))
X (setq dp (cdr dp))
X (setq *c51* (car dp))
X (setq dp (cdr dp))
X (setq *c52* (car dp))
X (setq dp (cdr dp))
X (setq *c53* (car dp))
X (setq dp (cdr dp))
X (setq *c54* (car dp))
X (setq dp (cdr dp))
X (setq *c55* (car dp))
X (setq dp (cdr dp))
X (setq *c56* (car dp))
X (setq dp (cdr dp))
X (setq *c57* (car dp))
X (setq dp (cdr dp))
X (setq *c58* (car dp))
X (setq dp (cdr dp))
X (setq *c59* (car dp))
X (setq dp (cdr dp))
X (setq *c60* (car dp))
X (setq dp (cdr dp))
X (setq *c61* (car dp))
X (setq dp (cdr dp))
X (setq *c62* (car dp))
X (setq dp (cdr dp))
X (setq *c63* (car dp))
X (setq dp (cdr dp))
X (setq *c64* (car dp))
X (eval-nodelist outs)))
X
X(defun &any (outs register const-list)
X (prog (z c)
X (setq z (fast-symeval register))
X (cond ((numberp z) (go number)))
X symbol (cond ((null const-list) (return nil))
X ((eq (car const-list) z) (go ok))
X (t (setq const-list (cdr const-list)) (go symbol)))
X number (cond ((null const-list) (return nil))
X ((and (numberp (setq c (car const-list)))
X (=alg c z))
X (go ok))
X (t (setq const-list (cdr const-list)) (go number)))
X ok (eval-nodelist outs)))
X
X(defun teqa (outs register constant)
X (and (eq (fast-symeval register) constant) (eval-nodelist outs)))
X
X(defun tnea (outs register constant)
X (and (not (eq (fast-symeval register) constant)) (eval-nodelist outs)))
X
X(defun txxa (outs register constant)
X (and (symbolp (fast-symeval register)) (eval-nodelist outs)))
X
X(defun teqn (outs register constant)
X (prog (z)
X (setq z (fast-symeval register))
X (and (numberp z)
X (=alg z constant)
X (eval-nodelist outs))))
X
X(defun tnen (outs register constant)
X (prog (z)
X (setq z (fast-symeval register))
X (and (or (not (numberp z))
X (not (=alg z constant)))
X (eval-nodelist outs))))
X
X(defun txxn (outs register constant)
X (prog (z)
X (setq z (fast-symeval register))
X (and (numberp z) (eval-nodelist outs))))
X
X(defun tltn (outs register constant)
X (prog (z)
X (setq z (fast-symeval register))
X (and (numberp z)
X (greaterp constant z)
X (eval-nodelist outs))))
X
X(defun tgtn (outs register constant)
X (prog (z)
X (setq z (fast-symeval register))
X (and (numberp z)
X (greaterp z constant)
X (eval-nodelist outs))))
X
X(defun tgen (outs register constant)
X (prog (z)
X (setq z (fast-symeval register))
X (and (numberp z)
X (not (greaterp constant z))
X (eval-nodelist outs))))
X
X(defun tlen (outs register constant)
X (prog (z)
X (setq z (fast-symeval register))
X (and (numberp z)
X (not (greaterp z constant))
X (eval-nodelist outs))))
X
X(defun teqs (outs vara varb)
X (prog (a b)
X (setq a (fast-symeval vara))
X (setq b (fast-symeval varb))
X (cond ((eq a b) (eval-nodelist outs))
X ((and (numberp a)
X (numberp b)
X (=alg a b))
X (eval-nodelist outs)))))
X
X(defun tnes (outs vara varb)
X (prog (a b)
X (setq a (fast-symeval vara))
X (setq b (fast-symeval varb))
X (cond ((eq a b) (return nil))
X ((and (numberp a)
X (numberp b)
X (=alg a b))
X (return nil))
X (t (eval-nodelist outs)))))
X
X(defun txxs (outs vara varb)
X (prog (a b)
X (setq a (fast-symeval vara))
X (setq b (fast-symeval varb))
X (cond ((and (numberp a) (numberp b)) (eval-nodelist outs))
X ((and (not (numberp a)) (not (numberp b)))
X (eval-nodelist outs)))))
X
X(defun tlts (outs vara varb)
X (prog (a b)
X (setq a (fast-symeval vara))
X (setq b (fast-symeval varb))
X (and (numberp a)
X (numberp b)
X (greaterp b a)
X (eval-nodelist outs))))
X
X(defun tgts (outs vara varb)
X (prog (a b)
X (setq a (fast-symeval vara))
X (setq b (fast-symeval varb))
X (and (numberp a)
X (numberp b)
X (greaterp a b)
X (eval-nodelist outs))))
X
X(defun tges (outs vara varb)
X (prog (a b)
X (setq a (fast-symeval vara))
X (setq b (fast-symeval varb))
X (and (numberp a)
X (numberp b)
X (not (greaterp b a))
X (eval-nodelist outs))))
X
X(defun tles (outs vara varb)
X (prog (a b)
X (setq a (fast-symeval vara))
X (setq b (fast-symeval varb))
X (and (numberp a)
X (numberp b)
X (not (greaterp a b))
X (eval-nodelist outs))))
X
X(defun &two (left-outs right-outs)
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 (sendto fp dp 'left left-outs)
X (sendto fp dp 'right right-outs)))
X
X(defun &mem (left-outs right-outs memory-list)
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 (sendto fp dp 'left left-outs)
X (add-token memory-list fp dp nil)
X (sendto fp dp 'right right-outs)))
X
X(defun &and (outs lpred rpred tests)
X (prog (mem)
X (cond ((eq *side* 'right) (setq mem (memory-part lpred)))
X (t (setq mem (memory-part rpred))))
X (cond ((not mem) (return nil))
X ((eq *side* 'right) (and-right outs mem tests))
X (t (and-left outs mem tests)))))
------------------------------
End of AIList Digest
********************
