;;; ****************************************************************
 ;;; 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.
 ;;;
 
 ;;;; Definitions and functions for backing up.
 
 (in-package "OPS")
 
 
 ;;; Internal Global Variables
 

 (defvar *refracts* nil)
 (defvar *record* nil)
 (defvar *record-array* nil)
 (defvar *recording* nil)
 (defvar *max-record-index* nil)
 (defvar *record-index* nil)

 
 
 
 (defun backup-init ()
   (setq *recording* nil)
   (setq *refracts* nil)
   (setq *record-array* (make-array 256 :initial-element ()))  ;jgk
   (initialize-record))
 
 
 (defun back (k)
   (dotimes (i k)
     (declare (ignore i))
     (let ((r (aref *record-array* *record-index*))) ; (('))
       (when (null r) (return '|nothing more stored|))
       (setf (aref *record-array* *record-index*) nil)
       (record-index-plus -1.)
       (undo-record r))))
 
 

 ;; *max-record-index* holds the maximum legal index for record-array
 ;; so it and the following must be changed at the same time

 
 (defun begin-record (p data)
   (setq *recording* t)
   (setq *record* (list '=>refract p data))) 
 
 (defun end-record ()
   (when *recording*
     (setq *record*

           (cons *cycle-count* (cons *p-name* *record*)))

     (record-index-plus 1.)
     (setf (aref *record-array* *record-index*) *record*)
     (setq *record* nil)
     (setq *recording* nil))) 
 
 (defun record-change (direct time elm)
   (when *recording*
     (setq *record*

           (cons direct (cons time (cons elm *record*)))))) 

 ;; to maintain refraction information, need keep only one piece of information:
 ;; need to record all unsuccessful attempts to delete things from the conflict
 ;; set.  unsuccessful deletes are caused by attempting to delete refracted
 ;; instantiations.  when backing up, have to avoid putting things back into the
 ;; conflict set if they were not deleted when running forward

 
 (defun record-refract (rule data)
   (when *recording*
     (setq *record* (cons '<=refract (cons rule (cons data *record*))))))
 
 (defun refracted (rule data)
   (when *refracts*
     (let ((z (cons rule data)))
       (member z *refracts* :test #'equal)))

   #+(or)
   (prog (z)
      (and (null *refracts*) (return nil))
      (setq z (cons rule data))
      (return (member z *refracts* :test #'equal))))

 
 
 (defun record-index-plus (k)
   (incf *record-index* k)
   (cond ((< *record-index* 0.)

          (setq *record-index* *max-record-index*))
         ((> *record-index* *max-record-index*)
          (setq *record-index* 0.))))

 ;; the following routine initializes the record.  putting nil in the
 ;; first slot indicates that that the record does not go back further
 ;; than that.  (when the system backs up, it writes nil over the used
 ;; records so that it will recognize which records it has used.  thus
 ;; the system is set up anyway never to back over a nil.)

 
 (defun initialize-record nil
   (setq *record-index* 0.)
   (setq *recording* nil)
   (setq *max-record-index* 31.)
   (setf (aref *record-array* 0.) nil)) 
 
 
 ;; replaced per jcp
 ;;; Commented out

 #+(or)

 (defun undo-record (r)
   (prog (save act a b rate)

      ;;###	(comment *recording* must be off during back up) ;
      (setq save *recording*)
      (setq *refracts* nil)
      (setq *recording* nil)
      (and *ptrace* (back-print (list '|undo:| (car r) (cadr r))))
      (setq r (cddr r))
    top  (and (atom r) (go fin))
      (setq act (car r))
      (setq a (cadr r))
      (setq b (caddr r))
      (setq r (cdddr r))
      (and *wtrace* (back-print (list '|undo:| act a)))
      (cond ((eq act '<=wm) (add-to-wm b a))
            ((eq act '=>wm) (remove-from-wm b))
            ((eq act '<=refract)
             (setq *refracts* (cons (cons a b) *refracts*)))
            ((and (eq act '=>refract) (still-present b))
             (setq *refracts* (delete (cons a b) *refracts*))
             (setq rate (rating-part (gethash a *topnode-table*)))
             (removecs a b)
             (insertcs a b rate))
            (t (%warn '|back: cannot undo action| (list act a))))
      (go top)
    fin  (setq *recording* save)
      (setq *refracts* nil)
      (return nil)))

 ;;; End commented out
 
 
 (defun undo-record (r)
   (prog (save act a b rate)

      ;;###	(comment *recording* must be off during back up)
      (setq save *recording*)
      (setq *refracts* nil)
      (setq *recording* nil)
      (and *ptrace* (back-print (list '|undo:| (car r) (cadr r))))
      (setq r (cddr r))
    top  (and (atom r) (go fin))
      (setq act (car r))
      (setq a (cadr r))
      (setq b (caddr r))
      (setq r (cdddr r))
      (and *wtrace* (back-print (list '|undo:| act a)))
      (cond ((eq act '<=wm) (add-to-wm b a))
            ((eq act '=>wm) (remove-from-wm b))
            ((eq act '<=refract)
             (setq *refracts* (cons (cons a b) *refracts*)))
            ((and (eq act '=>refract) (still-present b))
             (setq *refracts* (tree-remove (cons a b) *refracts*))
             (setq rate (rating-part (gethash a *topnode-table*)))
             (removecs a b)
             (insertcs a b rate))
            (t (%warn '|back: cannot undo action| (list act a))))
      (go top)
    fin  (setq *recording* save)
      (setq *refracts* nil)
      (return nil))) 
 
 
 
 ;; still-present makes sure that the user has not deleted something
 ;; from wm which occurs in the instantiation about to be restored; it
 ;; makes the check by determining whether each wme still has a time tag.

 
 (defun still-present (data)
   (prog nil

    loop
      (cond ((atom data) (return t))
            ((creation-time (car data))
             (setq data (cdr data))
             (go loop))
            (t (return nil))))) 

 
 (defun back-print (x) 
   (let ((stream (trace-file)))
     (format stream "~&~S" x)))
 
 ;;; *EOF*