Shapes - dynamic coloring for only parts of shapes
[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 lookup-color (color)
21  "LOOKUP-COLOR COLOR => COLOR-NUMBER
22
23 ARGUMENTS AND VALUES:
24
25   COLOR: a symbol representing a color
26   COLOR-NUMBER: the NetLogo color integer
27
28 DESCRIPTION:
29
30   Returns the number used to represent colors in NetLogo.
31
32   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#Constants"
33  (case color
34   (:black 0d0)
35   (:gray 5d0)
36   (:white 9.9d0)
37   (:red 15d0)
38   (:orange 25d0)
39   (:brown 35d0)
40   (:yellow 45d0)
41   (:green 55d0)
42   (:lime 65d0)
43   (:turquoise 75d0)
44   (:cyan 85d0)
45   (:sky 95d0)
46   (:blue 105d0)
47   (:violet 115d0)
48   (:magenta 125d0)
49   (:pink 135d0)))
50
51 (defun create-turtle (breed &optional base-turtle)
52  (let*
53   ((breed (or breed (and base-turtle (turtle-breed base-turtle)) :turtles))
54    (new-turtle (make-turtle
55                 :who (coerce *current-id* 'double-float)
56                 :color (if base-turtle
57                         (turtle-color base-turtle)
58                         (coerce (+ 5 (* 10 (clnl-random:next-int 14))) 'double-float))
59                 :heading (if base-turtle
60                           (turtle-heading base-turtle)
61                           (coerce (clnl-random:next-int 360) 'double-float))
62                 :label-color (if base-turtle (turtle-label-color base-turtle) 9.9d0)
63                 :size (if base-turtle (turtle-size base-turtle) 1d0)
64                 :breed breed
65                 :shape (breed-default-shape breed)
66                 :xcor (if base-turtle (turtle-xcor base-turtle) 0d0)
67                 :ycor (if base-turtle (turtle-ycor base-turtle) 0d0)
68                 :own-vars (when base-turtle (copy-list (turtle-own-vars base-turtle))))))
69   (let
70    ((patch (patch-at (turtle-xcor new-turtle) (turtle-ycor new-turtle))))
71    (setf (patch-turtles patch) (nconc (patch-turtles patch) (list new-turtle))))
72   (setf *turtles* (nconc *turtles* (list new-turtle)))
73   (incf *current-id*)
74   new-turtle))
75
76 (defun die ()
77  "DIE => RESULT
78
79 ARGUMENTS AND VALUES:
80
81   RESULT: undefined, commands don't return
82
83 DESCRIPTION:
84
85   The turtle or link dies
86
87   A dead agent ceases to exist. The effects of this include:
88   - The agent will not execute any further code.
89   - The agent will disappear from any agentsets it was in, reducing the size of those agentsets by one.
90   - Any variable that was storing the agent will now instead have nobody in it.
91   - If the dead agent was a turtle, every link connected to it also dies.
92   - If the observer was watching or following the agent, the observer's perspective resets.
93
94   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#die"
95  (when (not (turtle-p *self*)) (error "Gotta call die in turtle scope, dude (~A)" *self*))
96  (setf (turtle-who *self*) -1)
97  (setf *turtles* (remove *self* *turtles*))
98  (let
99   ((patch (patch-at (turtle-xcor *self*) (turtle-ycor *self*))))
100   (setf (patch-turtles patch) (remove *self* (patch-turtles patch))))
101  (error (make-condition 'death)))
102
103 (defun patches ()
104  "PATCHES => ALL-PATCHES
105
106 ARGUMENTS AND VALUES:
107
108   ALL-PATCHES: a NetLogo agentset, all patches
109
110 DESCRIPTION:
111
112   Reports the agentset consisting of all the patches.
113
114   This agentset is special in that it represents the living patches
115   each time it's used, so changes depending on the state of the engine.
116
117   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#patches"
118  :patches)
119
120 (defun turtles ()
121  "TURTLES => ALL-TURTLES
122
123 ARGUMENTS AND VALUES:
124
125   ALL-TURTLES: a NetLogo agentset, all turtles
126
127 DESCRIPTION:
128
129   Reports the agentset consisting of all the turtles.
130
131   This agentset is special in that it represents the living turtles
132   each time it's used, so changes depending on the state of the engine.
133
134   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#turtles"
135  :turtles)
136
137 (defun turtles-here (&optional breed)
138  "TURTLES-HERE => TURTLES
139
140 ARGUMENTS AND VALUES:
141
142   TURTLES: an agentset
143
144 DESCRIPTION:
145
146   Returns the agentset consisting of all the turtles sharing the patch
147   with the agent in by *self*
148
149   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#turtles-here"
150  (when (not (turtle-p *self*)) (error "Gotta call turtles-here with a turtle"))
151  (let
152   ((patch-turtles (patch-turtles (patch-at (turtle-xcor *self*) (turtle-ycor *self*)))))
153   (list->agentset
154    (if breed (remove breed patch-turtles :key #'turtle-breed :test-not #'eql) patch-turtles)
155    (or breed :turtles))))
156
157 (defun ask (agent-or-agentset fn)
158  "ASK AGENT-OR-AGENTSET FN => RESULT
159
160   AGENT-OR-AGENTSET: AGENT | AGENTSET
161
162 ARGUMENTS AND VALUES:
163
164   FN: a function, run on each agent
165   RESULT: undefined, commands don't return
166   AGENT: a NetLogo agent
167   AGENTSET: a NetLogo agentset
168
169 DESCRIPTION:
170
171   ASK is equivalent to ask in NetLogo.
172
173   The specified AGENTSET or AGENT runs the given FN.  In the case of an
174   AGENTSET, the order in which the agents are run is random each time,
175   and only agents that are in the set at the beginning of the call.
176
177   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#ask"
178  (cond
179   ((agentset-p agent-or-agentset)
180    (let
181     ((iter (shufflerator (agentset-list agent-or-agentset))))
182     (loop
183      :for agent := (funcall iter)
184      :while agent
185      :do (when (not (and (turtle-p agent) (= -1 (turtle-who agent))))
186           (let ((*myself* *self*) (*self* agent)) (with-stop-and-death-handler (funcall fn)))))))
187   ((agent-p agent-or-agentset)
188    (let ((*myself* *self*) (*self* agent-or-agentset)) (with-stop-and-death-handler (funcall fn))))
189   (t
190    (error "Ask requires an agentset or agent but got: ~A" agent-or-agentset))))
191
192 (defun count (agentset)
193  "COUNT AGENTSET => N
194
195 ARGUMENTS AND VALUES:
196
197   AGENTSET: a NetLogo agentset
198   N: a number
199
200 DESCRIPTION:
201
202   COUNT is equivalent to count in NetLogo.  Returns N, the number of
203   agents in AGENTSET.
204
205   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#count"
206  (coerce (length (agentset-list agentset)) 'double-float))
207
208 (defun clear-all ()
209  "CLEAR-ALL => RESULT
210
211 ARGUMENTS AND VALUES:
212
213   RESULT: undefined
214
215 DESCRIPTION:
216
217   Clears ticks, turtles, patches, globals (unimplemented).
218
219   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#clear-all"
220  (clear-turtles)
221  (clear-patches)
222  (clear-ticks))
223
224 (defun display ()
225  "DISPLAY => RESULT
226
227 ARGUMENTS AND VALUES:
228
229   RESULT: undefined
230
231 DESCRIPTION:
232
233   As of yet, this does nothing.  A placeholder method for forced dipslay
234   updates from the engine.
235
236   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#display"
237  nil)
238
239 (defun stop ()
240  "STOP => RESULT
241
242 ARGUMENTS AND VALUES:
243
244   RESULT: undefined
245
246 DESCRIPTION:
247
248   Returns from the current stop block, which will halt the currently running
249   thing, be that the program, current ask block, or procedure.  Stop has odd
250   semantics that are best gleaned from the actual NetLogo manual.
251
252   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#stop"
253  (error (make-condition 'stop)))
254
255 (defun of (fn agent-or-agentset)
256  "OF FN AGENT-OR-AGENTSET => RESULT
257
258   AGENT-OR-AGENTSET: AGENT | AGENTSET
259   RESULT: RESULT-LIST | RESULT-VALUE
260
261 ARGUMENTS AND VALUES:
262
263   FN: a function, run on each agent
264   AGENT: a NetLogo agent
265   AGENTSET: a NetLogo agentset
266   RESULT-LIST: a list
267   RESULT-VALUE: a single value
268
269 DESCRIPTION:
270
271   OF is equivalent to of in NetLogo.
272
273   The specified AGENTSET or AGENT runs the given FN.  In the case of an
274   AGENTSET, the order in which the agents are run is random each time,
275   and only agents that are in the set at the beginning of the call.
276
277   RESULT-LIST is returned when the input is an AGENTSET, but RESULT-VALUE
278   is returned when only passed an AGENT.
279
280   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#of"
281  (cond
282   ((agentset-p agent-or-agentset)
283    (let
284     ((iter (shufflerator (agentset-list agent-or-agentset))))
285     (loop
286      :for agent := (funcall iter)
287      :while agent
288      :collect (let ((*myself* *self*) (*self* agent)) (funcall fn)))))
289   ((agent-p agent-or-agentset)
290    (let ((*myself* *self*) (*self* agent-or-agentset)) (funcall fn)))
291   (t
292    (error "Of requires an agentset or agent but got: ~A" agent-or-agentset))))
293
294 (defun with (agentset fn)
295  "WITH AGENTSET FN => RESULT-AGENTSET
296
297 ARGUMENTS AND VALUES:
298
299   AGENTSET: a NetLogo agentset
300   FN: a boolean function, run on each agent to determine if included
301   RESULT-AGENTSET: an agentset of valid agents
302
303 DESCRIPTION:
304
305   WITH is equivalent to with in NetLogo.
306
307   Returns a new agentset containing only those agents that reported true
308   when FN is called.
309
310   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#with"
311  (list->agentset
312   (remove-if-not
313    (lambda (agent)
314     (let ((*myself* *self*) (*self* agent)) (funcall fn)))
315    (agentset-list agentset))
316   (agentset-breed agentset)))
317
318 (defun shufflerator (agentset-list)
319  (let
320   ((copy (copy-list agentset-list))
321    (i 0)
322    (agent nil))
323   (labels
324    ((fetch ()
325      (let
326       ((idx (when (< i (1- (length copy))) (+ i (clnl-random:next-int (- (length copy) i))))))
327       (when idx (setf agent (nth idx copy)))
328       (when idx (setf (nth idx copy) (nth i copy)))
329       (incf i)
330       (when (and (<= i (length copy)) (turtle-p agent) (= -1 (turtle-who agent))) (fetch)))))
331    (fetch) ; we pre-fetch because netlogo does, rng sync hype!
332    (lambda ()
333     (cond
334      ((> i (length copy)) nil)
335      ((= i (length copy)) (incf i) (car (last copy)))
336      (t (let ((result agent)) (fetch) result)))))))
337
338 (defun random-float (n)
339  "RANDOM-FLOAT N => RANDOM-NUMBER
340
341 ARGUMENTS AND VALUES:
342
343   N: a double, the upper bound of the random float
344   RANDOM-NUMBER: a double, the random result
345
346 DESCRIPTION:
347
348   Returns a random number strictly closer to zero than N.
349
350   If number is positive, returns a random floating point number greater than
351   or equal to 0 but strictly less than number.
352
353   If number is negative, returns a random floating point number less than or equal
354   to 0, but strictly greater than number.
355
356   If number is zero, the result is always 0.
357
358   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#random-float"
359  (clnl-random:next-double n))
360
361 (defun random (n)
362  "RANDOM N => RANDOM-NUMBER
363
364 ARGUMENTS AND VALUES:
365
366   N: an integer, the upper bound of the random
367   RANDOM-NUMBER: an integer, the random result
368
369 DESCRIPTION:
370
371   Returns a random number strictly closer to zero than N.
372
373   If number is positive, returns a random integer greater than or equal to 0,
374   but strictly less than number.
375
376   If number is negative, returns a random integer less than or equal to 0,
377   but strictly greater than number.
378
379   If number is zero, the result is always 0.
380
381   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#random"
382  (coerce (clnl-random:next-long (truncate n)) 'double-float))
383
384 (defun random-xcor ()
385  "RANDOM-XCOR => RANDOM-NUMBER
386
387 ARGUMENTS AND VALUES:
388
389   RANDOM-NUMBER: a float, the random result
390
391 DESCRIPTION:
392
393   Returns a random floating point number in the allowable range of turtle
394   coordinates along the x axis.
395
396   These range from min-pxcor - 0.5 (inclusive) to max-pxcor + 0.5 (exclusive)
397
398   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#random-cor"
399  (let
400   ((min (- (min-pxcor) 0.5d0))
401    (max (+ (max-pxcor) 0.5d0)))
402   (+ min (clnl-random:next-double (- max min)))))
403
404 (defun random-ycor ()
405  "RANDOM-YCOR => RANDOM-NUMBER
406
407 ARGUMENTS AND VALUES:
408
409   RANDOM-NUMBER: a float, the random result
410
411 DESCRIPTION:
412
413   Returns a random floating point number in the allowable range of turtle
414   coordinates along the y axis.
415
416   These range from min-pycor - 0.5 (inclusive) to max-pycor + 0.5 (exclusive)
417
418   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#random-cor"
419  (let
420   ((min (- (min-pycor) 0.5d0))
421    (max (+ (max-pycor) 0.5d0)))
422   (+ min (clnl-random:next-double (- max min)))))
423
424 (defun one-of (list-or-agentset)
425  "ONE-OF LIST-OR-AGENTSET => RESULT
426
427   LIST-OR-AGENTSET: LIST | AGENTSET
428   RESULT: RANDOM-VALUE | RANDOM-AGENT | :nobody
429
430 ARGUMENTS AND VALUES:
431
432   LIST: A list
433   AGENTSET: An agent set
434   RANDOM-VALUE: a value in LIST
435   RANDOM-AGENT: an agent if AGENTSET is non empty
436
437 DESCRIPTION:
438
439   From an AGENTSET, returns a RANDOM-AGENT. If the agentset is empty, returns :nobody.
440   From a list, returns a RANDOM-VALUE.  If the list is empty, an error occurs.
441
442   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#one-of"
443  (cond
444   ((agentset-p list-or-agentset)
445    (let*
446     ((agentset-list (agentset-list list-or-agentset))
447      (length (length agentset-list)))
448     (if (zerop length) :nobody (nth (clnl-random:next-int length) agentset-list))))
449   ((listp list-or-agentset)
450    (let*
451     ((length (length list-or-agentset)))
452     (if (zerop length)
453      (error "one-of requires a nonempty list")
454      (nth (clnl-random:next-int length) list-or-agentset))))
455   (t (error "one-of requires a list or agentset"))))
456
457 (defun jump (n)
458  (when (not (turtle-p *self*)) (error "Gotta call jump in turtle scope, dude (~A)" *self*))
459  (with-patch-update *self*
460   (setf
461    (turtle-xcor *self*)
462    (wrap-x *topology*
463     (+ (turtle-xcor *self*) (* n (using-cached-sin (turtle-heading *self*))))))
464   (setf
465    (turtle-ycor *self*)
466    (wrap-y *topology*
467     (+ (turtle-ycor *self*) (* n (using-cached-cos (turtle-heading *self*))))))))
468
469 (defun setxy (x y)
470  "SETXY X Y => RESULT
471
472 ARGUMENTS AND VALUES:
473
474   X: a double
475   Y: a double
476   RESULT: undefined
477
478 DESCRIPTION:
479
480   Sets the x-coordinate and y-coordinate for the turle.  Equivalent to
481   set xcor x set ycor y, except it happens in one step inside of two.
482
483   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#setxy"
484  (when (not (turtle-p *self*)) (error "Gotta call setxy in turtle scope, dude (~A)" *self*))
485  (setf (turtle-xcor *self*) (wrap-x *topology* x))
486  (setf (turtle-ycor *self*) (wrap-y *topology* y)))
487
488 (defun set-default-shape (breed shape)
489  "SET-DEFAULT-SHAPE BREED SHAPE => RESULT
490
491 ARGUMENTS AND VALUES:
492
493   BREED: a valid breed
494   SHAPE: a string
495   RESULT: undefined
496
497 DESCRIPTION:
498
499   Specifies a default initial shape for a BREED. When a turtle, or it changes breeds,
500   its shape is set to the given shape.
501
502   SET-DEFAULT-SHAPE doesn't affect existing agents, only agents you create afterwards.
503
504   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#set-default-shape"
505  (when (not (breed-p breed)) (error "Need a valid breed"))
506  (setf (breed-default-shape breed) shape))
507
508 (defun forward (n)
509  "FORWARD N => RESULT
510
511 ARGUMENTS AND VALUES:
512
513   N: a double, the amount the turtle moves forward
514   RESULT: undefined
515
516 DESCRIPTION:
517
518   Moves the current turtle forward N steps, one step at a time.
519
520   This moves forward one at a time in order to make the view updates look
521   good in the case of a purposefully slow running instance.  If the number
522   is negative, the turtle moves backward.
523
524   If the current agent is not a turtle, it raises an error.
525
526   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#forward"
527  (when (not (turtle-p *self*)) (error "Gotta call fd in turtle scope, dude (~A)" *self*))
528  (labels
529   ((internal (i)
530     (cond
531      ((< (abs i) 3.2e-15) nil)
532      ((< (abs i) 1d0) (jump i))
533      (t (jump (if (> i 0d0) 1d0 -1d0)) (internal (- i (if (> i 0d0) 1d0 -1d0)))))))
534   (internal n)))
535
536 (defun turn-right (n)
537  "TURN-RIGHT N => RESULT
538
539 ARGUMENTS AND VALUES:
540
541   N: a double, the amount the turtle turns
542   RESULT: undefined
543
544 DESCRIPTION:
545
546   The turtle turns right by number degrees. (If number is negative, it turns left.)
547
548   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#right"
549  (when (not (turtle-p *self*)) (error "Gotta call fd in turtle scope, dude (~A)" *self*))
550  (let
551   ((new-heading (+ (turtle-heading *self*) n)))
552   (setf (turtle-heading *self*)
553    (cond
554     ((< new-heading 0) (+ (mod new-heading -360) 360))
555     ((>= new-heading 360) (mod new-heading 360))
556     (t new-heading)))))
557
558 (defun turn-left (n)
559  "TURN-LEFT N => RESULT
560
561 ARGUMENTS AND VALUES:
562
563   N: a double, the amount the turtle turns
564   RESULT: undefined
565
566 DESCRIPTION:
567
568   The turtle turns left by number degrees. (If number is negative, it turns right.)
569
570   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#right"
571  (turn-right (- n)))
572
573 (defun create-turtles (n &optional breed fn)
574  "CREATE-TURTLES N &optional BREED FN => RESULT
575
576 ARGUMENTS AND VALUES:
577
578   N: an integer, the numbers of turtles to create
579   BREED: a breed
580   FN: A function, applied to each turtle after creation
581   RESULT: undefined
582
583 DESCRIPTION:
584
585   Creates N new turtles at the origin.
586
587   New turtles have random integer headings and the color is randomly selected
588   from the 14 primary colors.  If FN is supplied, the new turtles immediately
589   run it.  If a BREED is supplied, that is the breed the new turtles are set
590   to.
591
592   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#create-turtles"
593  (let
594   ((new-turtles (loop :repeat n :collect (create-turtle breed))))
595   (when fn (ask (list->agentset new-turtles :turtles) fn))))
596
597 (defun hatch (n &optional fn)
598  "HATCH N &optional FN => RESULT
599
600 ARGUMENTS AND VALUES:
601
602   N: an integer, the numbers of turtles to hatch
603   FN: A function, applied to each turtle after creation
604   RESULT: undefined
605
606 DESCRIPTION:
607
608   The turtle in *self* creates N new turtles. Each new turtle inherits of all its
609   variables, including its location, from self.
610
611   If FN is supplied, the new turtles immediately run it.
612
613   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#hatch"
614  (when (not (turtle-p *self*)) (error "Can only hatch from turtle scope"))
615  (let
616   ((new-turtles (loop :repeat n :collect (create-turtle nil *self*))))
617   (when fn (ask (list->agentset new-turtles :turtles) fn))))
618
619 (defun reset-ticks ()
620  "RESET-TICKS => RESULT
621
622 ARGUMENTS AND VALUES:
623
624   RESULT: undefined
625
626 DESCRIPTION:
627
628   Resets the tick counter to zero, sets up all plots, then updates all plots.
629
630   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#reset-ticks"
631  (setf *ticks* 0d0))
632
633 (defun tick ()
634  "RESET-TICKS => RESULT
635
636 ARGUMENTS AND VALUES:
637
638   RESULT: undefined
639
640 DESCRIPTION:
641
642   Advances the tick counter by one and updates all plots.
643
644   If the tick counter has not been started yet with reset-ticks, an error results.
645
646   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#tick"
647
648  (when (not *ticks*) (error "reset-ticks must be called"))
649  (incf *ticks*))
650
651 (defun ticks ()
652  "TICKS => CURRENT-TICKS
653
654 ARGUMENTS AND VALUES:
655
656   CURRENT-TICKS: A positiv double, representing the current number of ticks
657
658 DESCRIPTION:
659
660   Reports the current value of the tick counter. The result is always a number and never negative.
661
662   If the tick counter has not been started yet with reset-ticks, an error results.
663
664   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#ticks"
665  (when (not *ticks*) (error "reset-ticks must be called"))
666  *ticks*)
667
668 (defun clear-patches ()
669  (setf
670   *patches*
671   (loop
672    :for y :from (max-pycor) :downto (min-pycor)
673    :append (loop
674             :for x :from (min-pxcor) :to (max-pxcor)
675             :collect (make-patch
676                       :xcor (coerce x 'double-float)
677                       :ycor (coerce y 'double-float)
678                       :color 0d0)))))
679
680 (defun clear-turtles ()
681  (setf *turtles* nil)
682  (setf *current-id* 0))
683
684 (defun clear-ticks ()
685  (setf *ticks* nil))
686
687 (defun create-world (&key dims globals turtles-own-vars patches-own-vars breeds)
688  "CREATE-WORLD &key DIMS GLOBALS TURTLES-OWN-VARS PATCHES-OWN-VARS BREEDS => RESULT
689
690   DIMS: (:xmin XMIN :xmax XMAX :ymin YMIN :ymax YMAX)
691   GLOBALS: GLOBAL*
692   TURTLES-OWN-VARS: TURTLES-OWN-VAR*
693   PATCHES-OWN-VARS: PATCHES-OWN-VAR*
694   BREEDS: BREED*
695   GLOBAL: (GLOBAL-NAME GLOBAL-ACCESS-FUNC)
696
697 ARGUMENTS AND VALUES:
698
699   RESULT: undefined
700   XMIN: An integer representing the minimum patch coord in X
701   XMAX: An integer representing the maximum patch coord in X
702   YMIN: An integer representing the minimum patch coord in Y
703   YMAX: An integer representing the maximum patch coord in Y
704   TURTLES-OWN-VAR: Symbol for the turtles own variable in the keyword package
705   PATCHES-OWN-VAR: Symbol for the patches own variable in the keyword package
706   BREED: A list of symbols representing the possible preeds
707   GLOBAL-NAME: Symbol for the global in the keyword package
708   GLOBAL-ACCESS-FUNC: Function to get the value of the global
709
710 DESCRIPTION:
711
712   Initializes the world in the NVM.
713
714   This should be called before using the engine in any real capacity.  If
715   called when an engine is already running, it may do somethign weird."
716  (setf *turtles-own-vars* turtles-own-vars)
717  (setf *patches-own-vars* patches-own-vars)
718  (setf *dimensions* dims)
719  (setf *globals* globals)
720  (setf *breeds*
721   (append
722    (list (list :turtles "default"))
723    (mapcar (lambda (breed) (list breed "default")) breeds)))
724  (clear-ticks)
725  (clear-patches)
726  (clear-turtles))
727
728 ; These match netlogo's dump
729 (defgeneric dump-object (o))
730
731 (defmethod dump-object ((n double-float))
732  (multiple-value-bind (int rem) (floor n)
733   (if (eql 0d0 rem)
734    (format nil "~A" int)
735    (let
736     ((output (format nil "~D" n)))
737     ; Someday we'll have d<posint>, but this is not that day!
738     (cl-ppcre:regex-replace "d-" (cl-ppcre:regex-replace "d0" output "") "E-")))))
739
740 (defmethod dump-object ((o string)) (format nil "~A" (cl-ppcre:regex-replace-all "\"" (format nil "~S" o) "\"\"")))
741
742 (defmethod dump-object ((o (eql t))) "true")
743 (defmethod dump-object ((o (eql nil))) "false")
744
745 (defmethod dump-object ((o list))
746  (cond
747   ((agentset-p o) (format nil "(agentset, ~A ~A)" (dump-object (count o)) (string-downcase (agentset-breed o))))
748   (t (format nil "[~{~A~^ ~}]" (mapcar #'dump-object o)))))
749
750 (defmethod dump-object ((o patch))
751  (format nil "(patch ~A ~A)" (dump-object (patch-xcor o)) (dump-object (patch-ycor o))))
752
753 (defmethod dump-object ((o turtle)) (format nil "(turtle ~A)" (dump-object (turtle-who o))))
754 (defmethod dump-object ((o (eql :nobody))) (format nil "nobody"))
755 (defmethod dump-object ((o (eql :turtles))) (format nil "{all-turtles}"))
756 (defmethod dump-object ((o symbol))
757  (cond
758   ((find o *breeds* :key #'car) (format nil "{breed ~(~A~)}" o))
759   (t (error "Keyword unrecognized by dump object: ~A" o))))
760
761 (defun current-state ()
762  "CURRENT-STATE => WORLD-STATE
763
764 ARGUMENTS AND VALUES:
765
766   WORLD-STATE: A list, the current state of the whole world
767
768 DESCRIPTION:
769
770   Dumps out the state of the world.
771
772   This is useful for visualizations and also storing in a common lisp
773   data structure for easy usage in a common lisp instance.  It's preferable
774   to use this when working with the nvm than the output done by export-world.
775
776   Currently this only dumps out turtle and patch information.
777
778   This is called CURRENT-STATE because export-world is an actual primitive
779   used by NetLogo."
780  (list
781   (mapcar
782    (lambda (turtle)
783     (list
784      :color (turtle-color turtle)
785      :xcor (turtle-xcor turtle)
786      :ycor (turtle-ycor turtle)
787      :heading (turtle-heading turtle)
788      :shape (turtle-shape turtle)
789      :size (turtle-size turtle)))
790    *turtles*)
791   (mapcar
792    (lambda (patch)
793     (list
794      :color (patch-color patch)
795      :xcor (patch-xcor patch)
796      :ycor (patch-ycor patch)))
797    *patches*)))
798
799 (defun export-turtles ()
800  (append
801   (list
802    "\"TURTLES\""
803    (format nil "~A~A~{,\"~A\"~}"
804     "\"who\",\"color\",\"heading\",\"xcor\",\"ycor\",\"shape\",\"label\",\"label-color\","
805     "\"breed\",\"hidden?\",\"size\",\"pen-size\",\"pen-mode\""
806     (mapcar #'string-downcase *turtles-own-vars*)))
807   (mapcar
808    (lambda (turtle)
809     (format nil
810      "\"~A\",\"~A\",\"~A\",\"~A\",\"~A\",\"~A\",\"~A\",\"~A\",\"~A\",\"false\",\"~A\",~A~{,\"~A\"~}"
811      (dump-object (turtle-who turtle))
812      (dump-object (turtle-color turtle))
813      (dump-object (turtle-heading turtle))
814      (dump-object (turtle-xcor turtle))
815      (dump-object (turtle-ycor turtle))
816      (dump-object (turtle-shape turtle))
817      (dump-object (turtle-label turtle))
818      (dump-object (turtle-label-color turtle))
819      (dump-object (turtle-breed turtle))
820      (dump-object (turtle-size turtle))
821      "\"1\",\"\"\"up\"\"\""
822      (mapcar #'dump-object (mapcar (lambda (var) (agent-value-inner turtle var)) *turtles-own-vars*))))
823    *turtles*)))
824
825 (defun export-patches ()
826  (append
827   (list
828    "\"PATCHES\""
829    (format nil "\"pxcor\",\"pycor\",\"pcolor\",\"plabel\",\"plabel-color\"~{,\"~A\"~}"
830     (mapcar #'string-downcase *patches-own-vars*)))
831   (mapcar
832    (lambda (patch)
833     (format nil
834      "\"~A\",\"~A\",\"~A\",\"\"\"\"\"\",\"9.9\"~{,\"~A\"~}"
835      (dump-object (patch-xcor patch))
836      (dump-object (patch-ycor patch))
837      (dump-object (patch-color patch))
838      (mapcar #'dump-object (mapcar (lambda (var) (agent-value-inner patch var)) *patches-own-vars*))))
839    *patches*)))
840
841 (defun export-world ()
842  "EXPORT-WORLD => WORLD-CSV
843
844 ARGUMENTS AND VALUES:
845
846   WORLD-CSV: A string, the csv of the world
847
848 DESCRIPTION:
849
850   Dumps out a csv matching NetLogo's export world.
851
852   This is useful for serializing the current state of the engine in order
853   to compare against NetLogo or to reimport later.  Contains everything needed
854   to boot up a NetLogo instance in the exact same state."
855  (let
856   ((ordered-globals (sort (copy-list *globals*) #'string< :key (lambda (global) (symbol-name (car global))))))
857   (format nil "~{~A~%~}"
858    (list
859     (format nil "~S" "RANDOM STATE")
860     (format nil "~S" (clnl-random:export))
861     ""
862     (format nil "~S" "GLOBALS")
863     (format nil "~A~A~{\"~A\"~^,~}"
864      "\"min-pxcor\",\"max-pxcor\",\"min-pycor\",\"max-pycor\",\"perspective\",\"subject\","
865      "\"nextIndex\",\"directed-links\",\"ticks\","
866      (mapcar #'string-downcase (mapcar #'car ordered-globals)))
867     (format nil "\"~A\",\"~A\",\"~A\",\"~A\",\"0\",\"nobody\",\"~A\",\"\"\"NEITHER\"\"\",\"~A\"~{,\"~A\"~}"
868      (min-pxcor) (max-pxcor) (min-pycor) (max-pycor) *current-id* (dump-object (or *ticks* -1d0))
869      (mapcar #'dump-object (mapcar #'funcall (mapcar #'cadr ordered-globals))))
870     ""
871     (format nil "~{~A~^~%~}" (export-turtles))
872     ""
873     (format nil "~{~A~^~%~}" (export-patches))
874     ""
875     (format nil "~S" "LINKS")
876     "\"end1\",\"end2\",\"color\",\"label\",\"label-color\",\"hidden?\",\"breed\",\"thickness\",\"shape\",\"tie-mode\""
877     ""))))