;;; ****************************************************************
 ;;; OPS5 Interpreter ***********************************************
 ;;; ****************************************************************
 ;;; This Common Lisp version of OPS5 is in the public domain.  It is based
 ;;; in part on based on a Franz Lisp implementation done by Charles L. Forgy
 ;;; at Carnegie-Mellon University, which was placed in the public domain by
 ;;; the author in accordance with CMU policies.  Ported to Common Lisp by 
 ;;; George Wood and Jim Kowalski. CMU Common Lisp modifications by
 ;;; Dario Guise, Skef Wholey, Michael Parzen, and Dan Kuokka. 
 ;;; Modified to work in CLtL1, CLtL2 and X3J13 compatible lisps by 
 ;;; Mark Kantrowitz on 14-OCT-92.
 ;;; 
 ;;; This code is made available is, and without warranty of any kind by the
 ;;; authors or by Carnegie-Mellon University.
 ;;;
 
 ;;;; This file contains all the functions necessary for RHS actions
 ;;;; including $actions.
 
 (in-package "OPS")
 ;; see ops.lisp

                                         ;; (shadow '(remove write))
                                         ;; (export '(remove write make modify crlf))

 
 ;;; External global variables
 

 (defvar *size-result-array* nil)
 (defvar *in-rhs* nil)
 (defvar *current-wm* nil)
 (defvar *max-wm* nil)
 (defvar *action-count* nil)
 (defvar *critical* nil)

 
 
 ;;; Internal global variables
 

 (defvar *wmpart-list* nil)
 (defvar *wm-filter* nil)
 (defvar *wm* nil)
 (defvar *old-wm* nil)
 (defvar *result-array* nil)
 (defvar *variable-memory* nil)
 (defvar *last* nil)
 (defvar *max-index* nil)
 (defvar *next-index* nil)
 (defvar *data-matched* nil)
 (defvar *ce-variable-memory* nil)
 (defvar *rest* nil)
 (defvar *build-trace* nil)

 
 
 ;;;; Functions for RHS evaluation
 
 (defun rhs-init ()
   ;; if the size of result-array changes, change the line in i-g-v which
   ;; sets the value of *size-result-array*
   (setq *size-result-array* 255.)	;255 /256 set by gdw
   (setq *result-array* (make-array 256 :initial-element nil)) ;jgk
   (setq *in-rhs* nil)
   (setq *build-trace* nil)
   (setq *max-wm* (setq *current-wm* 0.))
   (setq *action-count* 0.)
   (setq *critical* nil)
   (setq *wmpart-list* nil))
 
 
 (defun eval-rhs (pname data)
   (when *ptrace*
     (let ((port (trace-file)))
       (format port "~&~A. ~A" 

               *cycle-count* pname)

       (time-tag-print data port)))
   (let ((node (gethash pname *topnode-table*)))
     (setq *data-matched* data

           *p-name* pname
           *last* nil)

     (init-var-mem (var-part node))
     (init-ce-var-mem (ce-var-part node))
     (begin-record pname data)
     (let ((*in-rhs* t))
       (eval (rhs-part node)))
     (end-record))) 
 
 (defun eval-args (z)
   (prog (r)

      (rhs-tab 1.)
    la   (and (atom z) (return nil))
      (setq r (pop z))
      (when (eq r '^)
        (rhs-tab (car z))
        (setq r (cadr z))
        (setq z (cddr z)))
      (cond ((eq r '//)
             ($value (car z))
             (setq z (cdr z)))
            (t ($change r)))
      (go la))) 

 
 ;;;; RHS actions
 ;;;; Some of these can be called at the top level.
 
 (defmacro make (&body z)
   `(ops-make ',z))
 
 (defmacro remove (&body z)
   `(ops-remove ',z))
 
 (defmacro modify (&body z)
   `(ops-modify ',z))
 
 (defmacro openfile (&body z)
   `(ops-openfile ',z))
 
 (defmacro closefile (&body z)
   `(ops-closefile ',z))
 
 (defmacro default (&body z)
   `(ops-default ',z))
 
 (defmacro write (&body z)
   `(ops-write ',z))
 
 (defmacro crlf (&body z)
   `(ops-crlf ',z))
 
 (defmacro tabto (&body z)
   `(ops-tabto ',z))
 
 (defmacro rjust (&body z)
   `(ops-rjust ',z))
 
 (defmacro call (&body z)
   `(ops-call ',z))
 
 (defmacro bind (&body z)
   `(ops-bind ',z))
 
 (defmacro cbind (&body z)
   `(ops-cbind ',z))
 
 (defmacro build (&body z)
   `(ops-build ',z))
 
 (defmacro substr (&body l)
   `(ops-substr ',l))
 
 (defmacro compute (&body z)
   `(ops-compute ',z))
 
 (defmacro litval (&body z)
   `(ops-litval ',z))
 
 (defmacro accept (&body z)
   `(ops-accept ',z))
 
 (defmacro acceptline (&body z)
   `(ops-acceptline ',z))
 
 (defmacro arith (&body z)
   `(ops-arith ',z))
 
 
 (defun ops-make (z)
   ($reset)
   (eval-args z)
   ($assert)) 
 
 (defun ops-remove (z)
   (prog (old)

      (when (not *in-rhs*)
        (return (top-level-remove z)))
    top  (and (atom z) (return nil))
      (setq old (get-ce-var-bind (car z)))
      (when (null old)
        (%warn '|remove: argument not an element variable| (car z))
        (return nil))
      (remove-from-wm old)
      (setq z (cdr z))
      (go top))) 

 
 (defun ops-modify (z)
   (prog (old)

      (cond ((not *in-rhs*)
             (%warn '|cannot be called at top level| 'modify)
             (return nil)))
      (setq old (get-ce-var-bind (car z)))
      (cond ((null old)
             (%warn '|modify: first argument must be an element variable|
                    (car z))
             (return nil)))
      (remove-from-wm old)
      (setq z (cdr z))
      ($reset)
    copy (and (atom old) (go fin))
      ($change (car old))
      (setq old (cdr old))
      (go copy)
    fin  (eval-args z)
      ($assert))) 

 
 (defun ops-bind (z)
   (prog (val)

      (cond ((not *in-rhs*)
             (%warn '|cannot be called at top level| 'bind)
             (return nil)))
      (cond ((< (length z) 1.)
             (%warn '|bind: wrong number of arguments to| z)
             (return nil))
            ((not (symbolp (car z)))
             (%warn '|bind: illegal argument| (car z))
             (return nil))
            ((= (length z) 1.) (setq val (gensym)))
            (t ($reset)
               (eval-args (cdr z))
               (setq val ($parameter 1.))))
      (make-var-bind (car z) val))) 

 
 (defun ops-cbind (z)
   (cond ((not *in-rhs*)

          (%warn '|cannot be called at top level| 'cbind))
         ((not (= (length z) 1.))
          (%warn '|cbind: wrong number of arguments| z))
         ((not (symbolp (car z)))
          (%warn '|cbind: illegal argument| (car z)))
         ((null *last*)
          (%warn '|cbind: nothing added yet| (car z)))
         (t (make-ce-var-bind (car z) *last*)))) 

 
 
 (defun ops-call (z)
   (let ((f (car z)))
     ($reset)
     (eval-args (cdr z))
     (funcall f))) 
 
 
 (defun halt () 
   (cond ((not *in-rhs*)

          (%warn '|cannot be called at top level| 'halt))
         (t (setq *halt-flag* t)))) 

 
 (defun ops-build (z)
   (prog (r)

      (cond ((not *in-rhs*)
             (%warn '|cannot be called at top level| 'build)
             (return nil)))
      ($reset)
      (build-collect z)
      (setq r (unflat (use-result-array)))
      (and *build-trace* (funcall *build-trace* r))
      (compile-production (car r) (cdr r)))) 

 
 (defun ops-compute (z) ($value (ari z))) 
 

                                         ;; arith is the obsolete form of compute

 (defun ops-arith (z) ($value (ari z))) 
 
 ;;; Should change the division in this function to use / instead of floor
 (defun ari (x)
   (cond ((atom x)

          (%warn '|bad syntax in arithmetic expression | x)
          0.)
         ((atom (cdr x)) (ari-unit (car x)))
         ((eq (cadr x) '+)
          (+ (ari-unit (car x)) (ari (cddr x))))
         ;;"plus" changed to "+" by gdw
         ((eq (cadr x) '-)
          (- (ari-unit (car x)) (ari (cddr x))))
         ((eq (cadr x) '*)
          (* (ari-unit (car x)) (ari (cddr x))))
         ((eq (cadr x) '//)
          ;; was (floor (ari-unit (car x)) (ari (cddr x))) ;@@@ quotient? /
          ;; but changed to / by mk 10-15-92
          (/ (ari-unit (car x)) (ari (cddr x))))
         ((eq (cadr x) 'quotient)
          ;; for backward compatability
          (floor (ari-unit (car x)) (ari (cddr x))))
         ;;@@@ kluge only works for integers
         ;;@@@ changed to floor by jcp (from round)
         ((eq (cadr x) '\\)
          (mod (floor (ari-unit (car x))) (floor (ari (cddr x)))))
         (t (%warn '|bad syntax in arithmetic expression | x) 0.))) 

 
 (defun ari-unit (a)
   (prog (r)

      (cond ((consp  a) (setq r (ari a)))	;dtpr\consp gdw
            (t (setq r ($varbind a))))
      (cond ((not (numberp r))
             (%warn '|bad value in arithmetic expression| a)
             (return 0.))
            (t (return r))))) 

 
 (defun ops-substr (l)
   (prog (k elm start end)

      (cond ((not (= (length l) 3.))
             (%warn '|substr: wrong number of arguments| l)
             (return nil)))
      (setq elm (get-ce-var-bind (car l)))
      (cond ((null elm)
             (%warn '|first argument to substr must be a ce var|
                    l)
             (return nil)))
      (setq start ($varbind (cadr l)))
      (setq start ($litbind start))
      (cond ((not (numberp start))
             (%warn '|second argument to substr must be a number|
                    l)
             (return nil)))
      ;;###	(comment |if a variable is bound to INF, the following|
      ;;	 |will get the binding and treat it as INF is|
      ;;	 |always treated.  that may not be good|)
      (setq end ($varbind (caddr l)))
      (cond ((eq end 'inf) (setq end (length elm))))
      (setq end ($litbind end))
      (cond ((not (numberp end))
             (%warn '|third argument to substr must be a number|
                    l)
             (return nil)))
      ;;###	(comment |this loop does not check for the end of elm|
      ;;         |instead it relies on cdr of nil being nil|
      ;;         |this may not work in all versions of lisp|)
      (setq k 1.)
    la   (cond ((> k end) (return nil))
               ((not (< k start)) ($value (car elm))))
      (setq elm (cdr elm))
      (setq k (1+ k))
      (go la))) 

 
 (defun genatom nil ($value (gensym))) 
 
 (defun ops-litval (z)
   (prog (r)

      (cond ((not (= (length z) 1.))
             (%warn '|litval: wrong number of arguments| z)
             ($value 0) 
             (return nil))
            ((numberp (car z)) ($value (car z)) (return nil)))
      (setq r ($litbind ($varbind (car z))))
      (cond ((numberp r) ($value r) (return nil)))
      (%warn '|litval: argument has no literal binding| (car z))
      ($value 0)))
 
 
 
 ;; rhs-tab implements the tab ('^') function in the rhs.  it has
 ;; four responsibilities:
 ;;	- to move the array pointers
 ;;	- to watch for tabbing off the left end of the array
 ;;	  (ie, to watch for pointers less than 1)
 ;;	- to watch for tabbing off the right end of the array
 ;;	- to write nil in all the slots that are skipped
 ;; the last is necessary if the result array is not to be cleared
 ;; after each use; if rhs-tab did not do this, $reset
 ;; would be much slower.

 
 (defun rhs-tab (z) ($tab ($varbind z)))
 
 
 (defun time-tag-print (data port)
   (when (not (null data))
     (time-tag-print (cdr data) port)
     (princ '| | port)
     (princ (creation-time (car data)) port)))
 
 (defun init-var-mem (vlist)
   (prog (v ind r)

      (setq *variable-memory* nil)
    top  (and (atom vlist) (return nil))
      (setq v (car vlist))
      (setq ind (cadr vlist))
      (setq vlist (cddr vlist))
      (setq r (gelm *data-matched* ind))
      (setq *variable-memory* (cons (cons v r) *variable-memory*))
      (go top))) 

 
 (defun init-ce-var-mem (vlist)
   (prog (v ind r)

      (setq *ce-variable-memory* nil)
    top  (and (atom vlist) (return nil))
      (setq v (car vlist))
      (setq ind (cadr vlist))
      (setq vlist (cddr vlist))
      (setq r (nth (1- ind) *data-matched*)) ; was ce-gelm
      (setq *ce-variable-memory*
            (cons (cons v r) *ce-variable-memory*))
      (go top))) 

 
 (defun make-ce-var-bind (var elem)
   (push (cons var elem)

         *ce-variable-memory*)) 

 
 (defun make-var-bind (var elem)
   (push (cons var elem) 

         *variable-memory*)) 

 
 (defun get-ce-var-bind (x)
   (if (numberp x)
       (get-num-ce x)
       (let ((r (assoc x *ce-variable-memory*)))

         (when r 
           (cdr r))))) 

 
 (defun get-num-ce (x)
   (prog (r l d)

      (setq r *data-matched*)
      (setq l (length r))
      (setq d (- l x))
      (and (> 0. d) (return nil))
    la   (cond ((null r) (return nil))
               ((> 1. d) (return (car r))))
      (setq d (1- d))
      (setq r (cdr r))
      (go la))) 

 
 (defun build-collect (z)
   (prog (r)

    la   (and (atom z) (return nil))
      (setq r (car z))
      (setq z (cdr z))
      (cond ((consp  r)	;dtpr\consp gdw
             ($value '\()
             (build-collect r)
             ($value '\)))
            ((eq r '\\) ($change (car z)) (setq z (cdr z)))
            (t ($value r)))
      (go la))) 

 
 (defun unflat (x)
   (setq *rest* x)
   (unflat*)) 
 
 (defun unflat* ()
   (if (atom *rest*)
       nil
       (let ((c (pop *rest*)))

         (cond ((eq c '\() (cons (unflat*) (unflat*)))
               ((eq c '\)) nil)
               (t (cons c (unflat*))))))) 

 
 ;;;; $Functions.
 ;;;; These functions provide an interface to the result array.
 ;;;; The result array is used to organize attribute values into their
 ;;;; correct slot.
 
 (defun $litbind (x)
   (if (symbolp x)
       (or (literal-binding-of x)

           x)

       x)) 
 
 (defun $varbind (x)
   (if *in-rhs*
       ;; If we're in the RHS, lookup the binding. 
       (let ((binding (assoc x *variable-memory*)))

         (if binding
             (cdr binding)
             x))

       ;; Otherwise just return it unevaluated.
       x))
 
 (defun $change (x)
   (if (consp  x)			;dtpr\consp gdw
       (eval-function x)	
       ($value ($varbind x)))) 
 
 (defun $reset nil
   (setq *max-index* 0.)
   (setq *next-index* 1.)) 
 
 (defun $tab (z)
   (prog (edge next)

      (setq next ($litbind z))
      (when (floatp next)
        (setq next (floor next)))
      (when (or (not (numberp next)) 
                (> next *size-result-array*)
                (> 1. next))		; ( '| |)
        (%warn '|illegal index after ^| next)
        (return *next-index*))
      (setq edge (- next 1.))
      (cond ((> *max-index* edge) (go ok)))
    clear (when (== *max-index* edge) (go ok))
      (setf (aref *result-array* edge) nil)
      (decf edge)
      (go clear)
    ok   (setq *next-index* next)
      (return next))) 

 
 (defun $value (v)
   (cond ((> *next-index* *size-result-array*)

          (%warn '|index too large| *next-index*))
         (t
          (and (> *next-index* *max-index*)
               (setq *max-index* *next-index*))
          (setf (aref *result-array* *next-index*) v)
          (incf *next-index*)))) 

 
 (defun $assert nil
   (setq *last* (use-result-array))
   (add-to-wm *last* nil))
 
 (defun $parametercount ()
   *max-index*)
 
 (defun $parameter (k)
   (cond ((or (not (numberp k)) (> k *size-result-array*) (< k 1.))

          (%warn '|illegal parameter number | k)
          nil)
         ((> k *max-index*) nil)
         (t (aref *result-array* k))))

 
 (defun $ifile (x) 
   (when (symbolp x)
     (gethash x *inputfile-table*)))
 
 (defun $ofile (x) 
   (when (symbolp x) 
     (gethash x *outputfile-table*)))
 
 ;;; 
 
 (defun use-result-array ()
   "Use-result-array returns the contents of the result array as a list."
   ;; is *max-index* acting like a fill-pointer? Then we can't just use
   ;; coerce, unless we change *result-array* to use a fill pointer.
   ;; Also, note that index 0 of the array is ignored.
   (prog (k r)

      (setq k *max-index*)
      (setq r nil)
    top  (and (== k 0.) (return r))
      (setq r (cons (aref *result-array* k) r))
      (decf k)
      (go top))) 

 
 (defun eval-function (form)
   (if (not *in-rhs*)
       (%warn '|functions cannot be used at top level| (car form))
       (eval form)))
 
 ;;;; WM maintaining functions
 
 ;;; The order of operations in the following two functions is critical.
 ;;; add-to-wm order: (1) change wm (2) record change (3) match 
 ;;; remove-from-wm order: (1) record change (2) match (3) change wm
 ;;; (back will not restore state properly unless wm changes are recorded
 ;;; before the cs changes that they cause)  (match will give errors if 
 ;;; the thing matched is not in wm at the time)
 
 (defun add-to-wm (wme override)
   (prog (fa z part timetag port)

      (setq *critical* t)
      (setq *current-wm* (1+ *current-wm*))
      (and (> *current-wm* *max-wm*) (setq *max-wm* *current-wm*))
      (setq *action-count* (1+ *action-count*))
      (setq fa (wm-hash wme))
      (or (member fa *wmpart-list*)
          (setq *wmpart-list* (cons fa *wmpart-list*)))
      (setq part (gethash fa *wmpart*-table*))
      (cond (override (setq timetag override))
            (t (setq timetag *action-count*)))
      (setq z (cons wme timetag))
      (setf (gethash fa *wmpart*-table*) (cons z part))
      (record-change '=>wm *action-count* wme)
      (match 'new wme)
      (setq *critical* nil)
      (cond ((and *in-rhs* *wtrace*)
             (setq port (trace-file))
             (terpri port)
             (princ '|=>wm: | port)
             (ppelm wme port))))) 

 
 ;;; remove-from-wm uses eq, not equal to determine if wme is present
 
 (defun remove-from-wm (wme)
   (prog (fa z part timetag port)

      (setq fa (wm-hash wme))
      (setq part (gethash fa *wmpart*-table*))
      (setq z (assoc wme part))
      (or z (return nil))
      (setq timetag (cdr z))
      (cond ((and *wtrace* *in-rhs*)
             (setq port (trace-file))
             (terpri port)
             (princ '|<=wm: | port)
             (ppelm wme port)))
      (setq *action-count* (1+ *action-count*))
      (setq *critical* t)
      (setq *current-wm* (1- *current-wm*))
      (record-change '<=wm timetag wme)
      (match nil wme)
      (setf (gethash fa *wmpart*-table*) (delete z part :test #'eq))
      (setq *critical* nil))) 

 
 ;;; mapwm maps down the elements of wm, applying fn to each element
 ;;; each element is of form (datum . creation-time)
 
 (defun mapwm (fn)
   (dolist (wmpl *wmpart-list*)
     (mapc fn (gethash wmpl *wmpart*-table*)))

   #+(or)
   (prog (wmpl part)
      (setq wmpl *wmpart-list*)
    lab1 (cond ((atom wmpl) (return nil)))
      (setq part (gethash (car wmpl) *wmpart*-table*))
      (setq wmpl (cdr wmpl))
      (mapc fn part)
      (go lab1))) 

 
 (defun ops-wm (a) 
   (mapc #'(lambda (z) (terpri) (ppelm z *standard-output*)) 

         (get-wm a))

   nil) 
 
 (defun creation-time (wme)
   (cdr (assoc wme (gethash (wm-hash wme) *wmpart*-table*)))) 
 
 (defun get-wm (z)
   (setq *wm-filter* z)
   (setq *wm* nil)
   (mapwm #'(lambda (elem) 

              (when (or (null *wm-filter*)
                        (member (cdr elem) *wm-filter*)) ;test #'equal
                (push (car elem) *wm*))))

   (prog2 nil *wm* (setq *wm* nil))) 
 
 (defun wm-hash (x)
   (cond ((not x) '<default>)

         ((not (car x)) (wm-hash (cdr x)))
         ((symbolp (car x)) (car x))
         (t (wm-hash (cdr x))))) 

 
 (defun refresh ()
   (setq *old-wm* nil)
   (mapwm #'refresh-collect)
   (mapc #'refresh-del *old-wm*)
   (mapc #'refresh-add *old-wm*)
   (setq *old-wm* nil)) 
 
 (defun refresh-collect (x)
   (push x *old-wm*)) 
 
 (defun refresh-del (x) (remove-from-wm (car x))) 
 
 (defun refresh-add (x) (add-to-wm (car x) (cdr x))) 
 
 ;;; *EOF*