home *** CD-ROM | disk | FTP | other *** search
/ The World of Computer Software / World_Of_Computer_Software-02-385-Vol-1of3.iso / o / ops5.zip / OPS-MATC.LIS < prev    next >
Lisp/Scheme  |  1992-03-06  |  20KB  |  750 lines
  1. ;
  2. ;************************************************************************
  3. ;
  4. ;    VPS2 -- Interpreter for OPS5
  5. ;
  6. ;
  7. ;
  8. ; This Common Lisp version of OPS5 is in the public domain.  It is based
  9. ; in part on based on a Franz Lisp implementation done by Charles L. Forgy
  10. ; at Carnegie-Mellon University, which was placed in the public domain by
  11. ; the author in accordance with CMU policies.  This version has been
  12. ; modified by George Wood, Dario Giuse, Skef Wholey, Michael Parzen,
  13. ; and Dan Kuokka.
  14. ;
  15. ; This code is made available is, and without warranty of any kind by the
  16. ; authors or by Carnegie-Mellon University.
  17. ;
  18.  
  19. ;;;; This file contains the functions that match working memory
  20. ;;;; elements against productions LHS.
  21.  
  22. (in-package "OPS")
  23.  
  24.  
  25.  
  26. ;;; External global variables
  27.  
  28. (defvar *current-token*)
  29.  
  30.  
  31. ;;; Internal global variables
  32.  
  33. (defvar *alpha-data-part*)
  34. (defvar *alpha-flag-part*)
  35. (defvar *flag-part*)
  36. (defvar *data-part*)
  37. (defvar *sendtocall*)
  38. (defvar *side*)
  39. (proclaim '(special *c1* *c2* *c3* *c4* *c5* *c6* *c7* *c8* *c9*
  40.        *c10* *c11* *c12* *c13* *c14* *c15* *c16* *c17* *c18* *c19*
  41.        *c20* *c21* *c22* *c23* *c24* *c25* *c26* *c27* *c28* *c29*
  42.        *c30* *c31* *c32* *c33* *c34* *c35* *c36* *c37* *c38* *c39*
  43.        *c40* *c41* *c42* *c43* *c44* *c45* *c46* *c47* *c48* *c49*
  44.        *c50* *c51* *c52* *c53* *c54* *c55* *c56* *c57* *c58* *c59*
  45.        *c60* *c61* *c62* *c63* *c64* *c65* *c66* *c67* *c68* *c69*
  46.        *c70* *c71* *c72* *c73* *c74* *c75* *c76* *c77* *c78* *c79*
  47.        *c80* *c81* *c82* *c83* *c84* *c85* *c86* *c87* *c88* *c89*
  48.        *c90* *c91* *c92* *c93* *c94* *c95* *c96* *c97* *c98* *c99*
  49.        *c100* *c101* *c102* *c103* *c104* *c105* *c106* *c107* *c108* *c109*
  50.        *c110* *c111* *c112* *c113* *c114* *c115* *c116* *c117* *c118* *c119*
  51.        *c120* *c121* *c122* *c123* *c124* *c125* *c126* *c127*))
  52.  
  53.  
  54.  
  55. ;;; Network interpreter
  56.  
  57.  
  58. (defun match-init ()
  59.   (setq *current-token* 0.))
  60.  
  61.  
  62. (defun match (flag wme)
  63.   (sendto flag (list wme) 'left (list *first-node*)))
  64.  
  65. ; note that eval-nodelist is not set up to handle building
  66. ; productions.  would have to add something like ops4's build-flag
  67.  
  68. (defun eval-nodelist (nl)
  69.   (prog nil
  70.     top  (and (not nl) (return nil))
  71.     (setq *sendtocall* nil)
  72.     (setq *last-node* (car nl))
  73.     (apply (caar nl) (cdar nl))
  74.     (setq nl (cdr nl))
  75.     (go top))) 
  76.  
  77. (defun sendto (flag data side nl)
  78.   (prog nil
  79.     top  (and (not nl) (return nil))
  80.     (setq *side* side)
  81.     (setq *flag-part* flag)
  82.     (setq *data-part* data)
  83.     (setq *sendtocall* t)
  84.     (setq *last-node* (car nl))
  85.     (apply (caar nl) (cdar nl))
  86.     (setq nl (cdr nl))
  87.     (go top))) 
  88.  
  89. ; &bus sets up the registers for the one-input nodes.  note that this
  90. (defun &bus (outs)
  91.   (prog (dp)
  92.     (setq *alpha-flag-part* *flag-part*)
  93.     (setq *alpha-data-part* *data-part*)
  94.     (setq dp (car *data-part*))
  95.     (setq *c1* (car dp))
  96.     (setq dp (cdr dp))
  97.     (setq *c2* (car dp))
  98.     (setq dp (cdr dp))
  99.     (setq *c3* (car dp))
  100.     (setq dp (cdr dp))
  101.     (setq *c4* (car dp))
  102.     (setq dp (cdr dp))
  103.     (setq *c5* (car dp))
  104.     (setq dp (cdr dp))
  105.     (setq *c6* (car dp))
  106.     (setq dp (cdr dp))
  107.     (setq *c7* (car dp))
  108.     (setq dp (cdr dp))
  109.     (setq *c8* (car dp))
  110.     (setq dp (cdr dp))
  111.     (setq *c9* (car dp))
  112.     (setq dp (cdr dp))
  113.     (setq *c10* (car dp))
  114.     (setq dp (cdr dp))
  115.     (setq *c11* (car dp))
  116.     (setq dp (cdr dp))
  117.     (setq *c12* (car dp))
  118.     (setq dp (cdr dp))
  119.     (setq *c13* (car dp))
  120.     (setq dp (cdr dp))
  121.     (setq *c14* (car dp))
  122.     (setq dp (cdr dp))
  123.     (setq *c15* (car dp))
  124.     (setq dp (cdr dp))
  125.     (setq *c16* (car dp))
  126.     (setq dp (cdr dp))
  127.     (setq *c17* (car dp))
  128.     (setq dp (cdr dp))
  129.     (setq *c18* (car dp))
  130.     (setq dp (cdr dp))
  131.     (setq *c19* (car dp))
  132.     (setq dp (cdr dp))
  133.     (setq *c20* (car dp))
  134.     (setq dp (cdr dp))
  135.     (setq *c21* (car dp))
  136.     (setq dp (cdr dp))
  137.     (setq *c22* (car dp))
  138.     (setq dp (cdr dp))
  139.     (setq *c23* (car dp))
  140.     (setq dp (cdr dp))
  141.     (setq *c24* (car dp))
  142.     (setq dp (cdr dp))
  143.     (setq *c25* (car dp))
  144.     (setq dp (cdr dp))
  145.     (setq *c26* (car dp))
  146.     (setq dp (cdr dp))
  147.     (setq *c27* (car dp))
  148.     (setq dp (cdr dp))
  149.     (setq *c28* (car dp))
  150.     (setq dp (cdr dp))
  151.     (setq *c29* (car dp))
  152.     (setq dp (cdr dp))
  153.     (setq *c30* (car dp))
  154.     (setq dp (cdr dp))
  155.     (setq *c31* (car dp))
  156.     (setq dp (cdr dp))
  157.     (setq *c32* (car dp))
  158.     (setq dp (cdr dp))
  159.     (setq *c33* (car dp))
  160.     (setq dp (cdr dp))
  161.     (setq *c34* (car dp))
  162.     (setq dp (cdr dp))
  163.     (setq *c35* (car dp))
  164.     (setq dp (cdr dp))
  165.     (setq *c36* (car dp))
  166.     (setq dp (cdr dp))
  167.     (setq *c37* (car dp))
  168.     (setq dp (cdr dp))
  169.     (setq *c38* (car dp))
  170.     (setq dp (cdr dp))
  171.     (setq *c39* (car dp))
  172.     (setq dp (cdr dp))
  173.     (setq *c40* (car dp))
  174.     (setq dp (cdr dp))
  175.     (setq *c41* (car dp))
  176.     (setq dp (cdr dp))
  177.     (setq *c42* (car dp))
  178.     (setq dp (cdr dp))
  179.     (setq *c43* (car dp))
  180.     (setq dp (cdr dp))
  181.     (setq *c44* (car dp))
  182.     (setq dp (cdr dp))
  183.     (setq *c45* (car dp))
  184.     (setq dp (cdr dp))
  185.     (setq *c46* (car dp))
  186.     (setq dp (cdr dp))
  187.     (setq *c47* (car dp))
  188.     (setq dp (cdr dp))
  189.     (setq *c48* (car dp))
  190.     (setq dp (cdr dp))
  191.     (setq *c49* (car dp))
  192.     (setq dp (cdr dp))
  193.     (setq *c50* (car dp))
  194.     (setq dp (cdr dp))
  195.     (setq *c51* (car dp))
  196.     (setq dp (cdr dp))
  197.     (setq *c52* (car dp))
  198.     (setq dp (cdr dp))
  199.     (setq *c53* (car dp))
  200.     (setq dp (cdr dp))
  201.     (setq *c54* (car dp))
  202.     (setq dp (cdr dp))
  203.     (setq *c55* (car dp))
  204.     (setq dp (cdr dp))
  205.     (setq *c56* (car dp))
  206.     (setq dp (cdr dp))
  207.     (setq *c57* (car dp))
  208.     (setq dp (cdr dp))
  209.     (setq *c58* (car dp))
  210.     (setq dp (cdr dp))
  211.     (setq *c59* (car dp))
  212.     (setq dp (cdr dp))
  213.     (setq *c60* (car dp))
  214.     (setq dp (cdr dp))
  215.     (setq *c61* (car dp))
  216.     (setq dp (cdr dp))
  217.     (setq *c62* (car dp))
  218.     (setq dp (cdr dp))
  219.     (setq *c63* (car dp))
  220.     (setq dp (cdr dp))
  221.     (setq *c64* (car dp))
  222.     ;-------- added for 127 atr
  223.     (setq dp (cdr dp))
  224.     (setq *c65* (car dp))
  225.     (setq dp (cdr dp))
  226.     (setq *c66* (car dp))
  227.     (setq dp (cdr dp))
  228.     (setq *c67* (car dp))
  229.     (setq dp (cdr dp))
  230.     (setq *c68* (car dp))
  231.     (setq dp (cdr dp))
  232.     (setq *c69*(car dp))
  233.     (setq dp (cdr dp))
  234.     (setq *c70* (car dp))
  235.     (setq dp (cdr dp))
  236.     (setq *c71* (car dp))
  237.     (setq dp (cdr dp))
  238.     (setq *c72* (car dp))
  239.     (setq dp (cdr dp))
  240.     (setq *c73* (car dp))
  241.     (setq dp (cdr dp))
  242.     (setq *c74* (car dp))
  243.     (setq dp (cdr dp))
  244.     (setq *c75* (car dp))
  245.     (setq dp (cdr dp))
  246.     (setq *c76* (car dp))
  247.     (setq dp (cdr dp))
  248.     (setq *c77* (car dp))
  249.     (setq dp (cdr dp))
  250.     (setq *c78* (car dp))
  251.     (setq dp (cdr dp))
  252.     (setq *c79*(car dp))
  253.     (setq dp (cdr dp))
  254.     (setq *c80* (car dp))
  255.     (setq dp (cdr dp))
  256.     (setq *c81* (car dp))
  257.     (setq dp (cdr dp))
  258.     (setq *c82* (car dp))
  259.     (setq dp (cdr dp))
  260.     (setq *c83* (car dp))
  261.     (setq dp (cdr dp))
  262.     (setq *c84* (car dp))
  263.     (setq dp (cdr dp))
  264.     (setq *c85* (car dp))
  265.     (setq dp (cdr dp))
  266.     (setq *c86* (car dp))
  267.     (setq dp (cdr dp))
  268.     (setq *c87* (car dp))
  269.     (setq dp (cdr dp))
  270.     (setq *c88* (car dp))
  271.     (setq dp (cdr dp))
  272.     (setq *c89*(car dp))
  273.     (setq dp (cdr dp))
  274.     (setq *c90* (car dp))
  275.     (setq dp (cdr dp))
  276.     (setq *c91* (car dp))
  277.     (setq dp (cdr dp))
  278.     (setq *c92* (car dp))
  279.     (setq dp (cdr dp))
  280.     (setq *c93* (car dp))
  281.     (setq dp (cdr dp))
  282.     (setq *c94* (car dp))
  283.     (setq dp (cdr dp))
  284.     (setq *c95* (car dp))
  285.     (setq dp (cdr dp))
  286.     (setq *c96* (car dp))
  287.     (setq dp (cdr dp))
  288.     (setq *c97* (car dp))
  289.     (setq dp (cdr dp))
  290.     (setq *c98* (car dp))
  291.     (setq dp (cdr dp))
  292.     (setq *c99*(car dp))
  293.     (setq dp (cdr dp))
  294.     (setq *c100* (car dp))
  295.     (setq dp (cdr dp))
  296.     (setq *c101* (car dp))
  297.     (setq dp (cdr dp))
  298.     (setq *c102* (car dp))
  299.     (setq dp (cdr dp))
  300.     (setq *c103* (car dp))
  301.     (setq dp (cdr dp))
  302.     (setq *c104* (car dp))
  303.     (setq dp (cdr dp))
  304.     (setq *c105* (car dp))
  305.     (setq dp (cdr dp))
  306.     (setq *c106* (car dp))
  307.     (setq dp (cdr dp))
  308.     (setq *c107* (car dp))
  309.     (setq dp (cdr dp))
  310.     (setq *c108* (car dp))
  311.     (setq dp (cdr dp))
  312.     (setq *c109*(car dp))
  313.     (setq dp (cdr dp))
  314.     (setq *c110* (car dp))
  315.     (setq dp (cdr dp))
  316.     (setq *c111* (car dp))
  317.     (setq dp (cdr dp))
  318.     (setq *c112* (car dp))
  319.     (setq dp (cdr dp))
  320.     (setq *c113* (car dp))
  321.     (setq dp (cdr dp))
  322.     (setq *c114* (car dp))
  323.     (setq dp (cdr dp))
  324.     (setq *c115* (car dp))
  325.     (setq dp (cdr dp))
  326.     (setq *c116* (car dp))
  327.     (setq dp (cdr dp))
  328.     (setq *c117* (car dp))
  329.     (setq dp (cdr dp))
  330.     (setq *c118* (car dp))
  331.     (setq dp (cdr dp))
  332.     (setq *c119*(car dp))
  333.     (setq dp (cdr dp))
  334.     (setq *c120* (car dp))
  335.     (setq dp (cdr dp))
  336.     (setq *c121* (car dp))
  337.     (setq dp (cdr dp))
  338.     (setq *c122* (car dp))
  339.     (setq dp (cdr dp))
  340.     (setq *c123* (car dp))
  341.     (setq dp (cdr dp))
  342.     (setq *c124* (car dp))
  343.     (setq dp (cdr dp))
  344.     (setq *c125* (car dp))
  345.     (setq dp (cdr dp))
  346.     (setq *c126* (car dp))
  347.     (setq dp (cdr dp))
  348.     (setq *c127* (car dp))
  349.     ;(setq dp (cdr dp))
  350.     ;(setq *c128* (car dp))
  351.     ;--------
  352.     (eval-nodelist outs))) 
  353.  
  354. (defun &any (outs register const-list)
  355.   (prog (z c)
  356.     (setq z (fast-symeval register))
  357.     (cond ((numberp z) (go number)))
  358.     symbol (cond ((null const-list) (return nil))
  359.          ((eq (car const-list) z) (go ok))
  360.          (t (setq const-list (cdr const-list)) (go symbol)))
  361.     number (cond ((null const-list) (return nil))
  362.          ((and (numberp (setq c (car const-list)))
  363.                (=alg c z))
  364.           (go ok))
  365.          (t (setq const-list (cdr const-list)) (go number)))
  366.     ok   (eval-nodelist outs))) 
  367.  
  368. (defun teqa (outs register constant)
  369.   (and (eq (fast-symeval register) constant) (eval-nodelist outs))) 
  370.  
  371. (defun tnea (outs register constant)
  372.   (and (not (eq (fast-symeval register) constant)) (eval-nodelist outs))) 
  373.  
  374. (defun txxa (outs register constant)
  375.   (declare (ignore constant))
  376.   (and (symbolp (fast-symeval register)) (eval-nodelist outs))) 
  377.  
  378. (defun teqn (outs register constant)
  379.   (prog (z)
  380.     (setq z (fast-symeval register))
  381.     (and (numberp z)
  382.      (=alg z constant)
  383.      (eval-nodelist outs)))) 
  384.  
  385. (defun tnen (outs register constant)
  386.   (prog (z)
  387.     (setq z (fast-symeval register))
  388.     (and (or (not (numberp z))
  389.          (not (=alg z constant)))
  390.      (eval-nodelist outs)))) 
  391.  
  392. (defun txxn (outs register constant)
  393.   (declare (ignore constant))
  394.   (prog (z)
  395.     (setq z (fast-symeval register))
  396.     (and (numberp z) (eval-nodelist outs)))) 
  397.  
  398. (defun tltn (outs register constant)
  399.   (prog (z)
  400.     (setq z (fast-symeval register))
  401.     (and (numberp z)
  402.      (> constant z)
  403.      (eval-nodelist outs)))) 
  404.  
  405. (defun tgtn (outs register constant)
  406.   (prog (z)
  407.     (setq z (fast-symeval register))
  408.     (and (numberp z)
  409.      (> z constant)
  410.      (eval-nodelist outs)))) 
  411.  
  412. (defun tgen (outs register constant)
  413.   (prog (z)
  414.     (setq z (fast-symeval register))
  415.     (and (numberp z)
  416.      (not (> constant z))
  417.      (eval-nodelist outs)))) 
  418.  
  419. (defun tlen (outs register constant)
  420.   (prog (z)
  421.     (setq z (fast-symeval register))
  422.     (and (numberp z)
  423.      (not (> z constant))
  424.      (eval-nodelist outs)))) 
  425.  
  426. (defun teqs (outs vara varb)
  427.   (prog (a b)
  428.     (setq a (fast-symeval vara))
  429.     (setq b (fast-symeval varb))
  430.     (cond ((eq a b) (eval-nodelist outs))
  431.       ((and (numberp a)
  432.         (numberp b)
  433.         (=alg a b))
  434.        (eval-nodelist outs))))) 
  435.  
  436. (defun tnes (outs vara varb)
  437.   (prog (a b)
  438.     (setq a (fast-symeval vara))
  439.     (setq b (fast-symeval varb))
  440.     (cond ((eq a b) (return nil))
  441.       ((and (numberp a)
  442.         (numberp b)
  443.         (=alg a b))
  444.        (return nil))
  445.       (t (eval-nodelist outs))))) 
  446.  
  447. (defun txxs (outs vara varb)
  448.   (prog (a b)
  449.     (setq a (fast-symeval vara))
  450.     (setq b (fast-symeval varb))
  451.     (cond ((and (numberp a) (numberp b)) (eval-nodelist outs))
  452.       ((and (not (numberp a)) (not (numberp b)))
  453.        (eval-nodelist outs))))) 
  454.  
  455. (defun tlts (outs vara varb)
  456.   (prog (a b)
  457.     (setq a (fast-symeval vara))
  458.     (setq b (fast-symeval varb))
  459.     (and (numberp a)
  460.      (numberp b)
  461.      (> b a)
  462.      (eval-nodelist outs)))) 
  463.  
  464. (defun tgts (outs vara varb)
  465.   (prog (a b)
  466.     (setq a (fast-symeval vara))
  467.     (setq b (fast-symeval varb))
  468.     (and (numberp a)
  469.      (numberp b)
  470.      (> a b)
  471.      (eval-nodelist outs)))) 
  472.  
  473. (defun tges (outs vara varb)
  474.   (prog (a b)
  475.     (setq a (fast-symeval vara))
  476.     (setq b (fast-symeval varb))
  477.     (and (numberp a)
  478.      (numberp b)
  479.      (not (> b a))
  480.      (eval-nodelist outs)))) 
  481.  
  482. (defun tles (outs vara varb)
  483.   (prog (a b)
  484.     (setq a (fast-symeval vara))
  485.     (setq b (fast-symeval varb))
  486.     (and (numberp a)
  487.      (numberp b)
  488.      (not (> a b))
  489.      (eval-nodelist outs)))) 
  490.  
  491. (defun &two (left-outs right-outs)
  492.   (prog (fp dp)
  493.     (cond (*sendtocall*
  494.        (setq fp *flag-part*)
  495.        (setq dp *data-part*))
  496.       (t
  497.        (setq fp *alpha-flag-part*)
  498.        (setq dp *alpha-data-part*)))
  499.     (sendto fp dp 'left left-outs)
  500.     (sendto fp dp 'right right-outs))) 
  501.  
  502. (defun &mem (left-outs right-outs memory-list)
  503.   (prog (fp dp)
  504.     (cond (*sendtocall*
  505.        (setq fp *flag-part*)
  506.        (setq dp *data-part*))
  507.       (t
  508.        (setq fp *alpha-flag-part*)
  509.        (setq dp *alpha-data-part*)))
  510.     (sendto fp dp 'left left-outs)
  511.     (add-token memory-list fp dp nil)
  512.     (sendto fp dp 'right right-outs))) 
  513.  
  514. (defun &and (outs lpred rpred tests)
  515.   (prog (mem)
  516.     (cond ((eq *side* 'right) (setq mem (memory-part lpred)))
  517.       (t (setq mem (memory-part rpred))))
  518.     (cond ((not mem) (return nil))
  519.       ((eq *side* 'right) (and-right outs mem tests))
  520.       (t (and-left outs mem tests))))) 
  521.  
  522. (defun and-left (outs mem tests)
  523.   (prog (fp dp memdp tlist tst lind rind res)
  524.     (setq fp *flag-part*)
  525.     (setq dp *data-part*)
  526.     fail (and (null mem) (return nil))
  527.     (setq memdp (car mem))
  528.     (setq mem (cdr mem))
  529.     (setq tlist tests)
  530.     tloop (and (null tlist) (go succ))
  531.     (setq tst (car tlist))
  532.     (setq tlist (cdr tlist))
  533.     (setq lind (car tlist))
  534.     (setq tlist (cdr tlist))
  535.     (setq rind (car tlist))
  536.     (setq tlist (cdr tlist))
  537.     ;###        (comment the next line differs in and-left & -right)
  538.     (setq res (funcall tst (gelm memdp rind) (gelm dp lind)))
  539.     (cond (res (go tloop))
  540.       (t (go fail)))
  541.     succ 
  542.     ;###    (comment the next line differs in and-left & -right)
  543.     (sendto fp (cons (car memdp) dp) 'left outs)
  544.     (go fail))) 
  545.  
  546. (defun and-right (outs mem tests)
  547.   (prog (fp dp memdp tlist tst lind rind res)
  548.     (setq fp *flag-part*)
  549.     (setq dp *data-part*)
  550.     fail (and (null mem) (return nil))
  551.     (setq memdp (car mem))
  552.     (setq mem (cdr mem))
  553.     (setq tlist tests)
  554.     tloop (and (null tlist) (go succ))
  555.     (setq tst (car tlist))
  556.     (setq tlist (cdr tlist))
  557.     (setq lind (car tlist))
  558.     (setq tlist (cdr tlist))
  559.     (setq rind (car tlist))
  560.     (setq tlist (cdr tlist))
  561.     ;###        (comment the next line differs in and-left & -right)
  562.     (setq res (funcall tst (gelm dp rind) (gelm memdp lind)))
  563.     (cond (res (go tloop))
  564.       (t (go fail)))
  565.     succ 
  566.     ;###        (comment the next line differs in and-left & -right)
  567.     (sendto fp (cons (car dp) memdp) 'right outs)
  568.     (go fail))) 
  569.  
  570.  
  571. (defun teqb (new eqvar)
  572.   (cond ((eq new eqvar) t)
  573.     ((not (numberp new)) nil)
  574.     ((not (numberp eqvar)) nil)
  575.     ((=alg new eqvar) t)
  576.     (t nil))) 
  577.  
  578. (defun tneb (new eqvar)
  579.   (cond ((eq new eqvar) nil)
  580.     ((not (numberp new)) t)
  581.     ((not (numberp eqvar)) t)
  582.     ((=alg new eqvar) nil)
  583.     (t t))) 
  584.  
  585. (defun tltb (new eqvar)
  586.   (cond ((not (numberp new)) nil)
  587.     ((not (numberp eqvar)) nil)
  588.     ((> eqvar new) t)
  589.     (t nil))) 
  590.  
  591. (defun tgtb (new eqvar)
  592.   (cond ((not (numberp new)) nil)
  593.     ((not (numberp eqvar)) nil)
  594.     ((> new eqvar) t)
  595.     (t nil))) 
  596.  
  597. (defun tgeb (new eqvar)
  598.   (cond ((not (numberp new)) nil)
  599.     ((not (numberp eqvar)) nil)
  600.     ((not (> eqvar new)) t)
  601.     (t nil))) 
  602.  
  603. (defun tleb (new eqvar)
  604.   (cond ((not (numberp new)) nil)
  605.     ((not (numberp eqvar)) nil)
  606.     ((not (> new eqvar)) t)
  607.     (t nil))) 
  608.  
  609. (defun txxb (new eqvar)
  610.   (cond ((numberp new)
  611.      (cond ((numberp eqvar) t)
  612.            (t nil)))
  613.     (t
  614.      (cond ((numberp eqvar) nil)
  615.            (t t))))) 
  616.  
  617.  
  618. (defun &p (rating name var-dope ce-var-dope rhs)
  619.   (declare (ignore var-dope ce-var-dope rhs))
  620.   (prog (fp dp)
  621.     (cond (*sendtocall*
  622.        (setq fp *flag-part*)
  623.        (setq dp *data-part*))
  624.       (t
  625.        (setq fp *alpha-flag-part*)
  626.        (setq dp *alpha-data-part*)))
  627.     (and (member fp '(nil old)) (removecs name dp))
  628.     (and fp (insertcs name dp rating)))) 
  629.  
  630. (defun &old (a b c d e)
  631.   (declare (ignore a b c d e))
  632.   nil) 
  633.  
  634. (defun ¬ (outs lmem rpred tests)
  635.   (cond ((and (eq *side* 'right) (eq *flag-part* 'old)) nil)
  636.     ((eq *side* 'right) (not-right outs (car lmem) tests))
  637.     (t (not-left outs (memory-part rpred) tests lmem)))) 
  638.  
  639. (defun not-left (outs mem tests own-mem)
  640.   (prog (fp dp memdp tlist tst lind rind res c)
  641.     (setq fp *flag-part*)
  642.     (setq dp *data-part*)
  643.     (setq c 0.)
  644.     fail (and (null mem) (go fin))
  645.     (setq memdp (car mem))
  646.     (setq mem (cdr mem))
  647.     (setq tlist tests)
  648.     tloop (and (null tlist) (setq c (1+ c)) (go fail))
  649.     (setq tst (car tlist))
  650.     (setq tlist (cdr tlist))
  651.     (setq lind (car tlist))
  652.     (setq tlist (cdr tlist))
  653.     (setq rind (car tlist))
  654.     (setq tlist (cdr tlist))
  655.     ;###        (comment the next line differs in not-left & -right)
  656.     (setq res (funcall tst (gelm memdp rind) (gelm dp lind)))
  657.     (cond (res (go tloop))
  658.       (t (go fail)))
  659.     fin  (add-token own-mem fp dp c)
  660.     (and (== c 0.) (sendto fp dp 'left outs)))) 
  661.  
  662. (defun not-right (outs mem tests)
  663.   (prog (fp dp memdp tlist tst lind rind res newfp inc newc)
  664.     (setq fp *flag-part*)
  665.     (setq dp *data-part*)
  666.     (cond ((not fp) (setq inc -1.) (setq newfp 'new))
  667.       ((eq fp 'new) (setq inc 1.) (setq newfp nil))
  668.       (t (return nil)))
  669.     fail (and (null mem) (return nil))
  670.     (setq memdp (car mem))
  671.     (setq newc (cadr mem))
  672.     (setq tlist tests)
  673.     tloop (and (null tlist) (go succ))
  674.     (setq tst (car tlist))
  675.     (setq tlist (cdr tlist))
  676.     (setq lind (car tlist))
  677.     (setq tlist (cdr tlist))
  678.     (setq rind (car tlist))
  679.     (setq tlist (cdr tlist))
  680.     ;###        (comment the next line differs in not-left & -right)
  681.     (setq res (funcall tst (gelm dp rind) (gelm memdp lind)))
  682.     (cond (res (go tloop))
  683.       (t (setq mem (cddr mem)) (go fail)))
  684.     succ (setq newc (+ inc newc))        ;"plus" changed to "+" by gdw
  685.     (rplaca (cdr mem) newc)
  686.     (cond ((or (and (== inc -1.) (== newc 0.))
  687.            (and (== inc 1.) (== newc 1.)))
  688.        (sendto newfp memdp 'right outs)))
  689.     (setq mem (cddr mem))
  690.     (go fail))) 
  691.  
  692.  
  693. ;;; Node memories
  694.  
  695.  
  696. (defun add-token (memlis flag data-part num)
  697.   (prog (was-present)
  698.     (cond ((eq flag 'new)
  699.        (setq was-present nil)
  700.        (real-add-token memlis data-part num))
  701.       ((not flag) 
  702.        (setq was-present (remove-old memlis data-part num)))
  703.       ((eq flag 'old) (setq was-present t)))
  704.     (return was-present))) 
  705.  
  706. (defun real-add-token (lis data-part num)
  707.   (setq *current-token* (1+ *current-token*))
  708.   (cond (num (rplaca lis (cons num (car lis)))))
  709.   (rplaca lis (cons data-part (car lis)))) 
  710.  
  711. (defun remove-old (lis data num)
  712.   (cond (num (remove-old-num lis data))
  713.     (t (remove-old-no-num lis data)))) 
  714.  
  715. (defun remove-old-num (lis data)
  716.   (prog (m next last)
  717.     (setq m (car lis))
  718.     (cond ((atom m) (return nil))
  719.       ((top-levels-eq data (car m))
  720.        (setq *current-token* (1- *current-token*))
  721.        (rplaca lis (cddr m))
  722.        (return (car m))))
  723.     (setq next m)
  724.     loop (setq last next)
  725.     (setq next (cddr next))
  726.     (cond ((atom next) (return nil))
  727.       ((top-levels-eq data (car next))
  728.        (rplacd (cdr last) (cddr next))
  729.        (setq *current-token* (1- *current-token*))
  730.        (return (car next)))
  731.       (t (go loop))))) 
  732.  
  733. (defun remove-old-no-num (lis data)
  734.   (prog (m next last)
  735.     (setq m (car lis))
  736.     (cond ((atom m) (return nil))
  737.       ((top-levels-eq data (car m))
  738.        (setq *current-token* (1- *current-token*))
  739.        (rplaca lis (cdr m))
  740.        (return (car m))))
  741.     (setq next m)
  742.     loop (setq last next)
  743.     (setq next (cdr next))
  744.     (cond ((atom next) (return nil))
  745.       ((top-levels-eq data (car next))
  746.        (rplacd last (cdr next))
  747.        (setq *current-token* (1- *current-token*))
  748.        (return (car next)))
  749.       (t (go loop))))) 
  750.