home *** CD-ROM | disk | FTP | other *** search
/ Usenet 1994 January / usenetsourcesnewsgroupsinfomagicjanuary1994.iso / sources / unix / volume12 / ops5 / part03 < prev    next >
Encoding:
Internet Message Format  |  1987-10-12  |  25.6 KB
  1. Subject:  v12i018:  OPS5 in Common Lisp, Part03/05
  2. Newsgroups: comp.sources.unix
  3. Sender: sources
  4. Approved: rs@uunet.UU.NET
  5.  
  6. Submitted-by: eric@dlcdev.UUCP (eric van tassell)
  7. Posting-number: Volume 12, Issue 18
  8. Archive-name: ops5/part03
  9.  
  10. [  Note that this package is not a shar file.  Consider this an experiment,
  11.    similar to the patch file I recently published.  Comments?  -r$  ]
  12.  
  13. ; the following two functions encode indices so that gelm can
  14. ; decode them as fast as possible
  15.  
  16. (defun encode-pair (a b) (+ (* 10000. (1- a)) (1- b))) 
  17.  
  18. (defun encode-singleton (a) (1- a)) 
  19.  
  20. (defun promote-var (dope)
  21.   (prog (vname vpred vpos new)
  22.         (setq vname (car dope))
  23.         (setq vpred (cadr dope))
  24.         (setq vpos (caddr dope))
  25.         (or (eq 'eq vpred)
  26.             (%error '|illegal predicate for first occurrence|
  27.                    (list vname vpred)))
  28.         (setq new (list vname 0. vpos))
  29.         (setq *vars* (cons new *vars*)))) 
  30.  
  31. (defun fudge nil
  32.   (mapc (function fudge*) *vars*)
  33.   (mapc (function fudge*) *ce-vars*)) 
  34.  
  35. (defun fudge* (z)
  36.   (prog (a) (setq a (cdr z)) (rplaca a (1+ (car a))))) 
  37.  
  38. (defun build-beta (type tests)
  39.   (prog (rpred lpred lnode lef)
  40.         (link-new-node (list '&mem nil nil (protomem)))
  41.         (setq rpred *last-node*)
  42.         (cond ((eq type '&and)
  43.                (setq lnode (list '&mem nil nil (protomem))))
  44.               (t (setq lnode (list '&two nil nil))))
  45.         (setq lpred (link-to-branch lnode))
  46.         (cond ((eq type '&and) (setq lef lpred))
  47.               (t (setq lef (protomem))))
  48.         (link-new-beta-node (list type nil lef rpred tests)))) 
  49.  
  50. (defun protomem nil (list nil)) 
  51.  
  52. (defun memory-part (mem-node) (car (cadddr mem-node))) 
  53.  
  54. (defun encode-dope nil
  55.   (prog (r all z k)
  56.         (setq r nil)
  57.         (setq all *vars*)
  58.    la   (and (atom all) (return r))
  59.         (setq z (car all))
  60.         (setq all (cdr all))
  61.         (setq k (encode-pair (cadr z) (caddr z)))
  62.         (setq r (cons (car z) (cons k r)))
  63.         (go la))) 
  64.  
  65. (defun encode-ce-dope nil
  66.   (prog (r all z k)
  67.         (setq r nil)
  68.         (setq all *ce-vars*)
  69.    la   (and (atom all) (return r))
  70.         (setq z (car all))
  71.         (setq all (cdr all))
  72.         (setq k (cadr z))
  73.         (setq r (cons (car z) (cons k r)))
  74.         (go la))) 
  75.  
  76.  
  77.  
  78. ;;; Linking the nodes
  79.  
  80. (defun link-new-node (r)
  81.   (cond ((not (member (car r) '(&p &mem &two &and ¬)))
  82.      (setq *feature-count* (1+ *feature-count*))))
  83.   (setq *virtual-cnt* (1+ *virtual-cnt*))
  84.   (setq *last-node* (link-left *last-node* r))) 
  85.  
  86. (defun link-to-branch (r)
  87.   (setq *virtual-cnt* (1+ *virtual-cnt*))
  88.   (setq *last-branch* (link-left *last-branch* r))) 
  89.  
  90. (defun link-new-beta-node (r)
  91.   (setq *virtual-cnt* (1+ *virtual-cnt*))
  92.   (setq *last-node* (link-both *last-branch* *last-node* r))
  93.   (setq *last-branch* *last-node*)) 
  94.  
  95. (defun link-left (pred succ)
  96.   (prog (a r)
  97.         (setq a (left-outs pred))
  98.         (setq r (find-equiv-node succ a))
  99.         (and r (return r))
  100.         (setq *real-cnt* (1+ *real-cnt*))
  101.         (attach-left pred succ)
  102.         (return succ))) 
  103.  
  104. (defun link-both (left right succ)
  105.   (prog (a r)
  106.         (setq a (interq (left-outs left) (right-outs right)))
  107.         (setq r (find-equiv-beta-node succ a))
  108.         (and r (return r))
  109.         (setq *real-cnt* (1+ *real-cnt*))
  110.         (attach-left left succ)
  111.         (attach-right right succ)
  112.         (return succ))) 
  113.  
  114. (defun attach-right (old new)
  115.   (rplaca (cddr old) (cons new (caddr old)))) 
  116.  
  117. (defun attach-left (old new)
  118.   (rplaca (cdr old) (cons new (cadr old)))) 
  119.  
  120. (defun right-outs (node) (caddr node)) 
  121.  
  122. (defun left-outs (node) (cadr node)) 
  123.  
  124. (defun find-equiv-node (node list)
  125.   (prog (a)
  126.         (setq a list)
  127.    l1   (cond ((atom a) (return nil))
  128.               ((equiv node (car a)) (return (car a))))
  129.         (setq a (cdr a))
  130.         (go l1))) 
  131.  
  132. (defun find-equiv-beta-node (node list)
  133.   (prog (a)
  134.         (setq a list)
  135.    l1   (cond ((atom a) (return nil))
  136.               ((beta-equiv node (car a)) (return (car a))))
  137.         (setq a (cdr a))
  138.         (go l1))) 
  139.  
  140. ; do not look at the predecessor fields of beta nodes; they have to be
  141. ; identical because of the way the candidate nodes were found
  142.  
  143. (defun equiv (a b)
  144.   (and (eq (car a) (car b))
  145.        (or (eq (car a) '&mem)
  146.            (eq (car a) '&two)
  147.            (equal (caddr a) (caddr b)))
  148.        (equal (cdddr a) (cdddr b)))) 
  149.  
  150. (defun beta-equiv (a b)
  151.   (and (eq (car a) (car b))
  152.        (equal (cddddr a) (cddddr b))
  153.        (or (eq (car a) '&and) (equal (caddr a) (caddr b))))) 
  154.  
  155. ; the equivalence tests are set up to consider the contents of
  156. ; node memories, so they are ready for the build action
  157.  
  158. ;;; Network interpreter
  159.  
  160. (defun match (flag wme)
  161.   (sendto flag (list wme) 'left (list *first-node*)))
  162.  
  163. ; note that eval-nodelist is not set up to handle building
  164. ; productions.  would have to add something like ops4's build-flag
  165.  
  166. (defun eval-nodelist (nl)
  167.   (prog nil
  168.    top  (and (not nl) (return nil))
  169.         (setq *sendtocall* nil)
  170.     (setq *last-node* (car nl))
  171.         (apply (caar nl) (cdar nl))
  172.         (setq nl (cdr nl))
  173.         (go top))) 
  174.  
  175. (defun sendto (flag data side nl)
  176.   (prog nil
  177.    top  (and (not nl) (return nil))
  178.         (setq *side* side)
  179.         (setq *flag-part* flag)
  180.         (setq *data-part* data)
  181.         (setq *sendtocall* t)
  182.     (setq *last-node* (car nl))
  183.         (apply (caar nl) (cdar nl))
  184.         (setq nl (cdr nl))
  185.         (go top))) 
  186.  
  187. ; &bus sets up the registers for the one-input nodes.  note that this
  188. (defun &bus (outs)
  189.   (prog (dp)
  190.         (setq *alpha-flag-part* *flag-part*)
  191.         (setq *alpha-data-part* *data-part*)
  192.         (setq dp (car *data-part*))
  193.         (setq *c1* (car dp))
  194.         (setq dp (cdr dp))
  195.         (setq *c2* (car dp))
  196.         (setq dp (cdr dp))
  197.         (setq *c3* (car dp))
  198.         (setq dp (cdr dp))
  199.         (setq *c4* (car dp))
  200.         (setq dp (cdr dp))
  201.         (setq *c5* (car dp))
  202.         (setq dp (cdr dp))
  203.         (setq *c6* (car dp))
  204.         (setq dp (cdr dp))
  205.         (setq *c7* (car dp))
  206.         (setq dp (cdr dp))
  207.         (setq *c8* (car dp))
  208.         (setq dp (cdr dp))
  209.         (setq *c9* (car dp))
  210.         (setq dp (cdr dp))
  211.         (setq *c10* (car dp))
  212.         (setq dp (cdr dp))
  213.         (setq *c11* (car dp))
  214.         (setq dp (cdr dp))
  215.         (setq *c12* (car dp))
  216.         (setq dp (cdr dp))
  217.         (setq *c13* (car dp))
  218.         (setq dp (cdr dp))
  219.         (setq *c14* (car dp))
  220.         (setq dp (cdr dp))
  221.         (setq *c15* (car dp))
  222.         (setq dp (cdr dp))
  223.         (setq *c16* (car dp))
  224.         (setq dp (cdr dp))
  225.         (setq *c17* (car dp))
  226.         (setq dp (cdr dp))
  227.         (setq *c18* (car dp))
  228.         (setq dp (cdr dp))
  229.         (setq *c19* (car dp))
  230.         (setq dp (cdr dp))
  231.         (setq *c20* (car dp))
  232.         (setq dp (cdr dp))
  233.         (setq *c21* (car dp))
  234.         (setq dp (cdr dp))
  235.         (setq *c22* (car dp))
  236.         (setq dp (cdr dp))
  237.         (setq *c23* (car dp))
  238.         (setq dp (cdr dp))
  239.         (setq *c24* (car dp))
  240.         (setq dp (cdr dp))
  241.         (setq *c25* (car dp))
  242.         (setq dp (cdr dp))
  243.         (setq *c26* (car dp))
  244.         (setq dp (cdr dp))
  245.         (setq *c27* (car dp))
  246.         (setq dp (cdr dp))
  247.         (setq *c28* (car dp))
  248.         (setq dp (cdr dp))
  249.         (setq *c29* (car dp))
  250.         (setq dp (cdr dp))
  251.         (setq *c30* (car dp))
  252.         (setq dp (cdr dp))
  253.         (setq *c31* (car dp))
  254.         (setq dp (cdr dp))
  255.         (setq *c32* (car dp))
  256.         (setq dp (cdr dp))
  257.         (setq *c33* (car dp))
  258.         (setq dp (cdr dp))
  259.         (setq *c34* (car dp))
  260.         (setq dp (cdr dp))
  261.         (setq *c35* (car dp))
  262.         (setq dp (cdr dp))
  263.         (setq *c36* (car dp))
  264.         (setq dp (cdr dp))
  265.         (setq *c37* (car dp))
  266.         (setq dp (cdr dp))
  267.         (setq *c38* (car dp))
  268.         (setq dp (cdr dp))
  269.         (setq *c39* (car dp))
  270.         (setq dp (cdr dp))
  271.         (setq *c40* (car dp))
  272.         (setq dp (cdr dp))
  273.         (setq *c41* (car dp))
  274.         (setq dp (cdr dp))
  275.         (setq *c42* (car dp))
  276.         (setq dp (cdr dp))
  277.         (setq *c43* (car dp))
  278.         (setq dp (cdr dp))
  279.         (setq *c44* (car dp))
  280.         (setq dp (cdr dp))
  281.         (setq *c45* (car dp))
  282.         (setq dp (cdr dp))
  283.         (setq *c46* (car dp))
  284.         (setq dp (cdr dp))
  285.         (setq *c47* (car dp))
  286.         (setq dp (cdr dp))
  287.         (setq *c48* (car dp))
  288.         (setq dp (cdr dp))
  289.         (setq *c49* (car dp))
  290.         (setq dp (cdr dp))
  291.         (setq *c50* (car dp))
  292.         (setq dp (cdr dp))
  293.         (setq *c51* (car dp))
  294.         (setq dp (cdr dp))
  295.         (setq *c52* (car dp))
  296.         (setq dp (cdr dp))
  297.         (setq *c53* (car dp))
  298.         (setq dp (cdr dp))
  299.         (setq *c54* (car dp))
  300.         (setq dp (cdr dp))
  301.         (setq *c55* (car dp))
  302.         (setq dp (cdr dp))
  303.         (setq *c56* (car dp))
  304.         (setq dp (cdr dp))
  305.         (setq *c57* (car dp))
  306.         (setq dp (cdr dp))
  307.         (setq *c58* (car dp))
  308.         (setq dp (cdr dp))
  309.         (setq *c59* (car dp))
  310.         (setq dp (cdr dp))
  311.         (setq *c60* (car dp))
  312.         (setq dp (cdr dp))
  313.         (setq *c61* (car dp))
  314.         (setq dp (cdr dp))
  315.         (setq *c62* (car dp))
  316.         (setq dp (cdr dp))
  317.         (setq *c63* (car dp))
  318.         (setq dp (cdr dp))
  319.         (setq *c64* (car dp))
  320.         (eval-nodelist outs))) 
  321.  
  322. (defun &any (outs register const-list)
  323.   (prog (z c)
  324.         (setq z (fast-symeval register))
  325.         (cond ((numberp z) (go number)))
  326.    symbol (cond ((null const-list) (return nil))
  327.                 ((eq (car const-list) z) (go ok))
  328.                 (t (setq const-list (cdr const-list)) (go symbol)))
  329.    number (cond ((null const-list) (return nil))
  330.                 ((and (numberp (setq c (car const-list)))
  331.                       (=alg c z))
  332.                  (go ok))
  333.                 (t (setq const-list (cdr const-list)) (go number)))
  334.    ok   (eval-nodelist outs))) 
  335.  
  336. (defun teqa (outs register constant)
  337.   (and (eq (fast-symeval register) constant) (eval-nodelist outs))) 
  338.  
  339. (defun tnea (outs register constant)
  340.   (and (not (eq (fast-symeval register) constant)) (eval-nodelist outs))) 
  341.  
  342. (defun txxa (outs register constant)
  343.   (and (symbolp (fast-symeval register)) (eval-nodelist outs))) 
  344.  
  345. (defun teqn (outs register constant)
  346.   (prog (z)
  347.         (setq z (fast-symeval register))
  348.         (and (numberp z)
  349.              (=alg z constant)
  350.              (eval-nodelist outs)))) 
  351.  
  352. (defun tnen (outs register constant)
  353.   (prog (z)
  354.         (setq z (fast-symeval register))
  355.         (and (or (not (numberp z))
  356.                  (not (=alg z constant)))
  357.              (eval-nodelist outs)))) 
  358.  
  359. (defun txxn (outs register constant)
  360.   (prog (z)
  361.         (setq z (fast-symeval register))
  362.         (and (numberp z) (eval-nodelist outs)))) 
  363.  
  364. (defun tltn (outs register constant)
  365.   (prog (z)
  366.         (setq z (fast-symeval register))
  367.         (and (numberp z)
  368.              (greaterp constant z)
  369.              (eval-nodelist outs)))) 
  370.  
  371. (defun tgtn (outs register constant)
  372.   (prog (z)
  373.         (setq z (fast-symeval register))
  374.         (and (numberp z)
  375.              (greaterp z constant)
  376.              (eval-nodelist outs)))) 
  377.  
  378. (defun tgen (outs register constant)
  379.   (prog (z)
  380.         (setq z (fast-symeval register))
  381.         (and (numberp z)
  382.              (not (greaterp constant z))
  383.              (eval-nodelist outs)))) 
  384.  
  385. (defun tlen (outs register constant)
  386.   (prog (z)
  387.         (setq z (fast-symeval register))
  388.         (and (numberp z)
  389.              (not (greaterp z constant))
  390.              (eval-nodelist outs)))) 
  391.  
  392. (defun teqs (outs vara varb)
  393.   (prog (a b)
  394.         (setq a (fast-symeval vara))
  395.         (setq b (fast-symeval varb))
  396.         (cond ((eq a b) (eval-nodelist outs))
  397.               ((and (numberp a)
  398.                     (numberp b)
  399.                     (=alg a b))
  400.                (eval-nodelist outs))))) 
  401.  
  402. (defun tnes (outs vara varb)
  403.   (prog (a b)
  404.         (setq a (fast-symeval vara))
  405.         (setq b (fast-symeval varb))
  406.         (cond ((eq a b) (return nil))
  407.               ((and (numberp a)
  408.                     (numberp b)
  409.                     (=alg a b))
  410.                (return nil))
  411.               (t (eval-nodelist outs))))) 
  412.  
  413. (defun txxs (outs vara varb)
  414.   (prog (a b)
  415.         (setq a (fast-symeval vara))
  416.         (setq b (fast-symeval varb))
  417.         (cond ((and (numberp a) (numberp b)) (eval-nodelist outs))
  418.               ((and (not (numberp a)) (not (numberp b)))
  419.                (eval-nodelist outs))))) 
  420.  
  421. (defun tlts (outs vara varb)
  422.   (prog (a b)
  423.         (setq a (fast-symeval vara))
  424.         (setq b (fast-symeval varb))
  425.         (and (numberp a)
  426.              (numberp b)
  427.              (greaterp b a)
  428.              (eval-nodelist outs)))) 
  429.  
  430. (defun tgts (outs vara varb)
  431.   (prog (a b)
  432.         (setq a (fast-symeval vara))
  433.         (setq b (fast-symeval varb))
  434.         (and (numberp a)
  435.              (numberp b)
  436.              (greaterp a b)
  437.              (eval-nodelist outs)))) 
  438.  
  439. (defun tges (outs vara varb)
  440.   (prog (a b)
  441.         (setq a (fast-symeval vara))
  442.         (setq b (fast-symeval varb))
  443.         (and (numberp a)
  444.              (numberp b)
  445.              (not (greaterp b a))
  446.              (eval-nodelist outs)))) 
  447.  
  448. (defun tles (outs vara varb)
  449.   (prog (a b)
  450.         (setq a (fast-symeval vara))
  451.         (setq b (fast-symeval varb))
  452.         (and (numberp a)
  453.              (numberp b)
  454.              (not (greaterp a b))
  455.              (eval-nodelist outs)))) 
  456.  
  457. (defun &two (left-outs right-outs)
  458.   (prog (fp dp)
  459.         (cond (*sendtocall*
  460.                (setq fp *flag-part*)
  461.                (setq dp *data-part*))
  462.               (t
  463.                (setq fp *alpha-flag-part*)
  464.                (setq dp *alpha-data-part*)))
  465.         (sendto fp dp 'left left-outs)
  466.         (sendto fp dp 'right right-outs))) 
  467.  
  468. (defun &mem (left-outs right-outs memory-list)
  469.   (prog (fp dp)
  470.         (cond (*sendtocall*
  471.                (setq fp *flag-part*)
  472.                (setq dp *data-part*))
  473.               (t
  474.                (setq fp *alpha-flag-part*)
  475.                (setq dp *alpha-data-part*)))
  476.         (sendto fp dp 'left left-outs)
  477.         (add-token memory-list fp dp nil)
  478.         (sendto fp dp 'right right-outs))) 
  479.  
  480. (defun &and (outs lpred rpred tests)
  481.   (prog (mem)
  482.         (cond ((eq *side* 'right) (setq mem (memory-part lpred)))
  483.               (t (setq mem (memory-part rpred))))
  484.         (cond ((not mem) (return nil))
  485.               ((eq *side* 'right) (and-right outs mem tests))
  486.               (t (and-left outs mem tests))))) 
  487.  
  488. (defun and-left (outs mem tests)
  489.   (prog (fp dp memdp tlist tst lind rind res)
  490.         (setq fp *flag-part*)
  491.         (setq dp *data-part*)
  492.    fail (and (null mem) (return nil))
  493.         (setq memdp (car mem))
  494.         (setq mem (cdr mem))
  495.         (setq tlist tests)
  496.    tloop (and (null tlist) (go succ))
  497.         (setq tst (car tlist))
  498.         (setq tlist (cdr tlist))
  499.         (setq lind (car tlist))
  500.         (setq tlist (cdr tlist))
  501.         (setq rind (car tlist))
  502.         (setq tlist (cdr tlist))
  503.         ;the next line differs in and-left & -right
  504.         (setq res (funcall tst (gelm memdp rind) (gelm dp lind)))
  505.         (cond (res (go tloop))
  506.               (t (go fail)))
  507.    succ ;the next line differs in and-left & -right
  508.         (sendto fp (cons (car memdp) dp) 'left outs)
  509.         (go fail))) 
  510.  
  511. (defun and-right (outs mem tests)
  512.   (prog (fp dp memdp tlist tst lind rind res)
  513.         (setq fp *flag-part*)
  514.         (setq dp *data-part*)
  515.    fail (and (null mem) (return nil))
  516.         (setq memdp (car mem))
  517.         (setq mem (cdr mem))
  518.         (setq tlist tests)
  519.    tloop (and (null tlist) (go succ))
  520.         (setq tst (car tlist))
  521.         (setq tlist (cdr tlist))
  522.         (setq lind (car tlist))
  523.         (setq tlist (cdr tlist))
  524.         (setq rind (car tlist))
  525.         (setq tlist (cdr tlist))
  526.         ;the next line differs in and-left & -right
  527.         (setq res (funcall tst (gelm dp rind) (gelm memdp lind)))
  528.         (cond (res (go tloop))
  529.               (t (go fail)))
  530.    succ ;the next line differs in and-left & -right
  531.         (sendto fp (cons (car dp) memdp) 'right outs)
  532.         (go fail))) 
  533.  
  534.  
  535. (defun teqb (new eqvar)
  536.   (cond ((eq new eqvar) t)
  537.         ((not (numberp new)) nil)
  538.         ((not (numberp eqvar)) nil)
  539.         ((=alg new eqvar) t)
  540.         (t nil))) 
  541.  
  542. (defun tneb (new eqvar)
  543.   (cond ((eq new eqvar) nil)
  544.         ((not (numberp new)) t)
  545.         ((not (numberp eqvar)) t)
  546.         ((=alg new eqvar) nil)
  547.         (t t))) 
  548.  
  549. (defun tltb (new eqvar)
  550.   (cond ((not (numberp new)) nil)
  551.         ((not (numberp eqvar)) nil)
  552.         ((greaterp eqvar new) t)
  553.         (t nil))) 
  554.  
  555. (defun tgtb (new eqvar)
  556.   (cond ((not (numberp new)) nil)
  557.         ((not (numberp eqvar)) nil)
  558.         ((greaterp new eqvar) t)
  559.         (t nil))) 
  560.  
  561. (defun tgeb (new eqvar)
  562.   (cond ((not (numberp new)) nil)
  563.         ((not (numberp eqvar)) nil)
  564.         ((not (greaterp eqvar new)) t)
  565.         (t nil))) 
  566.  
  567. (defun tleb (new eqvar)
  568.   (cond ((not (numberp new)) nil)
  569.         ((not (numberp eqvar)) nil)
  570.         ((not (greaterp new eqvar)) t)
  571.         (t nil))) 
  572.  
  573. (defun txxb (new eqvar)
  574.   (cond ((numberp new)
  575.          (cond ((numberp eqvar) t)
  576.                (t nil)))
  577.         (t
  578.          (cond ((numberp eqvar) nil)
  579.                (t t))))) 
  580.  
  581.  
  582. (defun &p (rating name var-dope ce-var-dope rhs)
  583.   (prog (fp dp)
  584.         (cond (*sendtocall*
  585.                (setq fp *flag-part*)
  586.                (setq dp *data-part*))
  587.               (t
  588.                (setq fp *alpha-flag-part*)
  589.                (setq dp *alpha-data-part*)))
  590.         (and (member fp '(nil old)) (removecs name dp))
  591.         (and fp (insertcs name dp rating)))) 
  592.  
  593. (defun &old (a b c d e) nil) ;a null function used for deleting node
  594.  
  595. (defun ¬ (outs lmem rpred tests)
  596.   (cond ((and (eq *side* 'right) (eq *flag-part* 'old)) nil)
  597.         ((eq *side* 'right) (not-right outs (car lmem) tests))
  598.         (t (not-left outs (memory-part rpred) tests lmem)))) 
  599.  
  600. (defun not-left (outs mem tests own-mem)
  601.   (prog (fp dp memdp tlist tst lind rind res c)
  602.         (setq fp *flag-part*)
  603.         (setq dp *data-part*)
  604.         (setq c 0.)
  605.    fail (and (null mem) (go fin))
  606.         (setq memdp (car mem))
  607.         (setq mem (cdr mem))
  608.         (setq tlist tests)
  609.    tloop (and (null tlist) (setq c (1+ c)) (go fail))
  610.         (setq tst (car tlist))
  611.         (setq tlist (cdr tlist))
  612.         (setq lind (car tlist))
  613.         (setq tlist (cdr tlist))
  614.         (setq rind (car tlist))
  615.         (setq tlist (cdr tlist))
  616.         ;the next line differs in not-left & -right
  617.         (setq res (funcall tst (gelm memdp rind) (gelm dp lind)))
  618.         (cond (res (go tloop))
  619.               (t (go fail)))
  620.    fin  (add-token own-mem fp dp c)
  621.         (and (== c 0.) (sendto fp dp 'left outs)))) 
  622.  
  623. (defun not-right (outs mem tests)
  624.   (prog (fp dp memdp tlist tst lind rind res newfp inc newc)
  625.         (setq fp *flag-part*)
  626.         (setq dp *data-part*)
  627.         (cond ((not fp) (setq inc -1.) (setq newfp 'new))
  628.               ((eq fp 'new) (setq inc 1.) (setq newfp nil))
  629.               (t (return nil)))
  630.    fail (and (null mem) (return nil))
  631.         (setq memdp (car mem))
  632.         (setq newc (cadr mem))
  633.         (setq tlist tests)
  634.    tloop (and (null tlist) (go succ))
  635.         (setq tst (car tlist))
  636.         (setq tlist (cdr tlist))
  637.         (setq lind (car tlist))
  638.         (setq tlist (cdr tlist))
  639.         (setq rind (car tlist))
  640.         (setq tlist (cdr tlist))
  641.         ;the next line differs in not-left & -right
  642.         (setq res (funcall tst (gelm dp rind) (gelm memdp lind)))
  643.         (cond (res (go tloop))
  644.               (t (setq mem (cddr mem)) (go fail)))
  645.    succ (setq newc (+ inc newc))
  646.         (rplaca (cdr mem) newc)
  647.         (cond ((or (and (== inc -1.) (== newc 0.))
  648.                    (and (== inc 1.) (== newc 1.)))
  649.                (sendto newfp memdp 'right outs)))
  650.         (setq mem (cddr mem))
  651.         (go fail))) 
  652.  
  653.  
  654.  
  655. ;;; Node memories
  656.  
  657.  
  658. (defun add-token (memlis flag data-part num)
  659.   (prog (was-present)
  660.         (cond ((eq flag 'new)
  661.                (setq was-present nil)
  662.                (real-add-token memlis data-part num))
  663.               ((not flag) 
  664.            (setq was-present (remove-old memlis data-part num)))
  665.               ((eq flag 'old) (setq was-present t)))
  666.         (return was-present))) 
  667.  
  668. (defun real-add-token (lis data-part num)
  669.   (setq *current-token* (1+ *current-token*))
  670.   (cond (num (rplaca lis (cons num (car lis)))))
  671.   (rplaca lis (cons data-part (car lis)))) 
  672.  
  673. (defun remove-old (lis data num)
  674.   (cond (num (remove-old-num lis data))
  675.         (t (remove-old-no-num lis data)))) 
  676.  
  677. (defun remove-old-num (lis data)
  678.   (prog (m next last)
  679.         (setq m (car lis))
  680.         (cond ((atom m) (return nil))
  681.               ((top-levels-eq data (car m))
  682.                (setq *current-token* (1- *current-token*))
  683.                (rplaca lis (cddr m))
  684.                (return (car m))))
  685.         (setq next m)
  686.    loop (setq last next)
  687.         (setq next (cddr next))
  688.         (cond ((atom next) (return nil))
  689.               ((top-levels-eq data (car next))
  690.                (rplacd (cdr last) (cddr next))
  691.                (setq *current-token* (1- *current-token*))
  692.                (return (car next)))
  693.               (t (go loop))))) 
  694.  
  695. (defun remove-old-no-num (lis data)
  696.   (prog (m next last)
  697.         (setq m (car lis))
  698.         (cond ((atom m) (return nil))
  699.               ((top-levels-eq data (car m))
  700.                (setq *current-token* (1- *current-token*))
  701.                (rplaca lis (cdr m))
  702.                (return (car m))))
  703.         (setq next m)
  704.    loop (setq last next)
  705.         (setq next (cdr next))
  706.         (cond ((atom next) (return nil))
  707.               ((top-levels-eq data (car next))
  708.                (rplacd last (cdr next))
  709.                (setq *current-token* (1- *current-token*))
  710.                (return (car next)))
  711.               (t (go loop))))) 
  712.  
  713.  
  714.  
  715. ;;; Conflict Resolution
  716. ;
  717. ;
  718. ; each conflict set element is a list of the following form:
  719. ; ((p-name . data-part) (sorted wm-recency) special-case-number)
  720.  
  721. (defun removecs (name data)
  722.   (prog (cr-data inst cs)
  723.         (setq cr-data (cons name data))
  724.     (setq cs *conflict-set*)
  725.  loop1    (cond ((null cs) 
  726.                (record-refract name data)
  727.                (return nil)))
  728.     (setq inst (car cs))
  729.     (setq cs (cdr cs))
  730.     (and (not (top-levels-eq (car inst) cr-data)) (go loop1))
  731.         (setq *conflict-set* (delete inst *conflict-set* :test #'eq))))
  732.  
  733. (defun insertcs (name data rating)
  734.   (prog (instan)
  735.     (and (refracted name data) (return nil))
  736.     (setq instan (list (cons name data) (order-tags data) rating))
  737.     (and (atom *conflict-set*) (setq *conflict-set* nil))
  738.     (return (setq *conflict-set* (cons instan *conflict-set*))))) 
  739.  
  740. (defun order-tags (dat)
  741.   (prog (tags)
  742.         (setq tags nil)
  743.    l1  (and (atom dat) (go l2))
  744.         (setq tags (cons (creation-time (car dat)) tags))
  745.         (setq dat (cdr dat))
  746.         (go l1)
  747.    l2  (cond ((eq *strategy* 'mea)
  748.                (return (cons (car tags) (dsort (cdr tags)))))
  749.               (t (return (dsort tags)))))) 
  750.  
  751. ; destructively sort x into descending order
  752.  
  753. (defun dsort (x)
  754.   (prog (sorted cur next cval nval)
  755.         (and (atom (cdr x)) (return x))
  756.    loop (setq sorted t)
  757.         (setq cur x)
  758.         (setq next (cdr x))
  759.    chek (setq cval (car cur))
  760.         (setq nval (car next))
  761.         (cond ((> nval cval)
  762.                (setq sorted nil)
  763.                (rplaca cur nval)
  764.                (rplaca next cval)))
  765.         (setq cur next)
  766.         (setq next (cdr cur))
  767.         (cond ((not (null next)) (go chek))
  768.               (sorted (return x))
  769.               (t (go loop))))) 
  770.  
  771. (defun conflict-resolution nil
  772.   (prog (best len)
  773.         (setq len (length *conflict-set*))
  774.         (cond ((> len *max-cs*) (setq *max-cs* len)))
  775.         (setq *total-cs* (+ *total-cs* len))
  776.         (cond (*conflict-set*
  777.                (setq best (best-of *conflict-set*))
  778.                (setq *conflict-set* (delete best *conflict-set* :test #'eq))
  779.                (return (pname-instantiation best)))
  780.               (t (return nil))))) 
  781.  
  782. (defun best-of (set) (best-of* (car set) (cdr set))) 
  783.  
  784. (defun best-of* (best rem)
  785.   (cond ((not rem) best)
  786.         ((conflict-set-compare best (car rem))
  787.          (best-of* best (cdr rem)))
  788.         (t (best-of* (car rem) (cdr rem))))) 
  789.  
  790. (defun remove-from-conflict-set (name)
  791.   (prog (cs entry)
  792.    l1   (setq cs *conflict-set*)
  793.    l2   (cond ((atom cs) (return nil)))
  794.         (setq entry (car cs))
  795.         (setq cs (cdr cs))
  796.         (cond ((eq name (caar entry))
  797.                (setq *conflict-set* (delete entry *conflict-set* :test #'eq))
  798.                (go l1))
  799.               (t (go l2))))) 
  800.  
  801. (defun pname-instantiation (conflict-elem) (car conflict-elem)) 
  802.  
  803. (defun order-part (conflict-elem) (cdr conflict-elem)) 
  804.  
  805. (defun instantiation (conflict-elem)
  806.   (cdr (pname-instantiation conflict-elem))) 
  807.  
  808.  
  809. (defun conflict-set-compare (x y)
  810.   (prog (x-order y-order xl yl xv yv)
  811.         (setq x-order (order-part x))
  812.         (setq y-order (order-part y))
  813.         (setq xl (car x-order))
  814.         (setq yl (car y-order))
  815.    data (cond ((and (null xl) (null yl)) (go ps))
  816.               ((null yl) (return t))
  817.               ((null xl) (return nil)))
  818.         (setq xv (car xl))
  819.         (setq yv (car yl))
  820.         (cond ((> xv yv) (return t))
  821.               ((> yv xv) (return nil)))
  822.         (setq xl (cdr xl))
  823.         (setq yl (cdr yl))
  824.         (go data)
  825.    ps   (setq xl (cdr x-order))
  826.         (setq yl (cdr y-order))
  827.    psl  (cond ((null xl) (return t)))
  828.         (setq xv (car xl))
  829.         (setq yv (car yl))
  830.         (cond ((> xv yv) (return t))
  831.               ((> yv xv) (return nil)))
  832.         (setq xl (cdr xl))
  833.         (setq yl (cdr yl))
  834.         (go psl))) 
  835.  
  836.  
  837. (defun conflict-set nil
  838.   (prog (cnts cs p z best)
  839.         (setq cnts nil)
  840.         (setq cs *conflict-set*)
  841.    l1  (and (atom cs) (go l2))
  842.         (setq p (caaar cs))
  843.         (setq cs (cdr cs))
  844.         (setq z (assoc p cnts :test #'eq))
  845.         (cond ((null z) (setq cnts (cons (cons p 1.) cnts)))
  846.               (t (rplacd z (1+ (cdr z)))))
  847.         (go l1)
  848.    l2  (cond ((atom cnts)
  849.                (setq best (best-of *conflict-set*))
  850.                (terpri)
  851.                (return (list (caar best) 'dominates))))
  852.         (terpri)
  853.         (princ (caar cnts))
  854.         (cond ((> (cdar cnts) 1.)
  855.                (princ '|    (|)
  856.                (princ (cdar cnts))
  857.                (princ '| occurrences)|)))
  858.         (setq cnts (cdr cnts))
  859.         (go l2))) 
  860.  
  861.