1 (in-package #:clnl-nvm)
3 (defun lookup-color (color)
4 "LOOKUP-COLOR COLOR => COLOR-NUMBER
8 COLOR: a symbol representing a color
9 COLOR-NUMBER: the NetLogo color integer
13 Returns the number used to represent colors in NetLogo.
15 See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#Constants"
34 (defun create-turtle (breed &optional base-turtle)
36 ((breed (or breed (and base-turtle (turtle-breed base-turtle)) :turtles))
37 (new-turtle (make-turtle
38 :who (coerce *current-id* 'double-float)
39 :color (if base-turtle
40 (turtle-color base-turtle)
41 (coerce (+ 5 (* 10 (clnl-random:next-int 14))) 'double-float))
42 :heading (if base-turtle
43 (turtle-heading base-turtle)
44 (coerce (clnl-random:next-int 360) 'double-float))
45 :label-color (if base-turtle (turtle-label-color base-turtle) 9.9d0)
46 :size (if base-turtle (turtle-size base-turtle) 1d0)
48 :shape (breed-default-shape breed)
49 :xcor (if base-turtle (turtle-xcor base-turtle) 0d0)
50 :ycor (if base-turtle (turtle-ycor base-turtle) 0d0)
51 :own-vars (when base-turtle (copy-list (turtle-own-vars base-turtle))))))
53 ((patch (patch-at (turtle-xcor new-turtle) (turtle-ycor new-turtle))))
54 (setf (patch-turtles patch) (nconc (patch-turtles patch) (list new-turtle))))
55 (setf *turtles* (nconc *turtles* (list new-turtle)))
59 (defun shufflerator (agentset-list)
61 ((copy (copy-list agentset-list))
67 ((idx (when (< i (1- (length copy))) (+ i (clnl-random:next-int (- (length copy) i))))))
68 (when idx (setf agent (nth idx copy)))
69 (when idx (setf (nth idx copy) (nth i copy)))
71 (when (and (<= i (length copy)) (turtle-p agent) (= -1 (turtle-who agent))) (fetch)))))
72 (fetch) ; we pre-fetch because netlogo does, rng sync hype!
75 ((> i (length copy)) nil)
76 ((= i (length copy)) (incf i) (car (last copy)))
77 (t (let ((result agent)) (fetch) result)))))))
79 (defcommand create-world (&key dims globals turtles-own-vars patches-own-vars breeds)
80 "CREATE-WORLD &key DIMS GLOBALS TURTLES-OWN-VARS PATCHES-OWN-VARS BREEDS => RESULT
82 DIMS: (:xmin XMIN :xmax XMAX :ymin YMIN :ymax YMAX)
84 TURTLES-OWN-VARS: TURTLES-OWN-VAR*
85 PATCHES-OWN-VARS: PATCHES-OWN-VAR*
88 GLOBAL: (GLOBAL-NAME GLOBAL-ACCESS-FUNC)
92 XMIN: An integer representing the minimum patch coord in X
93 XMAX: An integer representing the maximum patch coord in X
94 YMIN: An integer representing the minimum patch coord in Y
95 YMAX: An integer representing the maximum patch coord in Y
96 TURTLES-OWN-VAR: Symbol for the turtles own variable in the keyword package
97 PATCHES-OWN-VAR: Symbol for the patches own variable in the keyword package
98 BREED: A list of symbols representing the possible preeds
99 GLOBAL-NAME: Symbol for the global in the keyword package
100 GLOBAL-ACCESS-FUNC: Function to get the value of the global
104 Initializes the world in the NVM.
106 This should be called before using the engine in any real capacity. If
107 called when an engine is already running, it may do somethign weird."
108 (setf *turtles-own-vars* turtles-own-vars)
109 (setf *patches-own-vars* patches-own-vars)
110 (setf *dimensions* dims)
111 (setf *globals* globals)
114 (list (list :turtles "default"))
115 (mapcar (lambda (breed) (list breed "default")) breeds)))
120 (defun current-state ()
121 "CURRENT-STATE => WORLD-STATE
123 ARGUMENTS AND VALUES:
125 WORLD-STATE: A list, the current state of the whole world
129 Dumps out the state of the world.
131 This is useful for visualizations and also storing in a common lisp
132 data structure for easy usage in a common lisp instance. It's preferable
133 to use this when working with the nvm than the output done by export-world.
135 Currently this only dumps out turtle and patch information.
137 This is called CURRENT-STATE because export-world is an actual primitive
143 :color (turtle-color turtle)
144 :xcor (turtle-xcor turtle)
145 :ycor (turtle-ycor turtle)
146 :heading (turtle-heading turtle)
147 :shape (turtle-shape turtle)
148 :size (turtle-size turtle)))
153 :color (patch-color patch)
154 :xcor (patch-xcor patch)
155 :ycor (patch-ycor patch)))
158 ; These match netlogo's dump
159 (defgeneric dump-object (o))
161 (defmethod dump-object ((n double-float))
162 (multiple-value-bind (int rem) (floor n)
164 (format nil "~A" int)
166 ((output (format nil "~D" n)))
167 ; Someday we'll have d<posint>, but this is not that day!
168 (cl-ppcre:regex-replace "d-" (cl-ppcre:regex-replace "d0" output "") "E-")))))
170 (defmethod dump-object ((o string)) (format nil "~A" (cl-ppcre:regex-replace-all "\"" (format nil "~S" o) "\"\"")))
172 (defmethod dump-object ((o (eql t))) "true")
173 (defmethod dump-object ((o (eql nil))) "false")
175 (defmethod dump-object ((o list))
177 ((agentset-p o) (format nil "(agentset, ~A ~A)" (dump-object (count o)) (string-downcase (agentset-breed o))))
178 (t (format nil "[~{~A~^ ~}]" (mapcar #'dump-object o)))))
180 (defmethod dump-object ((o patch))
181 (format nil "(patch ~A ~A)" (dump-object (patch-xcor o)) (dump-object (patch-ycor o))))
183 (defmethod dump-object ((o turtle)) (format nil "(turtle ~A)" (dump-object (turtle-who o))))
184 (defmethod dump-object ((o (eql :nobody))) (format nil "nobody"))
185 (defmethod dump-object ((o (eql :turtles))) (format nil "{all-turtles}"))
186 (defmethod dump-object ((o symbol))
188 ((find o *breeds* :key #'car) (format nil "{breed ~(~A~)}" o))
189 (t (error "Keyword unrecognized by dump object: ~A" o))))