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-BACK.LIS < prev    next >
Lisp/Scheme  |  1992-03-06  |  6KB  |  197 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. ;;;; Definitions and functions for backing up.
  20.  
  21. (in-package "OPS")
  22.  
  23.  
  24. ;;; Internal Global Variables
  25.  
  26. (defvar *refracts*)
  27. (defvar *record*)
  28. (defvar *record-array*)
  29. (defvar *recording*)
  30. (defvar *max-record-index*)
  31. (defvar *record-index*)
  32.  
  33.  
  34.  
  35. (defun backup-init ()
  36.   (setq *recording* nil)
  37.   (setq *refracts* nil)
  38.   (setq *record-array* (make-array 256 :initial-element ()))  ;jgk
  39.   (initialize-record))
  40.  
  41.  
  42. (defun back (k)
  43.   (prog (r)
  44.     loop   (and (< k 1.) (return nil))
  45.     (setq r (getvector *record-array* *record-index*))    ; (('))
  46.     (and (null r) (return '|nothing more stored|))
  47.     (putvector *record-array* *record-index* nil)
  48.     (record-index-plus -1.)
  49.     (undo-record r)
  50.     (setq k (1- k))
  51.     (go loop)))
  52.  
  53.  
  54. ; *max-record-index* holds the maximum legal index for record-array
  55. ; so it and the following must be changed at the same time
  56.  
  57. (defun begin-record (p data)
  58.   (setq *recording* t)
  59.   (setq *record* (list '=>refract p data))) 
  60.  
  61. (defun end-record nil
  62.   (cond (*recording*
  63.      (setq *record*
  64.            (cons *cycle-count* (cons *p-name* *record*)))
  65.      (record-index-plus 1.)
  66.      (putvector *record-array* *record-index* *record*)
  67.      (setq *record* nil)
  68.      (setq *recording* nil)))) 
  69.  
  70. (defun record-change (direct time elm)
  71.   (cond (*recording*
  72.      (setq *record*
  73.            (cons direct (cons time (cons elm *record*))))))) 
  74.  
  75. ; to maintain refraction information, need keep only one piece of information:
  76. ; need to record all unsuccessful attempts to delete things from the conflict
  77. ; set.  unsuccessful deletes are caused by attempting to delete refracted
  78. ; instantiations.  when backing up, have to avoid putting things back into the
  79. ; conflict set if they were not deleted when running forward
  80.  
  81. (defun record-refract (rule data)
  82.   (and *recording*
  83.        (setq *record* (cons '<=refract (cons rule (cons data *record*))))))
  84.  
  85. (defun refracted (rule data)
  86.   (prog (z)
  87.     (and (null *refracts*) (return nil))
  88.     (setq z (cons rule data))
  89.     (return (member z *refracts* :test #'equal))))
  90.  
  91.  
  92. (defun record-index-plus (k)
  93.   (setq *record-index* (+ k *record-index*))    ;"plus" changed to "+" by gdw
  94.   (cond ((< *record-index* 0.)
  95.      (setq *record-index* *max-record-index*))
  96.     ((> *record-index* *max-record-index*)
  97.      (setq *record-index* 0.)))) 
  98.  
  99. ; the following routine initializes the record.  putting nil in the
  100. ; first slot indicates that that the record does not go back further
  101. ; than that.  (when the system backs up, it writes nil over the used
  102. ; records so that it will recognize which records it has used.  thus
  103. ; the system is set up anyway never to back over a nil.)
  104.  
  105. (defun initialize-record nil
  106.   (setq *record-index* 0.)
  107.   (setq *recording* nil)
  108.   (setq *max-record-index* 31.)
  109.   (putvector *record-array* 0. nil)) 
  110.  
  111.  
  112. ;; replaced per jcp
  113. ;;; Commented out
  114. #|
  115. (defun undo-record (r)
  116.   (prog (save act a b rate)
  117.     ;###    (comment *recording* must be off during back up)
  118.     (setq save *recording*)
  119.     (setq *refracts* nil)
  120.     (setq *recording* nil)
  121.     (and *ptrace* (back-print (list '|undo:| (car r) (cadr r))))
  122.     (setq r (cddr r))
  123.     top  (and (atom r) (go fin))
  124.     (setq act (car r))
  125.     (setq a (cadr r))
  126.     (setq b (caddr r))
  127.     (setq r (cdddr r))
  128.     (and *wtrace* (back-print (list '|undo:| act a)))
  129.     (cond ((eq act '<=wm) (add-to-wm b a))
  130.       ((eq act '=>wm) (remove-from-wm b))
  131.       ((eq act '<=refract)
  132.        (setq *refracts* (cons (cons a b) *refracts*)))
  133.       ((and (eq act '=>refract) (still-present b))
  134.        (setq *refracts* (delete (cons a b) *refracts*))
  135.        (setq rate (rating-part (get a 'topnode)))
  136.        (removecs a b)
  137.        (insertcs a b rate))
  138.       (t (%warn '|back: cannot undo action| (list act a))))
  139.     (go top)
  140.     fin  (setq *recording* save)
  141.     (setq *refracts* nil)
  142.     (return nil)))
  143. ;;; End commented out
  144. |#
  145.  
  146.  
  147. (defun undo-record (r)
  148.   (prog (save act a b rate)
  149.     ;###    (comment *recording* must be off during back up)
  150.     (setq save *recording*)
  151.     (setq *refracts* nil)
  152.     (setq *recording* nil)
  153.     (and *ptrace* (back-print (list '|undo:| (car r) (cadr r))))
  154.     (setq r (cddr r))
  155.     top  (and (atom r) (go fin))
  156.     (setq act (car r))
  157.     (setq a (cadr r))
  158.     (setq b (caddr r))
  159.     (setq r (cdddr r))
  160.     (and *wtrace* (back-print (list '|undo:| act a)))
  161.     (cond ((eq act '<=wm) (add-to-wm b a))
  162.       ((eq act '=>wm) (remove-from-wm b))
  163.       ((eq act '<=refract)
  164.        (setq *refracts* (cons (cons a b) *refracts*)))
  165.       ((and (eq act '=>refract) (still-present b))
  166.        (setq *refracts* (spdelete (cons a b) *refracts*))
  167.        (setq rate (rating-part (get a 'topnode)))
  168.        (removecs a b)
  169.        (insertcs a b rate))
  170.       (t (%warn '|back: cannot undo action| (list act a))))
  171.     (go top)
  172.     fin  (setq *recording* save)
  173.     (setq *refracts* nil)
  174.     (return nil))) 
  175.  
  176.  
  177.  
  178. ; still-present makes sure that the user has not deleted something
  179. ; from wm which occurs in the instantiation about to be restored; it
  180. ; makes the check by determining whether each wme still has a time tag.
  181.  
  182. (defun still-present (data)
  183.   (prog nil
  184.     loop
  185.     (cond ((atom data) (return t))
  186.       ((creation-time (car data))
  187.        (setq data (cdr data))
  188.        (go loop))
  189.       (t (return nil))))) 
  190.  
  191.  
  192. (defun back-print (x) 
  193.   (prog (port)
  194.     (setq port (trace-file))
  195.     (terpri port)
  196.     (print x port)))
  197.