Parse widgets v1 - slider
[clnl] / src / main / nvm / nvm.lisp
1 (in-package #:clnl-nvm)
2
3 ; Implementations of all the things the nvm can do.
4
5 (defun show (value)
6  "SHOW VALUE => RESULT
7
8 ARGUMENTS AND VALUES:
9
10   VALUE: a NetLogo value
11   RESULT: undefined
12
13 DESCRIPTION:
14
15   A command that prints the given NetLogo value to the command center.
16
17   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#show"
18  (format t "Showing: ~A~%" (dump-object value)))
19
20 (defun create-turtle ()
21  (setf
22   *turtles*
23   (nconc
24    *turtles*
25    (list
26     (make-turtle
27      :who *current-id*
28      :color (coerce (+ 5 (* 10 (clnl-random:next-int 14))) 'double-float)
29      :heading (coerce (clnl-random:next-int 360) 'double-float)
30      :xcor 0d0
31      :ycor 0d0))))
32  (incf *current-id*))
33
34 (defun turtles ()
35  "TURTLES => ALL-TURTLES
36
37 ARGUMENTS AND VALUES:
38
39   ALL-TURTLES: a NetLogo agentset, all turtles
40
41 DESCRIPTION:
42
43   Reports the agentset consisting of all the turtles.
44
45   This agentset is special in that it represents the living turtles
46   each time it's used, so changes depending on the state of the engine.
47
48   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#turtles"
49  *turtles*)
50
51 (defun ask (agent-set fn)
52  "ASK AGENT-SET FN => RESULT
53
54 ARGUMENTS AND VALUES:
55
56   AGENT-SET: a NetLogo agentset
57   FN: a function, run on each agent
58   RESULT: undefined, commands don't return
59
60 DESCRIPTION:
61
62   ASK is equivalent to ask in NetLogo.
63
64   The specified AGENT-SET runs the given FN.  The order in which the agents
65   are run is random each time, and only agents that are in the set at the
66   beginning of the call.
67
68   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#ask"
69  (let
70   ((iter (shufflerator agent-set)))
71   (loop
72    :for agent := (funcall iter)
73    :while agent
74    :do (let ((*myself* *self*) (*self* agent)) (funcall fn)))))
75
76 (defun shufflerator (agent-set)
77  (let
78   ((copy (copy-list agent-set))
79    (i 0)
80    (agent nil))
81   (flet
82    ((fetch ()
83      (let
84       ((idx (when (< i (1- (length copy))) (+ i (clnl-random:next-int (- (length copy) i))))))
85       (when idx (setf agent (nth idx copy)))
86       (when idx (setf (nth idx copy) (nth i copy)))
87       (incf i))))
88    (fetch) ; we pre-fetch because netlogo does, rng sync hype!
89    (lambda ()
90     (cond
91      ((> i (length copy)) nil)
92      ((= i (length copy)) (incf i) (car (last copy)))
93      (t (let ((result agent)) (fetch) result)))))))
94
95 (defun random-float (n)
96  "RANDOM-FLOAT N => RANDOM-NUMBER
97
98 ARGUMENTS AND VALUES:
99
100   N: a double, the upper bound of the random float
101   RANDOM-NUMBER: a double, the random result
102
103 DESCRIPTION:
104
105   Returns a random number strictly closer to zero than N.
106
107   If number is positive, returns a random floating point number greater than
108   or equal to 0 but strictly less than number.
109
110   If number is negative, returns a random floating point number less than or equal
111   to 0, but strictly greater than number.
112
113   If number is zero, the result is always 0.
114
115   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#random-float"
116  (clnl-random:next-double n))
117
118 (defun jump (n)
119  (when (not (turtle-p *self*)) (error "Gotta call fd in turtle scope, dude (~A)" *self*))
120  (setf
121   (turtle-xcor *self*)
122   (wrap-x *topology*
123    (+ (turtle-xcor *self*) (* n (strictmath:sin (strictmath:to-radians (turtle-heading *self*)))))))
124  (setf
125   (turtle-ycor *self*)
126   (wrap-y *topology*
127    (+ (turtle-ycor *self*) (* n (strictmath:cos (strictmath:to-radians (turtle-heading *self*))))))))
128
129 (defun forward (n)
130  "FORWARD N => RESULT
131
132 ARGUMENTS AND VALUES:
133
134   N: a double, the amount the turtle moves forward
135   RESULT: undefined
136
137 DESCRIPTION:
138
139   Moves the current turtle forward N steps, one step at a time.
140
141   This moves forward one at a time in order to make the view updates look
142   good in the case of a purposefully slow running instance.  If the number
143   is negative, the turtle moves backward.
144
145   If the current agent is not a turtle, it raises an error.
146
147   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#forward"
148  (when (not (turtle-p *self*)) (error "Gotta call fd in turtle scope, dude (~A)" *self*))
149  (labels
150   ((internal (i)
151     (cond
152      ((< (abs i) 3.2e-15) nil)
153      ((< (abs i) 1d0) (jump i))
154      (t (jump (if (> i 0d0) 1d0 -1d0)) (internal (- i (if (> i 0d0) 1d0 -1d0)))))))
155   (internal n)))
156
157 (defun create-turtles (n)
158  "CREATE-TURTLES N => RESULT
159
160 ARGUMENTS AND VALUES:
161
162   N: an integer, the numbers of turtles to create
163   RESULT: undefined
164
165 DESCRIPTION:
166
167   Creates number new turtles at the origin.
168
169   New turtles have random integer headings and the color is randomly selected
170   from the 14 primary colors.  If commands are supplied, the new turtles
171   immediately run them (unimplemented).
172
173   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#create-turtles"
174  (loop :for i :from 1 :to n :do (create-turtle)))
175
176 (defun create-world (&key dims)
177  "CREATE-WORLD &key DIMS => RESULT
178
179   DIMS: (:xmin XMIN :xmax XMAX :ymin YMIN :ymax YMAX)
180
181 ARGUMENTS AND VALUES:
182
183   RESULT: undefined
184   XMIN: An integer representing the minimum patch coord in X
185   XMAX: An integer representing the maximum patch coord in X
186   YMIN: An integer representing the minimum patch coord in Y
187   YMAX: An integer representing the maximum patch coord in Y
188
189 DESCRIPTION:
190
191   Initializes the world in the NVM.
192
193   This should be called before using the engine in any real capacity.  If
194   called when an engine is already running, it may do somethign weird."
195  (setf *dimensions* dims)
196  (setf *turtles* nil)
197  (setf *current-id* 0))
198
199 ; These match netlogo's dump
200 (defgeneric dump-object (o))
201
202 (defmethod dump-object ((n double-float))
203  (multiple-value-bind (int rem) (floor n)
204   (if (eql 0d0 rem)
205    (format nil "~A" int)
206    (let
207     ((output (format nil "~D" n)))
208     ; Someday we'll have d<posint>, but this is not that day!
209     (cl-ppcre:regex-replace "d-" (cl-ppcre:regex-replace "d0" output "") "E-")))))
210
211 (defmethod dump-object ((o string)) o)
212
213 (defun current-state ()
214  "CURRENT-STATE => WORLD-STATE
215
216 ARGUMENTS AND VALUES:
217
218   WORLD-STATE: A list, the current state of the whole world
219
220 DESCRIPTION:
221
222   Dumps out the state of the world.
223
224   This is useful for visualizations and also storing in a common lisp
225   data structure for easy usage in a common lisp instance.  It's preferable
226   to use this when working with the nvm than the output done by export-world.
227
228   Currently this only dumps out turtle information.
229
230   This is called CURRENT-STATE because export-world is an actual primitive
231   used by NetLogo."
232  (mapcar
233   (lambda (turtle)
234    (list
235     :color (turtle-color turtle)
236     :xcor (turtle-xcor turtle)
237     :ycor (turtle-ycor turtle)
238     :heading (turtle-heading turtle)))
239   *turtles*))
240
241 (defun export-patches ()
242  (list
243   "\"pxcor\",\"pycor\",\"pcolor\",\"plabel\",\"plabel-color\""
244   "\"-1\",\"1\",\"0\",\"\"\"\"\"\",\"9.9\""
245   "\"0\",\"1\",\"0\",\"\"\"\"\"\",\"9.9\""
246   "\"1\",\"1\",\"0\",\"\"\"\"\"\",\"9.9\""
247   "\"-1\",\"0\",\"0\",\"\"\"\"\"\",\"9.9\""
248   "\"0\",\"0\",\"0\",\"\"\"\"\"\",\"9.9\""
249   "\"1\",\"0\",\"0\",\"\"\"\"\"\",\"9.9\""
250   "\"-1\",\"-1\",\"0\",\"\"\"\"\"\",\"9.9\""
251   "\"0\",\"-1\",\"0\",\"\"\"\"\"\",\"9.9\""
252   "\"1\",\"-1\",\"0\",\"\"\"\"\"\",\"9.9\""))
253
254 (defun export-world ()
255  "EXPORT-WORLD => WORLD-CSV
256
257 ARGUMENTS AND VALUES:
258
259   WORLD-CSV: A string, the csv of the world
260
261 DESCRIPTION:
262
263   Dumps out a csv matching NetLogo's export world.
264
265   This is useful for serializing the current state of the engine in order
266   to compare against NetLogo or to reimport later.  Contains everything needed
267   to boot up a NetLogo instance in the exact same state."
268  (format nil "~{~A~%~}"
269   (list
270    (format nil "~S" "RANDOM STATE")
271    (format nil "~S" (clnl-random:export))
272    ""
273    (format nil "~S" "GLOBALS")
274    (format nil "~A~A"
275     "\"min-pxcor\",\"max-pxcor\",\"min-pycor\",\"max-pycor\",\"perspective\",\"subject\","
276     "\"nextIndex\",\"directed-links\",\"ticks\",")
277    (format nil "\"~A\",\"~A\",\"~A\",\"~A\",\"0\",\"nobody\",\"~A\",\"\"\"NEITHER\"\"\",\"-1\""
278     (min-pxcor) (max-pxcor) (min-pycor) (max-pycor) *current-id*)
279    ""
280    (format nil "~S" "TURTLES")
281    (format nil "~A~A"
282     "\"who\",\"color\",\"heading\",\"xcor\",\"ycor\",\"shape\",\"label\",\"label-color\","
283     "\"breed\",\"hidden?\",\"size\",\"pen-size\",\"pen-mode\"")
284    (format nil "~{~A~%~}"
285     (mapcar
286      (lambda (turtle)
287       (format nil
288        "\"~A\",\"~A\",\"~A\",\"~A\",\"~A\",~A"
289        (turtle-who turtle)
290        (dump-object (turtle-color turtle))
291        (dump-object (turtle-heading turtle))
292        (dump-object (turtle-xcor turtle))
293        (dump-object (turtle-ycor turtle))
294        "\"\"\"default\"\"\",\"\"\"\"\"\",\"9.9\",\"{all-turtles}\",\"false\",\"1\",\"1\",\"\"\"up\"\"\""))
295      *turtles*))
296    (format nil "~S" "PATCHES")
297    (format nil "~{~A~^~%~}" (export-patches))
298    ""
299    (format nil "~S" "LINKS")
300    "\"end1\",\"end2\",\"color\",\"label\",\"label-color\",\"hidden?\",\"breed\",\"thickness\",\"shape\",\"tie-mode\""
301    "")))