1 (in-package #:clnl-nvm)
3 ; Implementations of all the things the nvm can do.
10 VALUE: a NetLogo value
15 A command that prints the given NetLogo value to the command center.
17 See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#show"
18 (format t "Showing: ~A~%" (dump-object value)))
20 (defun lookup-color (color)
21 "LOOKUP-COLOR COLOR => COLOR-NUMBER
25 COLOR: a symbol representing a color
26 COLOR-NUMBER: the NetLogo color integer
30 Returns the number used to represent colors in NetLogo.
32 See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#Constants"
51 (defun create-turtle ()
53 ((new-turtle (make-turtle
54 :who (coerce *current-id* 'double-float)
55 :color (coerce (+ 5 (* 10 (clnl-random:next-int 14))) 'double-float)
56 :heading (coerce (clnl-random:next-int 360) 'double-float)
59 (setf *turtles* (nconc *turtles* (list new-turtle)))
68 RESULT: undefined, commands don't return
72 The turtle or link dies
74 A dead agent ceases to exist. The effects of this include:
75 - The agent will not execute any further code.
76 - The agent will disappear from any agentsets it was in, reducing the size of those agentsets by one.
77 - Any variable that was storing the agent will now instead have nobody in it.
78 - If the dead agent was a turtle, every link connected to it also dies.
79 - If the observer was watching or following the agent, the observer's perspective resets.
81 See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#die"
82 (when (not (turtle-p *self*)) (error "Gotta call die in turtle scope, dude (~A)" *self*))
83 (setf (turtle-who *self*) -1)
84 (setf *turtles* (remove *self* *turtles*)))
87 "PATCHES => ALL-PATCHES
91 ALL-PATCHES: a NetLogo agentset, all patches
95 Reports the agentset consisting of all the patches.
97 This agentset is special in that it represents the living patches
98 each time it's used, so changes depending on the state of the engine.
100 See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#patches"
104 "TURTLES => ALL-TURTLES
106 ARGUMENTS AND VALUES:
108 ALL-TURTLES: a NetLogo agentset, all turtles
112 Reports the agentset consisting of all the turtles.
114 This agentset is special in that it represents the living turtles
115 each time it's used, so changes depending on the state of the engine.
117 See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#turtles"
120 (defun ask (agent-or-agentset fn)
121 "ASK AGENT-OR-AGENTSET FN => RESULT
123 AGENT-OR-AGENTSET: AGENT | AGENTSET
125 ARGUMENTS AND VALUES:
127 FN: a function, run on each agent
128 RESULT: undefined, commands don't return
129 AGENT: a NetLogo agent
130 AGENTSET: a NetLogo agentset
134 ASK is equivalent to ask in NetLogo.
136 The specified AGENTSET or AGENT runs the given FN. In the case of an
137 AGENTSET, the order in which the agents are run is random each time,
138 and only agents that are in the set at the beginning of the call.
140 See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#ask"
142 ((agentset-p agent-or-agentset)
144 ((iter (shufflerator (agentset-list agent-or-agentset))))
146 :for agent := (funcall iter)
148 :do (let ((*myself* *self*) (*self* agent)) (funcall fn)))))
149 ((agent-p agent-or-agentset)
150 (let ((*myself* *self*) (*self* agent-or-agentset)) (funcall fn)))
152 (error "Ask requires an agentset or agent but got: ~A" agent-or-agentset))))
154 (defun count (agentset)
157 ARGUMENTS AND VALUES:
159 AGENTSET: a NetLogo agentset
164 COUNT is equivalent to count in NetLogo. Returns N, the number of
167 See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#count"
168 (coerce (length (agentset-list agentset)) 'double-float))
170 (defun of (fn agent-or-agentset)
171 "OF FN AGENT-OR-AGENTSET => RESULT
173 AGENT-OR-AGENTSET: AGENT | AGENTSET
174 RESULT: RESULT-LIST | RESULT-VALUE
176 ARGUMENTS AND VALUES:
178 FN: a function, run on each agent
179 AGENT: a NetLogo agent
180 AGENTSET: a NetLogo agentset
182 RESULT-VALUE: a single value
186 OF is equivalent to of in NetLogo.
188 The specified AGENTSET or AGENT runs the given FN. In the case of an
189 AGENTSET, the order in which the agents are run is random each time,
190 and only agents that are in the set at the beginning of the call.
192 RESULT-LIST is returned when the input is an AGENTSET, but RESULT-VALUE
193 is returned when only passed an AGENT.
195 See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#of"
197 ((agentset-p agent-or-agentset)
199 ((iter (shufflerator (agentset-list agent-or-agentset))))
201 :for agent := (funcall iter)
203 :collect (let ((*myself* *self*) (*self* agent)) (funcall fn)))))
204 ((agent-p agent-or-agentset)
205 (let ((*myself* *self*) (*self* agent-or-agentset)) (funcall fn)))
207 (error "Of requires an agentset or agent but got: ~A" agent-or-agentset))))
209 (defun with (agentset fn)
210 "WITH AGENTSET FN => RESULT-AGENTSET
212 ARGUMENTS AND VALUES:
214 AGENTSET: a NetLogo agentset
215 FN: a boolean function, run on each agent to determine if included
216 RESULT-AGENTSET: an agentset of valid agents
220 WITH is equivalent to with in NetLogo.
222 Returns a new agentset containing only those agents that reported true
225 See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#with"
229 (let ((*myself* *self*) (*self* agent)) (funcall fn)))
230 (agentset-list agentset))
231 (agentset-breed agentset)))
233 (defun shufflerator (agentset-list)
235 ((copy (copy-list agentset-list))
241 ((idx (when (< i (1- (length copy))) (+ i (clnl-random:next-int (- (length copy) i))))))
242 (when idx (setf agent (nth idx copy)))
243 (when idx (setf (nth idx copy) (nth i copy)))
245 (fetch) ; we pre-fetch because netlogo does, rng sync hype!
248 ((> i (length copy)) nil)
249 ((= i (length copy)) (incf i) (car (last copy)))
250 (t (let ((result agent)) (fetch) result)))))))
252 (defun random-float (n)
253 "RANDOM-FLOAT N => RANDOM-NUMBER
255 ARGUMENTS AND VALUES:
257 N: a double, the upper bound of the random float
258 RANDOM-NUMBER: a double, the random result
262 Returns a random number strictly closer to zero than N.
264 If number is positive, returns a random floating point number greater than
265 or equal to 0 but strictly less than number.
267 If number is negative, returns a random floating point number less than or equal
268 to 0, but strictly greater than number.
270 If number is zero, the result is always 0.
272 See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#random-float"
273 (clnl-random:next-double n))
276 "RANDOM N => RANDOM-NUMBER
278 ARGUMENTS AND VALUES:
280 N: an integer, the upper bound of the random
281 RANDOM-NUMBER: an integer, the random result
285 Returns a random number strictly closer to zero than N.
287 If number is positive, returns a random integer greater than or equal to 0,
288 but strictly less than number.
290 If number is negative, returns a random integer less than or equal to 0,
291 but strictly greater than number.
293 If number is zero, the result is always 0.
295 See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#random"
296 (coerce (clnl-random:next-long (truncate n)) 'double-float))
298 (defun random-xcor ()
299 "RANDOM-XCOR => RANDOM-NUMBER
301 ARGUMENTS AND VALUES:
303 RANDOM-NUMBER: a float, the random result
307 Returns a random floating point number in the allowable range of turtle
308 coordinates along the x axis.
310 These range from min-pxcor - 0.5 (inclusive) to max-pxcor + 0.5 (exclusive)
312 See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#random-cor"
314 ((min (- (min-pxcor) 0.5d0))
315 (max (+ (max-pxcor) 0.5d0)))
316 (+ min (clnl-random:next-double (- max min)))))
318 (defun random-ycor ()
319 "RANDOM-YCOR => RANDOM-NUMBER
321 ARGUMENTS AND VALUES:
323 RANDOM-NUMBER: a float, the random result
327 Returns a random floating point number in the allowable range of turtle
328 coordinates along the y axis.
330 These range from min-pycor - 0.5 (inclusive) to max-pycor + 0.5 (exclusive)
332 See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#random-cor"
334 ((min (- (min-pycor) 0.5d0))
335 (max (+ (max-pycor) 0.5d0)))
336 (+ min (clnl-random:next-double (- max min)))))
338 (defun one-of (list-or-agentset)
339 "ONE-OF LIST-OR-AGENTSET => RESULT
341 LIST-OR-AGENTSET: LIST | AGENTSET
342 RESULT: RANDOM-VALUE | RANDOM-AGENT | :nobody
344 ARGUMENTS AND VALUES:
347 AGENTSET: An agent set
348 RANDOM-VALUE: a value in LIST
349 RANDOM-AGENT: an agent if AGENTSET is non empty
353 From an AGENTSET, returns a RANDOM-AGENT. If the agentset is empty, returns :nobody.
354 From a list, returns a RANDOM-VALUE. If the list is empty, an error occurs.
356 See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#one-of"
358 ((agentset-p list-or-agentset)
360 ((agentset-list (agentset-list list-or-agentset))
361 (length (length agentset-list)))
362 (if (zerop length) :nobody (nth (clnl-random:next-int length) agentset-list))))
363 ((listp list-or-agentset)
365 ((length (length list-or-agentset)))
367 (error "one-of requires a nonempty list")
368 (nth (clnl-random:next-int length) list-or-agentset))))
369 (t (error "one-of requires a list or agentset"))))
372 (when (not (turtle-p *self*)) (error "Gotta call jump in turtle scope, dude (~A)" *self*))
376 (+ (turtle-xcor *self*) (* n (using-cached-sin (turtle-heading *self*))))))
380 (+ (turtle-ycor *self*) (* n (using-cached-cos (turtle-heading *self*)))))))
385 ARGUMENTS AND VALUES:
393 Sets the x-coordinate and y-coordinate for the turle. Equivalent to
394 set xcor x set ycor y, except it happens in one step inside of two.
396 See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#setxy"
397 (when (not (turtle-p *self*)) (error "Gotta call setxy in turtle scope, dude (~A)" *self*))
398 (setf (turtle-xcor *self*) (wrap-x *topology* x))
399 (setf (turtle-ycor *self*) (wrap-y *topology* y)))
404 ARGUMENTS AND VALUES:
406 N: a double, the amount the turtle moves forward
411 Moves the current turtle forward N steps, one step at a time.
413 This moves forward one at a time in order to make the view updates look
414 good in the case of a purposefully slow running instance. If the number
415 is negative, the turtle moves backward.
417 If the current agent is not a turtle, it raises an error.
419 See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#forward"
420 (when (not (turtle-p *self*)) (error "Gotta call fd in turtle scope, dude (~A)" *self*))
424 ((< (abs i) 3.2e-15) nil)
425 ((< (abs i) 1d0) (jump i))
426 (t (jump (if (> i 0d0) 1d0 -1d0)) (internal (- i (if (> i 0d0) 1d0 -1d0)))))))
429 (defun turn-right (n)
430 "TURN-RIGHT N => RESULT
432 ARGUMENTS AND VALUES:
434 N: a double, the amount the turtle turns
439 The turtle turns right by number degrees. (If number is negative, it turns left.)
441 See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#right"
442 (when (not (turtle-p *self*)) (error "Gotta call fd in turtle scope, dude (~A)" *self*))
444 ((new-heading (+ (turtle-heading *self*) n)))
445 (setf (turtle-heading *self*)
447 ((< new-heading 0) (+ (mod new-heading -360) 360))
448 ((>= new-heading 360) (mod new-heading 360))
452 "TURN-LEFT N => RESULT
454 ARGUMENTS AND VALUES:
456 N: a double, the amount the turtle turns
461 The turtle turns left by number degrees. (If number is negative, it turns right.)
463 See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#right"
466 (defun create-turtles (n &optional fn)
467 "CREATE-TURTLES N &optional FN => RESULT
469 ARGUMENTS AND VALUES:
471 N: an integer, the numbers of turtles to create
472 FN: A function, applied to each turtle after creation
477 Creates number new turtles at the origin.
479 New turtles have random integer headings and the color is randomly selected
480 from the 14 primary colors. If a function is supplied, the new turtles
483 See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#create-turtles"
485 ((new-turtles (loop :repeat n :collect (create-turtle))))
486 (when fn (ask (list->agentset new-turtles :turtles) fn))))
488 (defun reset-ticks ()
489 "RESET-TICKS => RESULT
491 ARGUMENTS AND VALUES:
497 Resets the tick counter to zero, sets up all plots, then updates all plots.
499 See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#reset-ticks"
503 "RESET-TICKS => RESULT
505 ARGUMENTS AND VALUES:
511 Advances the tick counter by one and updates all plots.
513 If the tick counter has not been started yet with reset-ticks, an error results.
515 See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#tick"
517 (when (not *ticks*) (error "reset-ticks must be called"))
521 "TICKS => CURRENT-TICKS
523 ARGUMENTS AND VALUES:
525 CURRENT-TICKS: A positiv double, representing the current number of ticks
529 Reports the current value of the tick counter. The result is always a number and never negative.
531 If the tick counter has not been started yet with reset-ticks, an error results.
533 See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#ticks"
534 (when (not *ticks*) (error "reset-ticks must be called"))
537 (defun create-world (&key dims)
538 "CREATE-WORLD &key DIMS => RESULT
540 DIMS: (:xmin XMIN :xmax XMAX :ymin YMIN :ymax YMAX)
542 ARGUMENTS AND VALUES:
545 XMIN: An integer representing the minimum patch coord in X
546 XMAX: An integer representing the maximum patch coord in X
547 YMIN: An integer representing the minimum patch coord in Y
548 YMAX: An integer representing the maximum patch coord in Y
552 Initializes the world in the NVM.
554 This should be called before using the engine in any real capacity. If
555 called when an engine is already running, it may do somethign weird."
556 (setf *dimensions* dims)
560 :for y :from (max-pycor) :downto (min-pycor)
562 :for x :from (min-pxcor) :to (max-pxcor)
564 :xcor (coerce x 'double-float)
565 :ycor (coerce y 'double-float)
568 (setf *current-id* 0))
570 ; These match netlogo's dump
571 (defgeneric dump-object (o))
573 (defmethod dump-object ((n double-float))
574 (multiple-value-bind (int rem) (floor n)
576 (format nil "~A" int)
578 ((output (format nil "~D" n)))
579 ; Someday we'll have d<posint>, but this is not that day!
580 (cl-ppcre:regex-replace "d-" (cl-ppcre:regex-replace "d0" output "") "E-")))))
582 (defmethod dump-object ((o string)) (format nil "~A" (cl-ppcre:regex-replace-all "\"" (format nil "~S" o) "\"\"")))
584 (defmethod dump-object ((o (eql t))) "true")
585 (defmethod dump-object ((o (eql nil))) "false")
587 (defmethod dump-object ((o list))
589 ((agentset-p o) (format nil "(agentset, ~A ~A)" (dump-object (count o)) (string-downcase (agentset-breed o))))
590 (t (format nil "[~{~A~^ ~}]" (mapcar #'dump-object o)))))
592 (defmethod dump-object ((o patch))
593 (format nil "(patch ~A ~A)" (dump-object (patch-xcor o)) (dump-object (patch-ycor o))))
595 (defmethod dump-object ((o turtle)) (format nil "(turtle ~A)" (dump-object (turtle-who o))))
596 (defmethod dump-object ((o (eql :nobody))) (format nil "nobody"))
598 (defun current-state ()
599 "CURRENT-STATE => WORLD-STATE
601 ARGUMENTS AND VALUES:
603 WORLD-STATE: A list, the current state of the whole world
607 Dumps out the state of the world.
609 This is useful for visualizations and also storing in a common lisp
610 data structure for easy usage in a common lisp instance. It's preferable
611 to use this when working with the nvm than the output done by export-world.
613 Currently this only dumps out turtle and patch information.
615 This is called CURRENT-STATE because export-world is an actual primitive
621 :color (turtle-color turtle)
622 :xcor (turtle-xcor turtle)
623 :ycor (turtle-ycor turtle)
624 :heading (turtle-heading turtle)
625 :size (turtle-size turtle)))
630 :color (patch-color patch)
631 :xcor (patch-xcor patch)
632 :ycor (patch-ycor patch)))
635 (defun export-turtles ()
640 "\"who\",\"color\",\"heading\",\"xcor\",\"ycor\",\"shape\",\"label\",\"label-color\","
641 "\"breed\",\"hidden?\",\"size\",\"pen-size\",\"pen-mode\""))
645 "\"~A\",\"~A\",\"~A\",\"~A\",\"~A\",\"\"\"default\"\"\",\"~A\",\"~A\",\"{all-turtles}\",\"false\",\"~A\",~A"
646 (dump-object (turtle-who turtle))
647 (dump-object (turtle-color turtle))
648 (dump-object (turtle-heading turtle))
649 (dump-object (turtle-xcor turtle))
650 (dump-object (turtle-ycor turtle))
651 (dump-object (turtle-label turtle))
652 (dump-object (turtle-label-color turtle))
653 (dump-object (turtle-size turtle))
654 "\"1\",\"\"\"up\"\"\""))
657 (defun export-patches ()
661 "\"pxcor\",\"pycor\",\"pcolor\",\"plabel\",\"plabel-color\"")
665 "\"~A\",\"~A\",\"~A\",\"\"\"\"\"\",\"9.9\""
666 (dump-object (patch-xcor patch))
667 (dump-object (patch-ycor patch))
668 (dump-object (patch-color patch))))
671 (defun export-world ()
672 "EXPORT-WORLD => WORLD-CSV
674 ARGUMENTS AND VALUES:
676 WORLD-CSV: A string, the csv of the world
680 Dumps out a csv matching NetLogo's export world.
682 This is useful for serializing the current state of the engine in order
683 to compare against NetLogo or to reimport later. Contains everything needed
684 to boot up a NetLogo instance in the exact same state."
685 (format nil "~{~A~%~}"
687 (format nil "~S" "RANDOM STATE")
688 (format nil "~S" (clnl-random:export))
690 (format nil "~S" "GLOBALS")
692 "\"min-pxcor\",\"max-pxcor\",\"min-pycor\",\"max-pycor\",\"perspective\",\"subject\","
693 "\"nextIndex\",\"directed-links\",\"ticks\",")
694 (format nil "\"~A\",\"~A\",\"~A\",\"~A\",\"0\",\"nobody\",\"~A\",\"\"\"NEITHER\"\"\",\"-1\""
695 (min-pxcor) (max-pxcor) (min-pycor) (max-pycor) *current-id*)
697 (format nil "~{~A~^~%~}" (export-turtles))
699 (format nil "~{~A~^~%~}" (export-patches))
701 (format nil "~S" "LINKS")
702 "\"end1\",\"end2\",\"color\",\"label\",\"label-color\",\"hidden?\",\"breed\",\"thickness\",\"shape\",\"tie-mode\""