-
Notifications
You must be signed in to change notification settings - Fork 2
/
Copy pathrun.lisp
215 lines (177 loc) · 7.61 KB
/
run.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
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
;---------------------------------------------
; RUN: This file contains functions for running the program.
;---------------------------------------------
(in-package 'user)
(defun run-ccat ()
; Runs the main loop of the program: choose a codelet, run it. Every
; %time-step-length% time-steps, update everything in the program (all the
; values on the workspace, all the activations in the slipnet, etc.).
; This is the main loop of the program.
(loop until *quit-program* do
; If the program has run for %time-step-length% steps, then
; update everything.
(if* (= (mod *codelet-count* %time-step-length%) 0)
then (update-everything))
; If there are no codelets left in the coderack, then
; clamp the initially clamped nodes and post the
; initial set of codelets.
(if* (send *coderack* :empty?)
then (loop for node in *initially-clamped-slipnodes* do
(send node :set-clamp t))
(post-initial-codelets))
; Step the program.
(step-ccat)
(if* %verbose% then (break))
; If the rule has been translated, then build the answer.
(if* *translated-rule*
then (answer-builder)
(if* *found-answer*
then (update-everything)
(if* %verbose%
then (format t "My answer is ~a.~&"
(send *answer-string* :pstring)))
; Collect some statistics.
(loop for group in (send *workspace* :group-list)
when (= (send group :length) 1) do
(incf *single-letter-group-at-end-count*))
(if* (= (send plato-length :activation) 100)
then (setq *length-relevant-at-end* t))
(setq *quit-program* t)))))
;---------------------------------------------
(defun update-everything (&aux new-structure-list unclamp-probability)
; Updates all the values in the program (workspace values, slipnet
; activations, etc.).
(setq *updating-everything* t)
; Update values for structures and objects.
(send-method-to-list (send *workspace* :structure-list)
:update-strength-values)
(send-method-to-list (send *workspace* :object-list) :update-object-values)
(send *initial-string* :update-relative-importances)
(send *target-string* :update-relative-importances)
(send *initial-string* :update-intra-string-unhappiness)
(send *target-string* :update-intra-string-unhappiness)
; If %initial-slipnode-clamp-time% cycles have gone by, then unclamp
; the initially-clamped slipnodes.
(if* (= *codelet-count*
(* %initial-slipnode-clamp-time% %time-step-length%))
then (loop for node in *initially-clamped-slipnodes*
do (send node :set-clamp nil)))
; If the program is dealing with a snag, then see if any new structures
; have been made. If so, see if snag condition should be ended.
(if* (and *snag-object* *snag-condition*)
then (setq new-structure-list
(loop for structure in (send *workspace* :structure-list)
when (and (not (typep structure 'bond))
(not (send *workspace*
:structure-in-snag-structure-list?
structure)))
collect structure))
(setq unclamp-probability
(if* (null new-structure-list)
then 0
else (/ (list-max (send-method-to-list new-structure-list
:total-strength))
100)))
(if* (eq (flip-coin unclamp-probability) 'heads)
then (setq *snag-condition* nil)
(setq *clamp-temperature* nil)
(loop for d in (send *snag-object* :descriptions) do
(send (send d :descriptor) :set-clamp nil))
(send *snag-object* :set-clamp-salience? nil)))
(if* (> *codelet-count* 0)
then (update-temperature)
(get-bottom-up-codelets)
(get-top-down-codelets)
(update-slipnet))
(if* *codelets-to-post*
then (send *coderack* :post-codelet-list *codelets-to-post*))
(setq *codelets-to-post* nil)
(if* (> *codelet-count* 0)
then (if* %description-graphics% then (display-descriptions))
(if* %temperature-graphics% then (update-temperature-display))
(if* %coderack-graphics% then (update-coderack-display))
(if* %minimal-coderack-graphics%
then (update-minimal-coderack-display))
(if* %slipnet-graphics% then (update-slipnet-display))
; Update concept-mapping and length displays.
(if* %workspace-graphics%
then (loop for c in (send *workspace* :correspondence-list) do
(send c :erase-concept-mappings)
(send c :draw-concept-mappings))
(loop for group
in (send *workspace* :group-list) do
(if* (send (send group :graphics-obj) :graphics-length)
then (send group :erase-length)
(send group :draw-length)))
(if* (= (mod *codelet-count* 100) 0) then (redraw-graphics))))
(setq *updating-everything* nil))
;---------------------------------------------
(defun step-ccat (&aux codelet)
; Runs one step of the program: chooses and runs a codelet from the
; coderack.
(setq codelet (send *coderack* :choose))
(if* %slightly-verbose% then (send codelet :print))
(send codelet :run)
(setq *codelet-count* (1+ *codelet-count*))
(if* %verbose% then (format t "~%"))
(if* *break-on-each-step*
then (if* %minimal-coderack-graphics%
then (update-minimal-coderack-display))
(break)))
;---------------------------------------------
(defun deal-with-snag ()
; If there is a snag in building the answer, then delete all
; proposed structures, empty the coderack, raise and clamp the
; temperature, and activate and clamp the activation of all the descriptions
; of the object causing the snag.
(incf *snag-count*)
(setq *last-snag-time* *codelet-count*)
; Save the current set of structures.
(setq *snag-structure-list* (send *workspace* :structure-list))
; Erase proposed structures. (Their builder codelets will
; disappear when the coderack is initialized.)
(if* %workspace-graphics%
then (loop for b in (send *workspace* :proposed-bond-list)
do (send (send b :string)
:delete-proposed-bond b)
(if* (not (send (send b :string)
:bond-present? b))
then (send b :erase-spline)))
(loop for g in (send *workspace* :proposed-group-list)
do (send (send g :string)
:delete-proposed-group g)
(if* (not (send (send g :string)
:group-present? g))
then (send g :erase-rectangle)))
(loop for c in (send *workspace*
:proposed-correspondence-list)
do (send *workspace*
:delete-proposed-correspondence c)
(if* (not (send *workspace*
:correspondence-present? c))
then (send c :erase-line))))
(send *coderack* :empty)
(if* %coderack-graphics% then (update-coderack-display))
(if* (and %workspace-graphics% *translated-rule*)
then (send *translated-rule* :erase %translated-rule-mode%))
(setq *translated-rule* nil)
(setq *answer-string* nil)
(setq *snag-condition* t)
(setq *temperature* 100)
(setq *clamp-temperature* t)
(loop for d in (send *snag-object* :descriptions) do
(send (send d :descriptor) :set-clamp t))
(send *snag-object* :set-clamp-salience? t)
(send *coderack* :empty)
(post-initial-codelets)
(update-everything))
;---------------------------------------------
(defun unanswer ()
; Deletes the answer so that the program can continue running.
(setq *translated-rule* nil
*answer-string* nil
*found-answer* nil
*quit-program* nil)
(display-ccat)
(run-ccat))
;---------------------------------------------