-
Notifications
You must be signed in to change notification settings - Fork 3
/
Copy pathops-backup.lisp
194 lines (162 loc) · 5.97 KB
/
ops-backup.lisp
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
;;; ****************************************************************
;;; 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)
(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)))
#|(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
#|
(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*