Relay-Version: version B 2.10 5/3/83; site utzoo.UUCP
Path: utzoo!mnetor!seismo!rutgers!sri-unix!hplabs!decwrl!sun!imagen!turner
From: turner@imagen.UUCP (D'arc Angel)
Newsgroups: comp.ai
Subject: AI expert sources
Message-ID: <800@imagen.UUCP>
Date: Sun, 18-Jan-87 22:49:01 EST
Article-I.D.: imagen.800
Posted: Sun Jan 18 22:49:01 1987
Date-Received: Mon, 19-Jan-87 21:38:35 EST
Organization: The Houses of the Holy
Lines: 1506
Keywords: ai,sources


	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
	X;;; Utility functions
	X
	X
	X
	X(defun printline (x) (mapc (function printline*) x)) 
	X
	X(defun printline* (y) (princ '| |) (print y)) 
	X
	X(defun printlinec (x) (mapc (function printlinec*) x)) 
	X
	X(defun printlinec* (y) (princ '| |) (princ y)) 
	X
	X; intersect two lists using eq for the equality test
	X
	X(defun interq (x y)
	X  (intersection x y :test #'eq))
	X
	X(defun enter (x ll)
	X   (and (not (member x ll :test #'equal))
	X       (push x ll)))
	X
	X; later versions of Franz have this standard
	X;(defun neq (x y)
	X;   (not (eq x y)))
	X
	X;Hack read-macro tables to accept single characters -- right out of CL book.
	X(defun single-macro-character (stream char)
	X   (declare (ignore stream))
	X   (character char))
	X
	X(defun i-g-v nil
	X (prog (x)
	X        (set-macro-character #\{ #'single-macro-character )
	X        (set-macro-character #\} #'single-macro-character )
	X        (set-macro-character #\^ #'single-macro-character )
	X;	(setsyntax '\{ 66.) ;These are already normal characters in CL
	X;	(setsyntax '\} 66.)
	X;	(setsyntax '^ 66.)
	X	(setq *buckets* 64.)		; OPS5 allows 64 named slots
	X	(setq *accept-file* nil)
	X	(setq *write-file* nil)
	X	(setq *trace-file* nil)
	X        (and (boundp '*class-list*)
	X          (mapc #'(lambda(class) (putprop class nil 'att-list)) *class-list*))
	X	(setq *class-list* nil)
	X	(setq *brkpts* nil)
	X	(setq *strategy* 'lex)
	X  	(setq *in-rhs* nil)
	X  	(setq *ptrace* t)
	X  	(setq *wtrace* nil)
	X	(setq *mtrace* t)            ; turn on made-by tracing
	X	(setq *madeby* nil)          ; record makers of wm elements
	X  	(setq *recording* nil)
	X        (setq *refracts* nil)
	X	(setq *real-cnt* (setq *virtual-cnt* 0.))
	X	(setq *max-cs* (setq *total-cs* 0.))
	X  	(setq *limit-token* 1000000.)
	X	(setq *limit-cs* 1000000.)
	X	(setq *critical* nil)
	X	(setq *build-trace* nil)
	X	(setq *wmpart-list* nil)
	X        (setq *pnames* nil)
	X        (setq *literals* nil) ; records literal definitions
	X	(setq *externals* nil) ; records external definitions
	X	(setq *vector-attributes* nil) ;records vector attributes
	X	(setq *size-result-array* 127.)
	X	(setq *result-array* (make-array 128))
	X	(setq *record-array* (make-array 128))
	X	(setq x 0)
	X        (setq *pnames* nil)     ; list of production names
	X  loop	(putvector *result-array* x nil)
	X	(setq x (1+ x))
	X	(and (not (> x *size-result-array*)) (go loop))
	X	(make-bottom-node)
	X	(setq *pcount* 0.)
	X	(initialize-record)
	X	(setq *cycle-count* (setq *action-count* 0.))
	X	(setq *total-token*
	X	       (setq *max-token* (setq *current-token* 0.)))
	X	(setq *total-cs* (setq *max-cs* 0.))
	X	(setq *total-wm* (setq *max-wm* (setq *current-wm* 0.)))
	X	(setq *conflict-set* nil)
	X	(setq *wmpart-list* nil)
	X	(setq *p-name* nil)
	X	(setq *remaining-cycles* 1000000)
	X))
	X
	X; if the size of result-array changes, change the line in i-g-v which
	X; sets the value of *size-result-array*
	X
	X(defun %warn (what where)
	X  (prog nil
	X    (terpri)
	X    (princ '?)
	X    (and *p-name* (princ *p-name*))
	X    (princ '|..|)
	X    (princ where)
	X    (princ '|..|)
	X    (princ what)
	X    (return where))) 
	X
	X(defun %error (what where)
	X    (%warn what where)
	X    (throw '!error! nil)) 
	X
	X;(defun round (x) (fix (plus 0.5 x))) 
	X
	X(defun top-levels-eq (la lb)
	X  (prog nil
	X   lx   (cond ((eq la lb) (return t))
	X              ((null la) (return nil))
	X              ((null lb) (return nil))
	X              ((not (eq (car la) (car lb))) (return nil)))
	X        (setq la (cdr la))
	X        (setq lb (cdr lb))
	X        (go lx))) 
	X
	X
	X;;; LITERAL and LITERALIZE
	X
	X(defmacro literal (&rest z)
	X  `(prog (atm val old args)
	X        (setq args ',z)
	X   top  (and (atom args) (return 'bound))
	X        (or (eq (cadr args) '=) (return (%warn '|wrong format| args)))
	X        (setq atm (car args))
	X        (setq val (caddr args))
	X        (setq args (cdddr args))
	X        (cond ((not (numberp val))
	X               (%warn '|can bind only to numbers| val))
	X              ((or (not (symbolp atm)) (variablep atm))
	X                (%warn '|can bind only constant atoms| atm))
	X              ((and (setq old (literal-binding-of atm)) (not (equal old val)))
	X               (%warn '|attempt to rebind attribute| atm))
	X              (t (putprop atm val 'ops-bind )))
	X        (go top))) 
	X
	X(defmacro literalize (&rest l)
	X  `(prog (class-name atts)
	X    (setq class-name (car ',l))
	X    (cond ((have-compiled-production)
	X           (%warn '|literalize called after p| class-name)
	X           (return nil))
	X          ((get class-name 'att-list)
	X           (%warn '|attempt to redefine class| class-name)
	X	   (return nil)))
	X    (setq *class-list* (cons class-name *class-list*))
	X    (setq atts (remove-duplicates (cdr ',l)))
	X    (test-attribute-names atts)
	X    (mark-conflicts atts atts)
	X    (putprop class-name  atts 'att-list))) 
	X
	X(defun vector-attribute  (&quote &rest l)
	X  (cond ((have-compiled-production)
	X         (%warn '|vector-attribute called after p| l))
	X        (t 
	X         (test-attribute-names l)
	X	 (mapc (function vector-attribute2) l)))) 
	X
	X(defun vector-attribute2 (att) (putprop att t 'vector-attribute)
	X			       (setq  *vector-attributes* 
	X				   (enter att *vector-attributes*)))
	X
	X(defun is-vector-attribute (att) (get att 'vector-attribute))
	X
	X(defun test-attribute-names (l)
	X  (mapc (function test-attribute-names2) l)) 
	X
	X(defun test-attribute-names2 (atm)
	X  (cond ((or (not (symbolp atm)) (variablep atm))
	X         (%warn '|can bind only constant atoms| atm)))) 
	X
	X(defun finish-literalize nil
	X  (cond ((not (null *class-list*))
	X         (mapc (function note-user-assigns) *class-list*)
	X         (mapc (function assign-scalars) *class-list*)
	X         (mapc (function assign-vectors) *class-list*)
	X         (mapc (function put-ppdat) *class-list*)
	X         (mapc (function erase-literal-info) *class-list*)
	X         (setq *class-list* nil)
	X         (setq *buckets* nil)))) 
	X
	X(defun have-compiled-production nil (not (zerop *pcount*))) 
	X
	X(defun put-ppdat (class)
	X  (prog (al att ppdat)
	X        (setq ppdat nil)
	X        (setq al (get class 'att-list))
	X   top  (cond ((not (atom al))
	X               (setq att (car al))
	X               (setq al (cdr al))
	X               (setq ppdat
	X                     (cons (cons (literal-binding-of att) att)
	X                           ppdat))
	X               (go top)))
	X        (putprop class ppdat 'ppdat))) 
	X
	X; note-user-assigns and note-user-vector-assigns are needed only when
	X; literal and literalize are both used in a program.  They make sure that
	X; the assignments that are made explicitly with literal do not cause problems
	X; for the literalized classes.
	X
	X(defun note-user-assigns (class)
	X  (mapc (function note-user-assigns2) (get class 'att-list)))
	X
	X(defun note-user-assigns2 (att)
	X  (prog (num conf buck clash)
	X        (setq num (literal-binding-of att))
	X	(and (null num) (return nil))
	X	(setq conf (get att 'conflicts))
	X	(setq buck (store-binding att num))
	X	(setq clash (find-common-atom buck conf))
	X	(and clash
	X	     (%warn '|attributes in a class assigned the same number|
	X	            (cons att clash)))
	X        (return nil)))
	X
	X(defun note-user-vector-assigns (att given needed)
	X  (and (> needed given)
	X       (%warn '|vector attribute assigned too small a value in literal| att)))
	X
	X(defun assign-scalars (class)
	X  (mapc (function assign-scalars2) (get class 'att-list))) 
	X
	X(defun assign-scalars2 (att)
	X  (prog (tlist num bucket conf)
	X        (and (literal-binding-of att) (return nil))
	X        (and (is-vector-attribute att) (return nil))
	X        (setq tlist (buckets))
	X        (setq conf (get att 'conflicts))
	X   top  (cond ((atom tlist)
	X               (%warn '|could not generate a binding| att)
	X               (store-binding att -1.)
	X               (return nil)))
	X        (setq num (caar tlist))
	X        (setq bucket (cdar tlist))
	X        (setq tlist (cdr tlist))
	X        (cond ((disjoint bucket conf) (store-binding att num))
	X        (t (go top))))) 
	X
	X(defun assign-vectors (class)
	X  (mapc (function assign-vectors2) (get class 'att-list))) 
	X
	X(defun assign-vectors2 (att)
	X  (prog (big conf new old need)
	X        (and (not (is-vector-attribute att)) (return nil))
	X        (setq big 1.)
	X        (setq conf (get att 'conflicts))
	X   top  (cond ((not (atom conf))
	X               (setq new (car conf))
	X               (setq conf (cdr conf))
	X               (cond ((is-vector-attribute new)
	X                      (%warn '|class has two vector attributes|
	X		              (list att new)))
	X                     (t (setq big (max (literal-binding-of new) big))))
	X               (go top)))
	X        (setq need (1+ big))
	X	(setq old (literal-binding-of att))
	X	(cond (old (note-user-vector-assigns att old need))
	X	      (t (store-binding att need)))
	X        (return nil)))
	X
	X(defun disjoint (la lb) (not (find-common-atom la lb))) 
	X
	X(defun find-common-atom (la lb)
	X  (prog nil
	X   top  (cond ((null la) (return nil))
	X              ((memq (car la) lb) (return (car la)))
	X              (t (setq la (cdr la)) (go top))))) 
	X
	X(defun mark-conflicts (rem all)
	X  (cond ((not (null rem))
	X         (mark-conflicts2 (car rem) all)
	X         (mark-conflicts (cdr rem) all)))) 
	X
	X(defun mark-conflicts2 (atm lst)
	X  (prog (l)
	X        (setq l lst)
	X   top  (and (atom l) (return nil))
	X        (conflict atm (car l))
	X        (setq l (cdr l))
	X        (go top))) 
	X
	X(defun conflict (a b)
	X  (prog (old)
	X    (setq old (get a 'conflicts))
	X    (and (not (eq a b))
	X         (not (memq b old))
	X         (putprop a (cons b old) 'conflicts )))) 
	X
	X;(defun remove-duplicates (lst)
	X;  (cond ((atom lst) nil)
	X;        ((memq (car lst) (cdr lst)) (remove-duplicates (cdr lst)))
	X;        (t (cons (car lst) (remove-duplicates (cdr lst)))))) 
	X
	X(defun literal-binding-of (name) (get name 'ops-bind)) 
	X
	X(defun store-binding (name lit)
	X  (putprop name lit 'ops-bind)
	X  (add-bucket name lit)) 
	X
	X(defun add-bucket (name num)
	X  (prog (buc)
	X    (setq buc (assoc num (buckets)))
	X    (and (not (memq name buc))
	X         (rplacd buc (cons name (cdr buc))))
	X    (return buc))) 
	X
	X(defun buckets nil
	X  (and (atom *buckets*) (setq *buckets* (make-nums *buckets*)))
	X  *buckets*) 
	X
	X(defun make-nums (k)
	X  (prog (nums)
	X        (setq nums nil)
	X   l    (and (< k 2.) (return nums))
	X        (setq nums (cons (ncons k) nums))
	X        (setq k (1- k))
	X        (go l))) 
	X
	X;(defun erase-literal-info (class)
	X;  (mapc (function erase-literal-info2) (get class 'att-list))
	X;  (remprop class 'att-list)) 
	X
	X; modified to record literal info in the variable *literals*
	X(defun erase-literal-info (class)
	X      (setq *literals*
	X            (cons (cons class (get class 'att-list)) *literals*))
	X      (mapc (function erase-literal-info2) (get class 'att-list))
	X      (remprop class 'att-list))
	X
	X
	X(defun erase-literal-info2 (att) (remprop att 'conflicts)) 
	X
	X
	X;;; LHS Compiler
	X
	X(defun p (&quote &rest z) 
	X  (finish-literalize)
	X  (princ '*) 
	X  ;(drain);drain probably drains a line feed
	X  (compile-production (car z) (cdr z))) 
	X
	X(defun compile-production (name matrix)
	X  (prog (erm)
	X        (setq *p-name* name)
	X        (setq erm (catch '!error! (cmp-p name matrix) ))
	X	; following line is modified to save production name on *pnames*
	X        (and (null erm) (setq *pnames* (enter name *pnames*)))
	X	(setq *p-name* nil)
	X	(return erm)))
	X
	X(defun peek-lex nil (car *matrix*)) 
	X
	X(defun lex nil
	X  (prog2 nil (car *matrix*) (setq *matrix* (cdr *matrix*)))) 
	X
	X(defun end-of-p nil (atom *matrix*)) 
	X
	X(defun rest-of-p nil *matrix*) 
	X
	X(defun prepare-lex (prod) (setq *matrix* prod)) 
	X
	X
	X(defun peek-sublex nil (car *curcond*)) 
	X
	X(defun sublex nil
	X  (prog2 nil (car *curcond*) (setq *curcond* (cdr *curcond*)))) 
	X
	X(defun end-of-ce nil (atom *curcond*)) 
	X
	X(defun rest-of-ce nil *curcond*) 
	X
	X(defun prepare-sublex (ce) (setq *curcond* ce)) 
	X
	X(defun make-bottom-node nil (setq *first-node* (list '&bus nil))) 
	X
	X(defun cmp-p (name matrix)
	X  (prog (m bakptrs)
	X        (cond ((or (null name) (listp name))
	X               (%error '|illegal production name| name))
	X              ((equal (get name 'production) matrix)
	X	       (return nil)))
	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	(check-rhs (rest-of-p))
	X        (link-new-node (list '&p
	X                             *feature-count*
	X                             name
	X                             (encode-dope)
	X                             (encode-ce-dope)
	X                             (cons 'progn (rest-of-p))))
	X        (putprop name (cdr (nreverse bakptrs)) 'backpointers )
	X	(putprop name matrix 'production)
	X        (putprop name *last-node* 'topnode))) 
	X
	X(defun rating-part (pnode) (cadr pnode)) 
	X
	X(defun var-part (pnode) (car (cdddr pnode))) 
	X
	X(defun ce-var-part (pnode) (cadr (cdddr pnode))) 
	X
	X(defun rhs-part (pnode) (caddr (cdddr pnode))) 
	X
	X(defun excise-p (name)
	X  (cond ((and (symbolp name) (get name 'topnode))
	X	 (printline (list name 'is 'excised))
	X         (setq *pcount* (1- *pcount*))
	X         (remove-from-conflict-set name)
	X         (kill-node (get name 'topnode))
	X         (setq *pnames* (delq name *pnames*))
	X	 (remprop name 'production)
	X	 (remprop name 'backpointers)
	X         (remprop name 'topnode)))) 
	X
	X(defun kill-node (node)
	X  (prog nil
	X   top  (and (atom node) (return nil))
	X        (rplaca node '&old)
	X        (setq node (cdr node))
	X        (go top))) 
	X
	X(defun cmp-prin nil
	X  (prog nil
	X        (setq *last-node* *first-node*)
	X        (cond ((null *last-branch*) (cmp-posce) (cmp-nobeta))
	X              ((eq (peek-lex) '-) (cmp-negce) (cmp-not))
	X              (t (cmp-posce) (cmp-and))))) 
	X
	X(defun cmp-negce nil (lex) (cmp-ce)) 
	X
	X(defun cmp-posce nil
	X  (setq *ce-count* (1+ *ce-count*))
	X  (cond ((eq (peek-lex) #\{) (cmp-ce+cevar))
	X        (t (cmp-ce)))) 
	X
	X(defun cmp-ce+cevar nil
	X  (prog (z)
	X        (lex)
	X        (cond ((atom (peek-lex)) (cmp-cevar) (cmp-ce))
	X              (t (cmp-ce) (cmp-cevar)))
	X        (setq z (lex))
	X        (or (eq z #\}) (%error '|missing '}'| z)))) 
	X
	X(defun new-subnum (k)
	X  (or (numberp k) (%error '|tab must be a number| k))
	X  (setq *subnum* (fix k))) 
	X
	X(defun incr-subnum nil (setq *subnum* (1+ *subnum*))) 
	X
	X(defun cmp-ce nil
	X  (prog (z)
	X        (new-subnum 0.)
	X        (setq *cur-vars* nil)
	X        (setq z (lex))
	X        (and (atom z)
	X             (%error '|atomic conditions are not allowed| z))
	X        (prepare-sublex z)
	X   la   (and (end-of-ce) (return nil))
	X        (incr-subnum)
	X        (cmp-element)
	X        (go la))) 
	X
	X(defun cmp-element nil
	X        (and (eq (peek-sublex) #\^) (cmp-tab))
	X        (cond ((eq (peek-sublex) '#\{) (cmp-product))
	X              (t (cmp-atomic-or-any))))
	X
	X(defun cmp-atomic-or-any nil
	X        (cond ((eq (peek-sublex) '<<) (cmp-any))
	X              (t (cmp-atomic))))
	X
	X(defun cmp-any nil
	X  (prog (a z)
	X        (sublex)
	X        (setq z nil)
	X   la   (cond ((end-of-ce) (%error '|missing '>>'| a)))
	X        (setq a (sublex))
	X        (cond ((not (eq '>> a)) (setq z (cons a z)) (go la)))
	X        (link-new-node (list '&any nil (current-field) z)))) 
	X
	X
	X(defun cmp-tab nil
	X  (prog (r)
	X        (sublex)
	X        (setq r (sublex))
	X        (setq r ($litbind r))
	X        (new-subnum r))) 
	X
	X(defun $litbind (x)
	X  (prog (r)
	X        (cond ((and (symbolp x) (setq r (literal-binding-of x)))
	X               (return r))
	X              (t (return x))))) 
	X
	X(defun get-bind (x)
	X  (prog (r)
	X        (cond ((and (symbolp x) (setq r (literal-binding-of x)))
	X               (return r))
	X              (t (return nil))))) 
	X
	X(defun cmp-atomic nil
	X  (prog (test x)
	X        (setq x (peek-sublex))
	X        (cond ((eq x '=) (setq test 'eq) (sublex))
	X              ((eq x '<>) (setq test 'ne) (sublex))
	X              ((eq x '<) (setq test 'lt) (sublex))
	X              ((eq x '<=) (setq test 'le) (sublex))
	X              ((eq x '>) (setq test 'gt) (sublex))
	X              ((eq x '>=) (setq test 'ge) (sublex))
	X              ((eq x '<=>) (setq test 'xx) (sublex))
	X              (t (setq test 'eq)))
	X        (cmp-symbol test))) 
	X
	X(defun cmp-product nil
	X  (prog (save)
	X        (setq save (rest-of-ce))
	X        (sublex)
	X   la   (cond ((end-of-ce)
	X               (cond ((member #\} save) 
	X		      (%error '|wrong contex for '}'| save))
	X		     (t (%error '|missing '}'| save))))
	X              ((eq (peek-sublex) #\}) (sublex) (return nil)))
	X        (cmp-atomic-or-any)
	X        (go la))) 
	X
	X(defun variablep (x) (and (symbolp x) (char-equal (char (symbol-name x) 0) #\<))) 
	X
	X(defun cmp-symbol (test)
	X  (prog (flag)
	X        (setq flag t)
	X        (cond ((eq (peek-sublex) '//) (sublex) (setq flag nil)))
	X        (cond ((and flag (variablep (peek-sublex)))
	X               (cmp-var test))
	X              ((numberp (peek-sublex)) (cmp-number test))
	X              ((symbolp (peek-sublex)) (cmp-constant test))
	X              (t (%error '|unrecognized symbol| (sublex)))))) 
	X
	X(defun concat3(x y z)
	X   (intern (format nil "~s~s~s" x y z)))
	X
	X(defun cmp-constant (test)
	X  (or (memq test '(eq ne xx))
	X      (%error '|non-numeric constant after numeric predicate| (sublex)))
	X  (link-new-node (list (concat3 't test 'a)
	X                       nil
	X                       (current-field)
	X                       (sublex)))) 
	X
	X
	X(defun cmp-number (test)
	X  (link-new-node (list (concat3 't test 'n)
	X                       nil
	X                       (current-field)
	X                       (sublex)))) 
	X
	X(defun current-field nil (field-name *subnum*)) 
	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) (assq var *vars*))
	X
	X(defun ce-var-dope (var) (assq var *ce-vars*))
	X
	X(defun cmp-var (test)
	X  (prog (old name)
	X        (setq name (sublex))
	X        (setq old (assq name *cur-vars*))
	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* (delq old *cur-vars*))
	X        (setq next (assq name *cur-vars*))
	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 (assq name *ce-vars*))
	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 '&not)) 
	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 (assq vname *vars*))
	X        (cond (old (setq tlist (add-test tlist vdope old)))
	X              ((neq kind '&not) (promote-var vdope)))
	X        (go la)
	X   lb   (and kind (build-beta kind tlist))
	X        (or (eq kind '&not) (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 &not)))
	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-cn (sublex))
	X              ((eq x '<=) (setq test 'le) (sublex))
	X              ((eq x '>) (setq test 'gt) (sublex))
	X              ((eq x '>=) (setq test 'ge) (sublex))
	X              ((eq x '<=>) (setq test 'xx) (sublex))
	X              (t (setq test 'eq)))
	X        (cmp-symbol test))) 
	X
	X(defun cmp-product nil
	X  (prog (save)
	X        (setq save (rest-of-ce))
	X        (sublex)
	X   la   (cond ((end-of-ce)
	X               (cond ((member #\} save) 
	X		      (%error '|wrong contex for '}'| save))
	X		     (t (%error '|missing '}'| save))))
	X              ((eq (peek-sublex) #\}) (sublex) (return nil)))
	X        (cmp-atomic-or-any)
	X        (go la))) 
	X
	X(defun variablep (x) (and (symbolp x) (char-equal (char (symbol-name x) 0) #\<))) 
	X
	X(defun cmp-symbol (test)
	X  (prog (flag)
	X        (setq flag t)
	X        (cond ((eq (peek-sublex) '//) (sublex) (setq flag nil)))
	X        (cond ((and flag (variablep (peek-sublex)))
	X               (cmp-var test))
	X              ((numberp (peek-sublex)) (cmp-number test))
	X              ((symbolp (peek-sublex)) (cmp-constant test))
	X              (t (%error '|unrecognized symbol| (sublex)))))) 
	X
	X(defun concat3(x y z)
	X   (intern (format nil "~s~s~s" x y z)))
	X
	X(defun cmp-constant (test)
	X  (or (memq test '(eq ne xx))
	X      (%error '|non-numeric constant after numeric predicate| (sublex)))
	X  (link-new-node (list (concat3 't test 'a)
	X                       nil
	X                       (current-field)
	X                       (sublex)))) 
	X
	X
	X(defun cmp-number (test)
	X  (link-new-node (list (concat3 't test 'n)
	X                       nil
	X                       (current-field)
	X                       (sublex)))) 
	X
	X(defun current-field nil (field-name *subnum*)) 
	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) (assq var *vars*))
	X
	X(defun ce-var-dope (var) (assq var *ce-vars*))
	X
	X(defun cmp-var (test)
	X  (prog (old name)
	X        (setq name (sublex))
	X        (setq old (assq name *cur-vars*))
	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* (delq old *cur-vars*))
	X        (setq next (assq name *cur-vars*))
	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 (assq name *ce-vars*))
	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 '&not)) 
	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 (assq vname *vars*))
	X        (cond (old (setq tlist (add-test tlist vdope old)))
	X              ((neq kind '&not) (promote-var vdope)))
	X        (go la)
	X   lb   (and kind (build-beta kind tlist))
	X        (or (eq kind '&not) (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 &not)))
	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