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 (&optional base-turtle)
53 ((new-turtle (make-turtle
54 :who (coerce *current-id* 'double-float)
55 :color (if base-turtle
56 (turtle-color base-turtle)
57 (coerce (+ 5 (* 10 (clnl-random:next-int 14))) 'double-float))
58 :heading (if base-turtle
59 (turtle-heading base-turtle)
60 (coerce (clnl-random:next-int 360) 'double-float))
61 :shape (breed-default-shape :turtles)
62 :xcor (if base-turtle (turtle-xcor base-turtle) 0d0)
63 :ycor (if base-turtle (turtle-ycor base-turtle) 0d0))))
64 (setf *turtles* (nconc *turtles* (list new-turtle)))
73 RESULT: undefined, commands don't return
77 The turtle or link dies
79 A dead agent ceases to exist. The effects of this include:
80 - The agent will not execute any further code.
81 - The agent will disappear from any agentsets it was in, reducing the size of those agentsets by one.
82 - Any variable that was storing the agent will now instead have nobody in it.
83 - If the dead agent was a turtle, every link connected to it also dies.
84 - If the observer was watching or following the agent, the observer's perspective resets.
86 See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#die"
87 (when (not (turtle-p *self*)) (error "Gotta call die in turtle scope, dude (~A)" *self*))
88 (setf (turtle-who *self*) -1)
89 (setf *turtles* (remove *self* *turtles*)))
92 "PATCHES => ALL-PATCHES
96 ALL-PATCHES: a NetLogo agentset, all patches
100 Reports the agentset consisting of all the patches.
102 This agentset is special in that it represents the living patches
103 each time it's used, so changes depending on the state of the engine.
105 See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#patches"
109 "TURTLES => ALL-TURTLES
111 ARGUMENTS AND VALUES:
113 ALL-TURTLES: a NetLogo agentset, all turtles
117 Reports the agentset consisting of all the turtles.
119 This agentset is special in that it represents the living turtles
120 each time it's used, so changes depending on the state of the engine.
122 See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#turtles"
125 (defun ask (agent-or-agentset fn)
126 "ASK AGENT-OR-AGENTSET FN => RESULT
128 AGENT-OR-AGENTSET: AGENT | AGENTSET
130 ARGUMENTS AND VALUES:
132 FN: a function, run on each agent
133 RESULT: undefined, commands don't return
134 AGENT: a NetLogo agent
135 AGENTSET: a NetLogo agentset
139 ASK is equivalent to ask in NetLogo.
141 The specified AGENTSET or AGENT runs the given FN. In the case of an
142 AGENTSET, the order in which the agents are run is random each time,
143 and only agents that are in the set at the beginning of the call.
145 See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#ask"
147 ((agentset-p agent-or-agentset)
149 ((iter (shufflerator (agentset-list agent-or-agentset))))
151 :for agent := (funcall iter)
153 :do (let ((*myself* *self*) (*self* agent)) (with-stop-handler (funcall fn))))))
154 ((agent-p agent-or-agentset)
155 (let ((*myself* *self*) (*self* agent-or-agentset)) (with-stop-handler (funcall fn))))
157 (error "Ask requires an agentset or agent but got: ~A" agent-or-agentset))))
159 (defun count (agentset)
162 ARGUMENTS AND VALUES:
164 AGENTSET: a NetLogo agentset
169 COUNT is equivalent to count in NetLogo. Returns N, the number of
172 See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#count"
173 (coerce (length (agentset-list agentset)) 'double-float))
178 ARGUMENTS AND VALUES:
184 Clears ticks, turtles, patches, globals (unimplemented).
186 See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#clear-all"
194 ARGUMENTS AND VALUES:
200 As of yet, this does nothing. A placeholder method for forced dipslay
201 updates from the engine.
203 See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#display"
209 ARGUMENTS AND VALUES:
215 Returns from the current stop block, which will halt the currently running
216 thing, be that the program, current ask block, or procedure. Stop has odd
217 semantics that are best gleaned from the actual NetLogo manual.
219 See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#stop"
220 (error (make-condition 'stop)))
222 (defun of (fn agent-or-agentset)
223 "OF FN AGENT-OR-AGENTSET => RESULT
225 AGENT-OR-AGENTSET: AGENT | AGENTSET
226 RESULT: RESULT-LIST | RESULT-VALUE
228 ARGUMENTS AND VALUES:
230 FN: a function, run on each agent
231 AGENT: a NetLogo agent
232 AGENTSET: a NetLogo agentset
234 RESULT-VALUE: a single value
238 OF is equivalent to of in NetLogo.
240 The specified AGENTSET or AGENT runs the given FN. In the case of an
241 AGENTSET, the order in which the agents are run is random each time,
242 and only agents that are in the set at the beginning of the call.
244 RESULT-LIST is returned when the input is an AGENTSET, but RESULT-VALUE
245 is returned when only passed an AGENT.
247 See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#of"
249 ((agentset-p agent-or-agentset)
251 ((iter (shufflerator (agentset-list agent-or-agentset))))
253 :for agent := (funcall iter)
255 :collect (let ((*myself* *self*) (*self* agent)) (funcall fn)))))
256 ((agent-p agent-or-agentset)
257 (let ((*myself* *self*) (*self* agent-or-agentset)) (funcall fn)))
259 (error "Of requires an agentset or agent but got: ~A" agent-or-agentset))))
261 (defun with (agentset fn)
262 "WITH AGENTSET FN => RESULT-AGENTSET
264 ARGUMENTS AND VALUES:
266 AGENTSET: a NetLogo agentset
267 FN: a boolean function, run on each agent to determine if included
268 RESULT-AGENTSET: an agentset of valid agents
272 WITH is equivalent to with in NetLogo.
274 Returns a new agentset containing only those agents that reported true
277 See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#with"
281 (let ((*myself* *self*) (*self* agent)) (funcall fn)))
282 (agentset-list agentset))
283 (agentset-breed agentset)))
285 (defun shufflerator (agentset-list)
287 ((copy (copy-list agentset-list))
293 ((idx (when (< i (1- (length copy))) (+ i (clnl-random:next-int (- (length copy) i))))))
294 (when idx (setf agent (nth idx copy)))
295 (when idx (setf (nth idx copy) (nth i copy)))
297 (fetch) ; we pre-fetch because netlogo does, rng sync hype!
300 ((> i (length copy)) nil)
301 ((= i (length copy)) (incf i) (car (last copy)))
302 (t (let ((result agent)) (fetch) result)))))))
304 (defun random-float (n)
305 "RANDOM-FLOAT N => RANDOM-NUMBER
307 ARGUMENTS AND VALUES:
309 N: a double, the upper bound of the random float
310 RANDOM-NUMBER: a double, the random result
314 Returns a random number strictly closer to zero than N.
316 If number is positive, returns a random floating point number greater than
317 or equal to 0 but strictly less than number.
319 If number is negative, returns a random floating point number less than or equal
320 to 0, but strictly greater than number.
322 If number is zero, the result is always 0.
324 See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#random-float"
325 (clnl-random:next-double n))
328 "RANDOM N => RANDOM-NUMBER
330 ARGUMENTS AND VALUES:
332 N: an integer, the upper bound of the random
333 RANDOM-NUMBER: an integer, the random result
337 Returns a random number strictly closer to zero than N.
339 If number is positive, returns a random integer greater than or equal to 0,
340 but strictly less than number.
342 If number is negative, returns a random integer less than or equal to 0,
343 but strictly greater than number.
345 If number is zero, the result is always 0.
347 See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#random"
348 (coerce (clnl-random:next-long (truncate n)) 'double-float))
350 (defun random-xcor ()
351 "RANDOM-XCOR => RANDOM-NUMBER
353 ARGUMENTS AND VALUES:
355 RANDOM-NUMBER: a float, the random result
359 Returns a random floating point number in the allowable range of turtle
360 coordinates along the x axis.
362 These range from min-pxcor - 0.5 (inclusive) to max-pxcor + 0.5 (exclusive)
364 See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#random-cor"
366 ((min (- (min-pxcor) 0.5d0))
367 (max (+ (max-pxcor) 0.5d0)))
368 (+ min (clnl-random:next-double (- max min)))))
370 (defun random-ycor ()
371 "RANDOM-YCOR => RANDOM-NUMBER
373 ARGUMENTS AND VALUES:
375 RANDOM-NUMBER: a float, the random result
379 Returns a random floating point number in the allowable range of turtle
380 coordinates along the y axis.
382 These range from min-pycor - 0.5 (inclusive) to max-pycor + 0.5 (exclusive)
384 See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#random-cor"
386 ((min (- (min-pycor) 0.5d0))
387 (max (+ (max-pycor) 0.5d0)))
388 (+ min (clnl-random:next-double (- max min)))))
390 (defun one-of (list-or-agentset)
391 "ONE-OF LIST-OR-AGENTSET => RESULT
393 LIST-OR-AGENTSET: LIST | AGENTSET
394 RESULT: RANDOM-VALUE | RANDOM-AGENT | :nobody
396 ARGUMENTS AND VALUES:
399 AGENTSET: An agent set
400 RANDOM-VALUE: a value in LIST
401 RANDOM-AGENT: an agent if AGENTSET is non empty
405 From an AGENTSET, returns a RANDOM-AGENT. If the agentset is empty, returns :nobody.
406 From a list, returns a RANDOM-VALUE. If the list is empty, an error occurs.
408 See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#one-of"
410 ((agentset-p list-or-agentset)
412 ((agentset-list (agentset-list list-or-agentset))
413 (length (length agentset-list)))
414 (if (zerop length) :nobody (nth (clnl-random:next-int length) agentset-list))))
415 ((listp list-or-agentset)
417 ((length (length list-or-agentset)))
419 (error "one-of requires a nonempty list")
420 (nth (clnl-random:next-int length) list-or-agentset))))
421 (t (error "one-of requires a list or agentset"))))
424 (when (not (turtle-p *self*)) (error "Gotta call jump in turtle scope, dude (~A)" *self*))
428 (+ (turtle-xcor *self*) (* n (using-cached-sin (turtle-heading *self*))))))
432 (+ (turtle-ycor *self*) (* n (using-cached-cos (turtle-heading *self*)))))))
437 ARGUMENTS AND VALUES:
445 Sets the x-coordinate and y-coordinate for the turle. Equivalent to
446 set xcor x set ycor y, except it happens in one step inside of two.
448 See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#setxy"
449 (when (not (turtle-p *self*)) (error "Gotta call setxy in turtle scope, dude (~A)" *self*))
450 (setf (turtle-xcor *self*) (wrap-x *topology* x))
451 (setf (turtle-ycor *self*) (wrap-y *topology* y)))
453 (defun set-default-shape (breed shape)
454 "SET-DEFAULT-SHAPE BREED SHAPE => RESULT
456 ARGUMENTS AND VALUES:
464 Specifies a default initial shape for a BREED. When a turtle, or it changes breeds,
465 its shape is set to the given shape.
467 SET-DEFAULT-SHAPE doesn't affect existing agents, only agents you create afterwards.
469 See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#set-default-shape"
470 (when (not (breed-p breed)) (error "Need a valid breed"))
471 (setf (breed-default-shape breed) shape))
476 ARGUMENTS AND VALUES:
478 N: a double, the amount the turtle moves forward
483 Moves the current turtle forward N steps, one step at a time.
485 This moves forward one at a time in order to make the view updates look
486 good in the case of a purposefully slow running instance. If the number
487 is negative, the turtle moves backward.
489 If the current agent is not a turtle, it raises an error.
491 See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#forward"
492 (when (not (turtle-p *self*)) (error "Gotta call fd in turtle scope, dude (~A)" *self*))
496 ((< (abs i) 3.2e-15) nil)
497 ((< (abs i) 1d0) (jump i))
498 (t (jump (if (> i 0d0) 1d0 -1d0)) (internal (- i (if (> i 0d0) 1d0 -1d0)))))))
501 (defun turn-right (n)
502 "TURN-RIGHT N => RESULT
504 ARGUMENTS AND VALUES:
506 N: a double, the amount the turtle turns
511 The turtle turns right by number degrees. (If number is negative, it turns left.)
513 See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#right"
514 (when (not (turtle-p *self*)) (error "Gotta call fd in turtle scope, dude (~A)" *self*))
516 ((new-heading (+ (turtle-heading *self*) n)))
517 (setf (turtle-heading *self*)
519 ((< new-heading 0) (+ (mod new-heading -360) 360))
520 ((>= new-heading 360) (mod new-heading 360))
524 "TURN-LEFT N => RESULT
526 ARGUMENTS AND VALUES:
528 N: a double, the amount the turtle turns
533 The turtle turns left by number degrees. (If number is negative, it turns right.)
535 See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#right"
538 (defun create-turtles (n &optional fn)
539 "CREATE-TURTLES N &optional FN => RESULT
541 ARGUMENTS AND VALUES:
543 N: an integer, the numbers of turtles to create
544 FN: A function, applied to each turtle after creation
549 Creates number new turtles at the origin.
551 New turtles have random integer headings and the color is randomly selected
552 from the 14 primary colors. If a function is supplied, the new turtles
555 See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#create-turtles"
557 ((new-turtles (loop :repeat n :collect (create-turtle))))
558 (when fn (ask (list->agentset new-turtles :turtles) fn))))
560 (defun hatch (n &optional fn)
561 "HATCH N &optional FN => RESULT
563 ARGUMENTS AND VALUES:
565 N: an integer, the numbers of turtles to hatch
566 FN: A function, applied to each turtle after creation
571 The turtle in *self* creates N new turtles. Each new turtle inherits of all its
572 variables, including its location, from self.
574 If FN is supplied, the new turtles immediately run it.
576 See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#hatch"
577 (when (not (turtle-p *self*)) (error "Can only hatch from turtle scope"))
579 ((new-turtles (loop :repeat n :collect (create-turtle *self*))))
580 (when fn (ask (list->agentset new-turtles :turtles) fn))))
582 (defun reset-ticks ()
583 "RESET-TICKS => RESULT
585 ARGUMENTS AND VALUES:
591 Resets the tick counter to zero, sets up all plots, then updates all plots.
593 See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#reset-ticks"
597 "RESET-TICKS => RESULT
599 ARGUMENTS AND VALUES:
605 Advances the tick counter by one and updates all plots.
607 If the tick counter has not been started yet with reset-ticks, an error results.
609 See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#tick"
611 (when (not *ticks*) (error "reset-ticks must be called"))
615 "TICKS => CURRENT-TICKS
617 ARGUMENTS AND VALUES:
619 CURRENT-TICKS: A positiv double, representing the current number of ticks
623 Reports the current value of the tick counter. The result is always a number and never negative.
625 If the tick counter has not been started yet with reset-ticks, an error results.
627 See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#ticks"
628 (when (not *ticks*) (error "reset-ticks must be called"))
631 (defun clear-patches ()
635 :for y :from (max-pycor) :downto (min-pycor)
637 :for x :from (min-pxcor) :to (max-pxcor)
639 :xcor (coerce x 'double-float)
640 :ycor (coerce y 'double-float)
643 (defun clear-turtles ()
645 (setf *current-id* 0))
647 (defun clear-ticks ()
650 (defun create-world (&key dims)
651 "CREATE-WORLD &key DIMS => RESULT
653 DIMS: (:xmin XMIN :xmax XMAX :ymin YMIN :ymax YMAX)
655 ARGUMENTS AND VALUES:
658 XMIN: An integer representing the minimum patch coord in X
659 XMAX: An integer representing the maximum patch coord in X
660 YMIN: An integer representing the minimum patch coord in Y
661 YMAX: An integer representing the maximum patch coord in Y
665 Initializes the world in the NVM.
667 This should be called before using the engine in any real capacity. If
668 called when an engine is already running, it may do somethign weird."
669 (setf *dimensions* dims)
670 (setf *breeds* (list (list :turtles "default")))
675 ; These match netlogo's dump
676 (defgeneric dump-object (o))
678 (defmethod dump-object ((n double-float))
679 (multiple-value-bind (int rem) (floor n)
681 (format nil "~A" int)
683 ((output (format nil "~D" n)))
684 ; Someday we'll have d<posint>, but this is not that day!
685 (cl-ppcre:regex-replace "d-" (cl-ppcre:regex-replace "d0" output "") "E-")))))
687 (defmethod dump-object ((o string)) (format nil "~A" (cl-ppcre:regex-replace-all "\"" (format nil "~S" o) "\"\"")))
689 (defmethod dump-object ((o (eql t))) "true")
690 (defmethod dump-object ((o (eql nil))) "false")
692 (defmethod dump-object ((o list))
694 ((agentset-p o) (format nil "(agentset, ~A ~A)" (dump-object (count o)) (string-downcase (agentset-breed o))))
695 (t (format nil "[~{~A~^ ~}]" (mapcar #'dump-object o)))))
697 (defmethod dump-object ((o patch))
698 (format nil "(patch ~A ~A)" (dump-object (patch-xcor o)) (dump-object (patch-ycor o))))
700 (defmethod dump-object ((o turtle)) (format nil "(turtle ~A)" (dump-object (turtle-who o))))
701 (defmethod dump-object ((o (eql :nobody))) (format nil "nobody"))
703 (defun current-state ()
704 "CURRENT-STATE => WORLD-STATE
706 ARGUMENTS AND VALUES:
708 WORLD-STATE: A list, the current state of the whole world
712 Dumps out the state of the world.
714 This is useful for visualizations and also storing in a common lisp
715 data structure for easy usage in a common lisp instance. It's preferable
716 to use this when working with the nvm than the output done by export-world.
718 Currently this only dumps out turtle and patch information.
720 This is called CURRENT-STATE because export-world is an actual primitive
726 :color (turtle-color turtle)
727 :xcor (turtle-xcor turtle)
728 :ycor (turtle-ycor turtle)
729 :heading (turtle-heading turtle)
730 :size (turtle-size turtle)))
735 :color (patch-color patch)
736 :xcor (patch-xcor patch)
737 :ycor (patch-ycor patch)))
740 (defun export-turtles ()
745 "\"who\",\"color\",\"heading\",\"xcor\",\"ycor\",\"shape\",\"label\",\"label-color\","
746 "\"breed\",\"hidden?\",\"size\",\"pen-size\",\"pen-mode\""))
750 "\"~A\",\"~A\",\"~A\",\"~A\",\"~A\",\"~A\",\"~A\",\"~A\",\"{all-turtles}\",\"false\",\"~A\",~A"
751 (dump-object (turtle-who turtle))
752 (dump-object (turtle-color turtle))
753 (dump-object (turtle-heading turtle))
754 (dump-object (turtle-xcor turtle))
755 (dump-object (turtle-ycor turtle))
756 (dump-object (turtle-shape turtle))
757 (dump-object (turtle-label turtle))
758 (dump-object (turtle-label-color turtle))
759 (dump-object (turtle-size turtle))
760 "\"1\",\"\"\"up\"\"\""))
763 (defun export-patches ()
767 "\"pxcor\",\"pycor\",\"pcolor\",\"plabel\",\"plabel-color\"")
771 "\"~A\",\"~A\",\"~A\",\"\"\"\"\"\",\"9.9\""
772 (dump-object (patch-xcor patch))
773 (dump-object (patch-ycor patch))
774 (dump-object (patch-color patch))))
777 (defun export-world ()
778 "EXPORT-WORLD => WORLD-CSV
780 ARGUMENTS AND VALUES:
782 WORLD-CSV: A string, the csv of the world
786 Dumps out a csv matching NetLogo's export world.
788 This is useful for serializing the current state of the engine in order
789 to compare against NetLogo or to reimport later. Contains everything needed
790 to boot up a NetLogo instance in the exact same state."
791 (format nil "~{~A~%~}"
793 (format nil "~S" "RANDOM STATE")
794 (format nil "~S" (clnl-random:export))
796 (format nil "~S" "GLOBALS")
798 "\"min-pxcor\",\"max-pxcor\",\"min-pycor\",\"max-pycor\",\"perspective\",\"subject\","
799 "\"nextIndex\",\"directed-links\",\"ticks\",")
800 (format nil "\"~A\",\"~A\",\"~A\",\"~A\",\"0\",\"nobody\",\"~A\",\"\"\"NEITHER\"\"\",\"-1\""
801 (min-pxcor) (max-pxcor) (min-pycor) (max-pycor) *current-id*)
803 (format nil "~{~A~^~%~}" (export-turtles))
805 (format nil "~{~A~^~%~}" (export-patches))
807 (format nil "~S" "LINKS")
808 "\"end1\",\"end2\",\"color\",\"label\",\"label-color\",\"hidden?\",\"breed\",\"thickness\",\"shape\",\"tie-mode\""