(: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 create-turtle (&optional base-turtle)
+ (let
+ ((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))
+ :shape (breed-default-shape :turtles)
+ :xcor (if base-turtle (turtle-xcor base-turtle) 0d0)
+ :ycor (if base-turtle (turtle-ycor base-turtle) 0d0))))
+ (setf *turtles* (nconc *turtles* (list new-turtle)))
+ (incf *current-id*)
+ new-turtle))
(defun die ()
"DIE => RESULT
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*)
+ :patches)
(defun turtles ()
"TURTLES => ALL-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*)
+ :turtles)
+
+(defun ask (agent-or-agentset fn)
+ "ASK AGENT-OR-AGENTSET FN => RESULT
-(defun ask (agent-set fn)
- "ASK AGENT-SET FN => RESULT
+ AGENT-OR-AGENTSET: AGENT | AGENTSET
ARGUMENTS AND VALUES:
- AGENT-SET: a NetLogo agentset
FN: a function, run on each agent
RESULT: undefined, commands don't return
+ AGENT: a NetLogo agent
+ AGENTSET: a NetLogo agentset
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.
+ The specified AGENTSET or AGENT runs the given FN. In the case of an
+ AGENTSET, 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-list agent-set))))
- (loop
- :for agent := (funcall iter)
- :while agent
- :do (let ((*myself* *self*) (*self* agent)) (funcall fn)))))
+ (cond
+ ((agentset-p agent-or-agentset)
+ (let
+ ((iter (shufflerator (agentset-list agent-or-agentset))))
+ (loop
+ :for agent := (funcall iter)
+ :while agent
+ :do (let ((*myself* *self*) (*self* agent)) (with-stop-handler (funcall fn))))))
+ ((agent-p agent-or-agentset)
+ (let ((*myself* *self*) (*self* agent-or-agentset)) (with-stop-handler (funcall fn))))
+ (t
+ (error "Ask requires an agentset or agent but got: ~A" agent-or-agentset))))
+
+(defun count (agentset)
+ "COUNT AGENTSET => N
+
+ARGUMENTS AND VALUES:
+
+ AGENTSET: a NetLogo agentset
+ N: a number
+
+DESCRIPTION:
+
+ COUNT is equivalent to count in NetLogo. Returns N, the number of
+ agents in AGENTSET.
+
+ See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#count"
+ (coerce (length (agentset-list agentset)) 'double-float))
+
+(defun clear-all ()
+ "CLEAR-ALL => RESULT
+
+ARGUMENTS AND VALUES:
+
+ RESULT: undefined
+
+DESCRIPTION:
+
+ Clears ticks, turtles, patches, globals (unimplemented).
+
+ See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#clear-all"
+ (clear-turtles)
+ (clear-patches)
+ (clear-ticks))
+
+(defun display ()
+ "DISPLAY => RESULT
+
+ARGUMENTS AND VALUES:
+
+ RESULT: undefined
+
+DESCRIPTION:
+
+ As of yet, this does nothing. A placeholder method for forced dipslay
+ updates from the engine.
+
+ See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#display"
+ nil)
+
+(defun stop ()
+ "STOP => RESULT
+
+ARGUMENTS AND VALUES:
+
+ RESULT: undefined
-(defun of (fn agent-set)
- "OF FN AGENT-SET => RESULT
+DESCRIPTION:
+
+ Returns from the current stop block, which will halt the currently running
+ thing, be that the program, current ask block, or procedure. Stop has odd
+ semantics that are best gleaned from the actual NetLogo manual.
+
+ See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#stop"
+ (error (make-condition 'stop)))
+
+(defun of (fn agent-or-agentset)
+ "OF FN AGENT-OR-AGENTSET => RESULT
+
+ AGENT-OR-AGENTSET: AGENT | AGENTSET
+ RESULT: RESULT-LIST | RESULT-VALUE
ARGUMENTS AND VALUES:
FN: a function, run on each agent
- AGENT-SET: a NetLogo agentset
- RESULT: a list
+ AGENT: a NetLogo agent
+ AGENTSET: a NetLogo agentset
+ RESULT-LIST: a list
+ RESULT-VALUE: a single value
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.
+ The specified AGENTSET or AGENT runs the given FN. In the case of an
+ AGENTSET, 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.
+
+ RESULT-LIST is returned when the input is an AGENTSET, but RESULT-VALUE
+ is returned when only passed an AGENT.
See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#of"
- (let
- ((iter (shufflerator (agent-set-list agent-set))))
- (loop
- :for agent := (funcall iter)
- :while agent
- :collect (let ((*myself* *self*) (*self* agent)) (funcall fn)))))
+ (cond
+ ((agentset-p agent-or-agentset)
+ (let
+ ((iter (shufflerator (agentset-list agent-or-agentset))))
+ (loop
+ :for agent := (funcall iter)
+ :while agent
+ :collect (let ((*myself* *self*) (*self* agent)) (funcall fn)))))
+ ((agent-p agent-or-agentset)
+ (let ((*myself* *self*) (*self* agent-or-agentset)) (funcall fn)))
+ (t
+ (error "Of requires an agentset or agent but got: ~A" agent-or-agentset))))
+
+(defun with (agentset fn)
+ "WITH AGENTSET FN => RESULT-AGENTSET
-(defun shufflerator (agent-set-list)
+ARGUMENTS AND VALUES:
+
+ AGENTSET: a NetLogo agentset
+ FN: a boolean function, run on each agent to determine if included
+ RESULT-AGENTSET: an agentset of valid agents
+
+DESCRIPTION:
+
+ WITH is equivalent to with in NetLogo.
+
+ Returns a new agentset containing only those agents that reported true
+ when FN is called.
+
+ See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#with"
+ (list->agentset
+ (remove-if-not
+ (lambda (agent)
+ (let ((*myself* *self*) (*self* agent)) (funcall fn)))
+ (agentset-list agentset))
+ (agentset-breed agentset)))
+
+(defun shufflerator (agentset-list)
(let
- ((copy (copy-list agent-set-list))
+ ((copy (copy-list agentset-list))
(i 0)
(agent nil))
(flet
See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#random-float"
(clnl-random:next-double n))
-(defun one-of (agent-set)
- "ONE-OF AGENT-SET => RESULT
+(defun random (n)
+ "RANDOM N => RANDOM-NUMBER
+
+ARGUMENTS AND VALUES:
+
+ N: an integer, the upper bound of the random
+ RANDOM-NUMBER: an integer, the random result
+
+DESCRIPTION:
+
+ Returns a random number strictly closer to zero than N.
+
+ If number is positive, returns a random integer greater than or equal to 0,
+ but strictly less than number.
+
+ If number is negative, returns a random integer 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"
+ (coerce (clnl-random:next-long (truncate n)) 'double-float))
- RESULT: RANDOM-AGENT | :nobody
+(defun random-xcor ()
+ "RANDOM-XCOR => RANDOM-NUMBER
ARGUMENTS AND VALUES:
- AGENT-SET: An agent set
- RANDOM-AGENT: an agent if AGENT-SET is non empty
+ RANDOM-NUMBER: a float, the random result
DESCRIPTION:
- From an agentset, returns a random agent. If the agentset is empty, returns nobody.
+ Returns a random floating point number in the allowable range of turtle
+ coordinates along the x axis.
+
+ These range from min-pxcor - 0.5 (inclusive) to max-pxcor + 0.5 (exclusive)
+
+ See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#random-cor"
+ (let
+ ((min (- (min-pxcor) 0.5d0))
+ (max (+ (max-pxcor) 0.5d0)))
+ (+ min (clnl-random:next-double (- max min)))))
+
+(defun random-ycor ()
+ "RANDOM-YCOR => RANDOM-NUMBER
+
+ARGUMENTS AND VALUES:
+
+ RANDOM-NUMBER: a float, the random result
+
+DESCRIPTION:
+
+ Returns a random floating point number in the allowable range of turtle
+ coordinates along the y axis.
+
+ These range from min-pycor - 0.5 (inclusive) to max-pycor + 0.5 (exclusive)
+
+ See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#random-cor"
+ (let
+ ((min (- (min-pycor) 0.5d0))
+ (max (+ (max-pycor) 0.5d0)))
+ (+ min (clnl-random:next-double (- max min)))))
+
+(defun one-of (list-or-agentset)
+ "ONE-OF LIST-OR-AGENTSET => RESULT
+
+ LIST-OR-AGENTSET: LIST | AGENTSET
+ RESULT: RANDOM-VALUE | RANDOM-AGENT | :nobody
+
+ARGUMENTS AND VALUES:
+
+ LIST: A list
+ AGENTSET: An agent set
+ RANDOM-VALUE: a value in LIST
+ RANDOM-AGENT: an agent if AGENTSET is non empty
+
+DESCRIPTION:
+
+ From an AGENTSET, returns a RANDOM-AGENT. If the agentset is empty, returns :nobody.
+ From a list, returns a RANDOM-VALUE. If the list is empty, an error occurs.
See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#one-of"
- (let*
- ((agent-set-list (agent-set-list agent-set))
- (length (length agent-set-list)))
- (if (zerop length) :nobody (nth (clnl-random:next-int length) agent-set-list))))
+ (cond
+ ((agentset-p list-or-agentset)
+ (let*
+ ((agentset-list (agentset-list list-or-agentset))
+ (length (length agentset-list)))
+ (if (zerop length) :nobody (nth (clnl-random:next-int length) agentset-list))))
+ ((listp list-or-agentset)
+ (let*
+ ((length (length list-or-agentset)))
+ (if (zerop length)
+ (error "one-of requires a nonempty list")
+ (nth (clnl-random:next-int length) list-or-agentset))))
+ (t (error "one-of requires a list or agentset"))))
(defun jump (n)
- (when (not (turtle-p *self*)) (error "Gotta call fd in turtle scope, dude (~A)" *self*))
+ (when (not (turtle-p *self*)) (error "Gotta call jump in turtle scope, dude (~A)" *self*))
(setf
(turtle-xcor *self*)
(wrap-x *topology*
(wrap-y *topology*
(+ (turtle-ycor *self*) (* n (using-cached-cos (turtle-heading *self*)))))))
+(defun setxy (x y)
+ "SETXY X Y => RESULT
+
+ARGUMENTS AND VALUES:
+
+ X: a double
+ Y: a double
+ RESULT: undefined
+
+DESCRIPTION:
+
+ Sets the x-coordinate and y-coordinate for the turle. Equivalent to
+ set xcor x set ycor y, except it happens in one step inside of two.
+
+ See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#setxy"
+ (when (not (turtle-p *self*)) (error "Gotta call setxy in turtle scope, dude (~A)" *self*))
+ (setf (turtle-xcor *self*) (wrap-x *topology* x))
+ (setf (turtle-ycor *self*) (wrap-y *topology* y)))
+
+(defun set-default-shape (breed shape)
+ "SET-DEFAULT-SHAPE BREED SHAPE => RESULT
+
+ARGUMENTS AND VALUES:
+
+ BREED: a valid breed
+ SHAPE: a string
+ RESULT: undefined
+
+DESCRIPTION:
+
+ Specifies a default initial shape for a BREED. When a turtle, or it changes breeds,
+ its shape is set to the given shape.
+
+ SET-DEFAULT-SHAPE doesn't affect existing agents, only agents you create afterwards.
+
+ See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#set-default-shape"
+ (when (not (breed-p breed)) (error "Need a valid breed"))
+ (setf (breed-default-shape breed) shape))
+
(defun forward (n)
"FORWARD N => RESULT
See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#right"
(turn-right (- n)))
-(defun create-turtles (n)
- "CREATE-TURTLES N => RESULT
+(defun create-turtles (n &optional fn)
+ "CREATE-TURTLES N &optional FN => RESULT
ARGUMENTS AND VALUES:
N: an integer, the numbers of turtles to create
+ FN: A function, applied to each turtle after creation
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).
+ from the 14 primary colors. If a function is supplied, the new turtles
+ immediately run it.
See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#create-turtles"
- (loop :for i :from 1 :to n :do (create-turtle)))
+ (let
+ ((new-turtles (loop :repeat n :collect (create-turtle))))
+ (when fn (ask (list->agentset new-turtles :turtles) fn))))
+
+(defun hatch (n &optional fn)
+ "HATCH N &optional FN => RESULT
+
+ARGUMENTS AND VALUES:
+
+ N: an integer, the numbers of turtles to hatch
+ FN: A function, applied to each turtle after creation
+ RESULT: undefined
+
+DESCRIPTION:
+
+ The turtle in *self* creates N new turtles. Each new turtle inherits of all its
+ variables, including its location, from self.
+
+ If FN is supplied, the new turtles immediately run it.
+
+ See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#hatch"
+ (when (not (turtle-p *self*)) (error "Can only hatch from turtle scope"))
+ (let
+ ((new-turtles (loop :repeat n :collect (create-turtle *self*))))
+ (when fn (ask (list->agentset new-turtles :turtles) fn))))
(defun reset-ticks ()
"RESET-TICKS => RESULT
(when (not *ticks*) (error "reset-ticks must be called"))
*ticks*)
-(defun create-world (&key dims)
- "CREATE-WORLD &key DIMS => RESULT
+(defun clear-patches ()
+ (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)))))
+
+(defun clear-turtles ()
+ (setf *turtles* nil)
+ (setf *current-id* 0))
+
+(defun clear-ticks ()
+ (setf *ticks* nil))
+
+(defun create-world (&key dims globals turtles-own-vars)
+ "CREATE-WORLD &key DIMS GLOBALS TURTLES-OWN-VARS => RESULT
DIMS: (:xmin XMIN :xmax XMAX :ymin YMIN :ymax YMAX)
+ GLOBALS: GLOBAL*
+ TURTLES-OWN-VARS: TURTLES-OWN-VAR*
+ GLOBAL: (GLOBAL-NAME GLOBAL-ACCESS-FUNC)
ARGUMENTS AND VALUES:
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
+ 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 *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))
+ (setf *globals* globals)
+ (setf *breeds* (list (list :turtles "default")))
+ (clear-ticks)
+ (clear-patches)
+ (clear-turtles))
; These match netlogo's dump
(defgeneric dump-object (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)))
+(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))))
(append
(list
"\"TURTLES\""
- (format nil "~A~A"
+ (format nil "~A~A~{,\"~A\"~}"
"\"who\",\"color\",\"heading\",\"xcor\",\"ycor\",\"shape\",\"label\",\"label-color\","
- "\"breed\",\"hidden?\",\"size\",\"pen-size\",\"pen-mode\""))
+ "\"breed\",\"hidden?\",\"size\",\"pen-size\",\"pen-mode\""
+ (mapcar #'string-downcase *turtles-own-vars*)))
(mapcar
(lambda (turtle)
(format nil
- "\"~A\",\"~A\",\"~A\",\"~A\",\"~A\",\"\"\"default\"\"\",\"~A\",\"~A\",\"{all-turtles}\",\"false\",\"~A\",~A"
+ "\"~A\",\"~A\",\"~A\",\"~A\",\"~A\",\"~A\",\"~A\",\"~A\",\"{all-turtles}\",\"false\",\"~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))
+ (dump-object (turtle-shape turtle))
(dump-object (turtle-label turtle))
(dump-object (turtle-label-color turtle))
(dump-object (turtle-size turtle))
- "\"1\",\"\"\"up\"\"\""))
+ "\"1\",\"\"\"up\"\"\""
+ (mapcar #'dump-object (mapcar (lambda (var) (agent-value-inner turtle var)) *turtles-own-vars*))))
*turtles*)))
(defun export-patches ()
(format nil "~S" (clnl-random:export))
""
(format nil "~S" "GLOBALS")
- (format nil "~A~A"
+ (format nil "~A~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*)
+ "\"nextIndex\",\"directed-links\",\"ticks\","
+ (mapcar #'string-downcase (mapcar #'car *globals*)))
+ (format nil "\"~A\",\"~A\",\"~A\",\"~A\",\"0\",\"nobody\",\"~A\",\"\"\"NEITHER\"\"\",\"~A\"~{,\"~A\"~}"
+ (min-pxcor) (max-pxcor) (min-pycor) (max-pycor) *current-id* (dump-object (or *ticks* -1d0))
+ (mapcar #'dump-object (mapcar #'funcall (mapcar #'cadr *globals*))))
""
(format nil "~{~A~^~%~}" (export-turtles))
""
projects / clnl / blobdiff