(in-package #:clnl-nvm)
-; Implementations of all the things the nvm can do.
-
-(defun show (value)
- "SHOW VALUE => RESULT
-
-ARGUMENTS AND VALUES:
-
- VALUE: a NetLogo value
- RESULT: undefined
-
-DESCRIPTION:
-
- A command that prints the given NetLogo value to the command center.
-
- See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#show"
- (format t "Showing: ~A~%" (dump-object value)))
-
(defun lookup-color (color)
"LOOKUP-COLOR COLOR => COLOR-NUMBER
(:magenta 125d0)
(:pink 135d0)))
-(defun create-turtle ()
- (setf
- *turtles*
- (nconc
- *turtles*
- (list
- (make-turtle
- :who (coerce *current-id* 'double-float)
- :color (coerce (+ 5 (* 10 (clnl-random:next-int 14))) 'double-float)
- :heading (coerce (clnl-random:next-int 360) 'double-float)
- :xcor 0d0
- :ycor 0d0))))
- (incf *current-id*))
-
-(defun die ()
- "DIE => RESULT
-
-ARGUMENTS AND VALUES:
-
- RESULT: undefined, commands don't return
-
-DESCRIPTION:
-
- The turtle or link dies
-
- A dead agent ceases to exist. The effects of this include:
- - The agent will not execute any further code.
- - The agent will disappear from any agentsets it was in, reducing the size of those agentsets by one.
- - Any variable that was storing the agent will now instead have nobody in it.
- - If the dead agent was a turtle, every link connected to it also dies.
- - If the observer was watching or following the agent, the observer's perspective resets.
-
- See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#die"
- (when (not (turtle-p *self*)) (error "Gotta call die in turtle scope, dude (~A)" *self*))
- (setf (turtle-who *self*) -1)
- (setf *turtles* (remove *self* *turtles*)))
-
-(defun patches ()
- "PATCHES => ALL-PATCHES
-
-ARGUMENTS AND VALUES:
-
- ALL-PATCHES: a NetLogo agentset, all patches
-
-DESCRIPTION:
-
- Reports the agentset consisting of all the patches.
-
- This agentset is special in that it represents the living patches
- each time it's used, so changes depending on the state of the engine.
-
- See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#patches"
- *patches*)
-
-(defun turtles ()
- "TURTLES => ALL-TURTLES
-
-ARGUMENTS AND VALUES:
-
- ALL-TURTLES: a NetLogo agentset, all turtles
-
-DESCRIPTION:
-
- Reports the agentset consisting of all the turtles.
-
- This agentset is special in that it represents the living turtles
- each time it's used, so changes depending on the state of the engine.
-
- See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#turtles"
- *turtles*)
-
-(defun ask (agent-set fn)
- "ASK AGENT-SET FN => RESULT
-
-ARGUMENTS AND VALUES:
-
- AGENT-SET: a NetLogo agentset
- FN: a function, run on each agent
- RESULT: undefined, commands don't return
-
-DESCRIPTION:
-
- ASK is equivalent to ask in NetLogo.
-
- The specified AGENT-SET runs the given FN. The order in which the agents
- are run is random each time, and only agents that are in the set at the
- beginning of the call.
-
- See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#ask"
- (let
- ((iter (shufflerator agent-set)))
- (loop
- :for agent := (funcall iter)
- :while agent
- :do (let ((*myself* *self*) (*self* agent)) (funcall fn)))))
-
-(defun of (fn agent-set)
- "OF FN AGENT-SET => RESULT
-
-ARGUMENTS AND VALUES:
-
- FN: a function, run on each agent
- AGENT-SET: a NetLogo agentset
- RESULT: a list
-
-DESCRIPTION:
-
- OF is equivalent to of in NetLogo.
-
- The specified AGENT-SET runs the given FN. The order in which the agents
- are run is random each time, and only agents that are in the set at the
- beginning of the call. A list is returned of the returned valuse of
- FN.
-
- See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#of"
- (let
- ((iter (shufflerator agent-set)))
- (loop
- :for agent := (funcall iter)
- :while agent
- :collect (let ((*myself* *self*) (*self* agent)) (funcall fn)))))
-
-(defun shufflerator (agent-set)
+(defun create-turtle (breed &optional base-turtle)
+ (let*
+ ((breed (or breed (and base-turtle (turtle-breed base-turtle)) :turtles))
+ (new-turtle (make-turtle
+ :who (coerce *current-id* 'double-float)
+ :color (if base-turtle
+ (turtle-color base-turtle)
+ (coerce (+ 5 (* 10 (clnl-random:next-int 14))) 'double-float))
+ :heading (if base-turtle
+ (turtle-heading base-turtle)
+ (coerce (clnl-random:next-int 360) 'double-float))
+ :label-color (if base-turtle (turtle-label-color base-turtle) 9.9d0)
+ :size (if base-turtle (turtle-size base-turtle) 1d0)
+ :breed breed
+ :shape (breed-default-shape breed)
+ :xcor (if base-turtle (turtle-xcor base-turtle) 0d0)
+ :ycor (if base-turtle (turtle-ycor base-turtle) 0d0)
+ :own-vars (when base-turtle (copy-list (turtle-own-vars base-turtle))))))
+ (let
+ ((patch (patch-at (turtle-xcor new-turtle) (turtle-ycor new-turtle))))
+ (setf (patch-turtles patch) (nconc (patch-turtles patch) (list new-turtle))))
+ (setf *turtles* (nconc *turtles* (list new-turtle)))
+ (incf *current-id*)
+ new-turtle))
+
+(defun shufflerator (agentset-list)
(let
- ((copy (copy-list agent-set))
+ ((copy (copy-list agentset-list))
(i 0)
(agent nil))
- (flet
+ (labels
((fetch ()
(let
((idx (when (< i (1- (length copy))) (+ i (clnl-random:next-int (- (length copy) i))))))
(when idx (setf agent (nth idx copy)))
(when idx (setf (nth idx copy) (nth i copy)))
- (incf i))))
+ (incf i)
+ (when (and (<= i (length copy)) (turtle-p agent) (= -1 (turtle-who agent))) (fetch)))))
(fetch) ; we pre-fetch because netlogo does, rng sync hype!
(lambda ()
(cond
((= i (length copy)) (incf i) (car (last copy)))
(t (let ((result agent)) (fetch) result)))))))
-(defun random-float (n)
- "RANDOM-FLOAT N => RANDOM-NUMBER
-
-ARGUMENTS AND VALUES:
-
- N: a double, the upper bound of the random float
- RANDOM-NUMBER: a double, the random result
-
-DESCRIPTION:
-
- Returns a random number strictly closer to zero than N.
-
- If number is positive, returns a random floating point number greater than
- or equal to 0 but strictly less than number.
-
- If number is negative, returns a random floating point number less than or equal
- to 0, but strictly greater than number.
-
- If number is zero, the result is always 0.
-
- See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#random-float"
- (clnl-random:next-double n))
-
-(defun jump (n)
- (when (not (turtle-p *self*)) (error "Gotta call fd in turtle scope, dude (~A)" *self*))
- (setf
- (turtle-xcor *self*)
- (wrap-x *topology*
- (+ (turtle-xcor *self*) (* n (using-cached-sin (turtle-heading *self*))))))
- (setf
- (turtle-ycor *self*)
- (wrap-y *topology*
- (+ (turtle-ycor *self*) (* n (using-cached-cos (turtle-heading *self*)))))))
-
-(defun forward (n)
- "FORWARD N => RESULT
-
-ARGUMENTS AND VALUES:
-
- N: a double, the amount the turtle moves forward
- RESULT: undefined
-
-DESCRIPTION:
-
- Moves the current turtle forward N steps, one step at a time.
-
- This moves forward one at a time in order to make the view updates look
- good in the case of a purposefully slow running instance. If the number
- is negative, the turtle moves backward.
-
- If the current agent is not a turtle, it raises an error.
-
- See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#forward"
- (when (not (turtle-p *self*)) (error "Gotta call fd in turtle scope, dude (~A)" *self*))
- (labels
- ((internal (i)
- (cond
- ((< (abs i) 3.2e-15) nil)
- ((< (abs i) 1d0) (jump i))
- (t (jump (if (> i 0d0) 1d0 -1d0)) (internal (- i (if (> i 0d0) 1d0 -1d0)))))))
- (internal n)))
-
-(defun turn-right (n)
- "TURN-RIGHT N => RESULT
-
-ARGUMENTS AND VALUES:
-
- N: a double, the amount the turtle turns
- RESULT: undefined
-
-DESCRIPTION:
-
- The turtle turns right by number degrees. (If number is negative, it turns left.)
-
- See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#right"
- (when (not (turtle-p *self*)) (error "Gotta call fd in turtle scope, dude (~A)" *self*))
- (let
- ((new-heading (+ (turtle-heading *self*) n)))
- (setf (turtle-heading *self*)
- (cond
- ((< new-heading 0) (+ (mod new-heading -360) 360))
- ((>= new-heading 360) (mod new-heading 360))
- (t new-heading)))))
-
-(defun turn-left (n)
- "TURN-LEFT N => RESULT
-
-ARGUMENTS AND VALUES:
-
- N: a double, the amount the turtle turns
- RESULT: undefined
-
-DESCRIPTION:
-
- The turtle turns left by number degrees. (If number is negative, it turns right.)
-
- See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#right"
- (turn-right (- n)))
-
-(defun create-turtles (n)
- "CREATE-TURTLES N => RESULT
-
-ARGUMENTS AND VALUES:
-
- N: an integer, the numbers of turtles to create
- RESULT: undefined
-
-DESCRIPTION:
-
- Creates number new turtles at the origin.
-
- New turtles have random integer headings and the color is randomly selected
- from the 14 primary colors. If commands are supplied, the new turtles
- immediately run them (unimplemented).
-
- See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#create-turtles"
- (loop :for i :from 1 :to n :do (create-turtle)))
-
-(defun reset-ticks ()
- "RESET-TICKS => RESULT
-
-ARGUMENTS AND VALUES:
-
- RESULT: undefined
-
-DESCRIPTION:
-
- Resets the tick counter to zero, sets up all plots, then updates all plots.
-
- See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#reset-ticks"
- (setf *ticks* 0d0))
-
-(defun tick ()
- "RESET-TICKS => RESULT
-
-ARGUMENTS AND VALUES:
-
- RESULT: undefined
-
-DESCRIPTION:
-
- Advances the tick counter by one and updates all plots.
-
- If the tick counter has not been started yet with reset-ticks, an error results.
-
- See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#tick"
-
- (when (not *ticks*) (error "reset-ticks must be called"))
- (incf *ticks*))
-
-(defun ticks ()
- "TICKS => CURRENT-TICKS
-
-ARGUMENTS AND VALUES:
-
- CURRENT-TICKS: A positiv double, representing the current number of ticks
-
-DESCRIPTION:
-
- Reports the current value of the tick counter. The result is always a number and never negative.
-
- If the tick counter has not been started yet with reset-ticks, an error results.
-
- See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#ticks"
- (when (not *ticks*) (error "reset-ticks must be called"))
- *ticks*)
-
-(defun create-world (&key dims)
- "CREATE-WORLD &key DIMS => RESULT
+(defcommand create-world (&key dims globals turtles-own-vars patches-own-vars breeds)
+ "CREATE-WORLD &key DIMS GLOBALS TURTLES-OWN-VARS PATCHES-OWN-VARS BREEDS => RESULT
DIMS: (:xmin XMIN :xmax XMAX :ymin YMIN :ymax YMAX)
+ GLOBALS: GLOBAL*
+ TURTLES-OWN-VARS: TURTLES-OWN-VAR*
+ PATCHES-OWN-VARS: PATCHES-OWN-VAR*
+ BREEDS: BREED*
+ RESULT: :undefined
+ GLOBAL: (GLOBAL-NAME GLOBAL-ACCESS-FUNC)
ARGUMENTS AND VALUES:
- RESULT: undefined
XMIN: An integer representing the minimum patch coord in X
XMAX: An integer representing the maximum patch coord in X
YMIN: An integer representing the minimum patch coord in Y
YMAX: An integer representing the maximum patch coord in Y
+ TURTLES-OWN-VAR: Symbol for the turtles own variable in the keyword package
+ PATCHES-OWN-VAR: Symbol for the patches own variable in the keyword package
+ BREED: A list of symbols representing the possible preeds
+ GLOBAL-NAME: Symbol for the global in the keyword package
+ GLOBAL-ACCESS-FUNC: Function to get the value of the global
DESCRIPTION:
This should be called before using the engine in any real capacity. If
called when an engine is already running, it may do somethign weird."
+ (setf *turtles-own-vars* turtles-own-vars)
+ (setf *patches-own-vars* patches-own-vars)
(setf *dimensions* dims)
- (setf
- *patches*
- (loop
- :for y :from (max-pycor) :downto (min-pycor)
- :append (loop
- :for x :from (min-pxcor) :to (max-pxcor)
- :collect (make-patch
- :xcor (coerce x 'double-float)
- :ycor (coerce y 'double-float)
- :color 0d0))))
- (setf *turtles* nil)
- (setf *current-id* 0))
-
-; These match netlogo's dump
-(defgeneric dump-object (o))
-
-(defmethod dump-object ((n double-float))
- (multiple-value-bind (int rem) (floor n)
- (if (eql 0d0 rem)
- (format nil "~A" int)
- (let
- ((output (format nil "~D" n)))
- ; Someday we'll have d<posint>, but this is not that day!
- (cl-ppcre:regex-replace "d-" (cl-ppcre:regex-replace "d0" output "") "E-")))))
-
-(defmethod dump-object ((o string)) o)
-
-(defmethod dump-object ((o (eql t))) "true")
-(defmethod dump-object ((o (eql nil))) "false")
-
-(defmethod dump-object ((o list)) (format nil "[~{~A~^ ~}]" (mapcar #'dump-object o)))
+ (setf *globals* globals)
+ (setf *breeds*
+ (append
+ (list (list :turtles "default"))
+ (mapcar (lambda (breed) (list breed "default")) breeds)))
+ (clear-ticks)
+ (clear-patches)
+ (clear-turtles))
(defun current-state ()
"CURRENT-STATE => WORLD-STATE
:color (turtle-color turtle)
:xcor (turtle-xcor turtle)
:ycor (turtle-ycor turtle)
- :heading (turtle-heading turtle)))
+ :heading (turtle-heading turtle)
+ :shape (turtle-shape turtle)
+ :size (turtle-size turtle)))
*turtles*)
(mapcar
(lambda (patch)
:color (patch-color patch)
:xcor (patch-xcor patch)
:ycor (patch-ycor patch)))
- *patches*)))
-
-(defun export-turtles ()
- (append
- (list
- "\"TURTLES\""
- (format nil "~A~A"
- "\"who\",\"color\",\"heading\",\"xcor\",\"ycor\",\"shape\",\"label\",\"label-color\","
- "\"breed\",\"hidden?\",\"size\",\"pen-size\",\"pen-mode\""))
- (mapcar
- (lambda (turtle)
- (format nil
- "\"~A\",\"~A\",\"~A\",\"~A\",\"~A\",~A"
- (dump-object (turtle-who turtle))
- (dump-object (turtle-color turtle))
- (dump-object (turtle-heading turtle))
- (dump-object (turtle-xcor turtle))
- (dump-object (turtle-ycor turtle))
- "\"\"\"default\"\"\",\"\"\"\"\"\",\"9.9\",\"{all-turtles}\",\"false\",\"1\",\"1\",\"\"\"up\"\"\""))
- *turtles*)))
-
-(defun export-patches ()
- (append
- (list
- "\"PATCHES\""
- "\"pxcor\",\"pycor\",\"pcolor\",\"plabel\",\"plabel-color\"")
+ *patches*)
(mapcar
- (lambda (patch)
- (format nil
- "\"~A\",\"~A\",\"~A\",\"\"\"\"\"\",\"9.9\""
- (dump-object (patch-xcor patch))
- (dump-object (patch-ycor patch))
- (dump-object (patch-color patch))))
- *patches*)))
-
-(defun export-world ()
- "EXPORT-WORLD => WORLD-CSV
+ (lambda (global)
+ (list
+ :name (car global)
+ :value (funcall (cadr global))))
+ *globals*)))
-ARGUMENTS AND VALUES:
+; These match netlogo's dump
+(defgeneric dump-object (o))
- WORLD-CSV: A string, the csv of the world
+(defmethod dump-object ((n double-float))
+ (multiple-value-bind (int rem) (floor n)
+ (if (eql 0d0 rem)
+ (format nil "~A" int)
+ (let
+ ((output (format nil "~D" n)))
+ ; Someday we'll have d<posint>, but this is not that day!
+ (cl-ppcre:regex-replace "d-" (cl-ppcre:regex-replace "d0" output "") "E-")))))
-DESCRIPTION:
+(defmethod dump-object ((o string)) (format nil "~A" (cl-ppcre:regex-replace-all "\"" (format nil "~S" o) "\"\"")))
- Dumps out a csv matching NetLogo's export world.
+(defmethod dump-object ((o (eql t))) "true")
+(defmethod dump-object ((o (eql nil))) "false")
- This is useful for serializing the current state of the engine in order
- to compare against NetLogo or to reimport later. Contains everything needed
- to boot up a NetLogo instance in the exact same state."
- (format nil "~{~A~%~}"
- (list
- (format nil "~S" "RANDOM STATE")
- (format nil "~S" (clnl-random:export))
- ""
- (format nil "~S" "GLOBALS")
- (format nil "~A~A"
- "\"min-pxcor\",\"max-pxcor\",\"min-pycor\",\"max-pycor\",\"perspective\",\"subject\","
- "\"nextIndex\",\"directed-links\",\"ticks\",")
- (format nil "\"~A\",\"~A\",\"~A\",\"~A\",\"0\",\"nobody\",\"~A\",\"\"\"NEITHER\"\"\",\"-1\""
- (min-pxcor) (max-pxcor) (min-pycor) (max-pycor) *current-id*)
- ""
- (format nil "~{~A~^~%~}" (export-turtles))
- ""
- (format nil "~{~A~^~%~}" (export-patches))
- ""
- (format nil "~S" "LINKS")
- "\"end1\",\"end2\",\"color\",\"label\",\"label-color\",\"hidden?\",\"breed\",\"thickness\",\"shape\",\"tie-mode\""
- "")))
+(defmethod dump-object ((o list))
+ (cond
+ ((agentset-p o) (format nil "(agentset, ~A ~A)" (dump-object (count o)) (string-downcase (agentset-breed o))))
+ (t (format nil "[~{~A~^ ~}]" (mapcar #'dump-object o)))))
+
+(defmethod dump-object ((o patch))
+ (format nil "(patch ~A ~A)" (dump-object (patch-xcor o)) (dump-object (patch-ycor o))))
+
+(defmethod dump-object ((o turtle)) (format nil "(turtle ~A)" (dump-object (turtle-who o))))
+(defmethod dump-object ((o (eql :nobody))) (format nil "nobody"))
+(defmethod dump-object ((o (eql :turtles))) (format nil "{all-turtles}"))
+(defmethod dump-object ((o symbol))
+ (cond
+ ((find o *breeds* :key #'car) (format nil "{breed ~(~A~)}" o))
+ (t (error "Keyword unrecognized by dump object: ~A" o))))