(:magenta 125d0)
(:pink 135d0)))
-(defun create-turtle (&optional base-turtle)
- (let
- ((new-turtle (make-turtle
+(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)
:heading (if base-turtle
(turtle-heading base-turtle)
(coerce (clnl-random:next-int 360) 'double-float))
- :shape (breed-default-shape :turtles)
+ :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))))
+ :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))
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*)))
+ (setf *turtles* (remove *self* *turtles*))
+ (let
+ ((patch (patch-at (turtle-xcor *self*) (turtle-ycor *self*))))
+ (setf (patch-turtles patch) (remove *self* (patch-turtles patch))))
+ (error (make-condition 'death)))
(defun patches ()
"PATCHES => ALL-PATCHES
See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#turtles"
:turtles)
+(defun turtles-here (&optional breed)
+ "TURTLES-HERE => TURTLES
+
+ARGUMENTS AND VALUES:
+
+ TURTLES: an agentset
+
+DESCRIPTION:
+
+ Returns the agentset consisting of all the turtles sharing the patch
+ with the agent in by *self*
+
+ See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#turtles-here"
+ (when (not (turtle-p *self*)) (error "Gotta call turtles-here with a turtle"))
+ (let
+ ((patch-turtles (patch-turtles (patch-at (turtle-xcor *self*) (turtle-ycor *self*)))))
+ (list->agentset
+ (if breed (remove breed patch-turtles :key #'turtle-breed :test-not #'eql) patch-turtles)
+ (or breed :turtles))))
+
(defun ask (agent-or-agentset fn)
"ASK AGENT-OR-AGENTSET FN => RESULT
(loop
:for agent := (funcall iter)
:while agent
- :do (let ((*myself* *self*) (*self* agent)) (with-stop-handler (funcall fn))))))
+ :do (when (not (and (turtle-p agent) (= -1 (turtle-who agent))))
+ (let ((*myself* *self*) (*self* agent)) (with-stop-and-death-handler (funcall fn)))))))
((agent-p agent-or-agentset)
- (let ((*myself* *self*) (*self* agent-or-agentset)) (with-stop-handler (funcall fn))))
+ (let ((*myself* *self*) (*self* agent-or-agentset)) (with-stop-and-death-handler (funcall fn))))
(t
(error "Ask requires an agentset or agent but got: ~A" agent-or-agentset))))
((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
(defun jump (n)
(when (not (turtle-p *self*)) (error "Gotta call jump 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*)))))))
+ (with-patch-update *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 setxy (x y)
"SETXY X Y => RESULT
See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#right"
(turn-right (- n)))
-(defun create-turtles (n &optional fn)
- "CREATE-TURTLES N &optional FN => RESULT
+(defun create-turtles (n &optional breed fn)
+ "CREATE-TURTLES N &optional BREED FN => RESULT
ARGUMENTS AND VALUES:
N: an integer, the numbers of turtles to create
+ BREED: a breed
FN: A function, applied to each turtle after creation
RESULT: undefined
DESCRIPTION:
- Creates number new turtles at the origin.
+ Creates N new turtles at the origin.
New turtles have random integer headings and the color is randomly selected
- from the 14 primary colors. If a function is supplied, the new turtles
- immediately run it.
+ from the 14 primary colors. If FN is supplied, the new turtles immediately
+ run it. If a BREED is supplied, that is the breed the new turtles are set
+ to.
See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#create-turtles"
(let
- ((new-turtles (loop :repeat n :collect (create-turtle))))
+ ((new-turtles (loop :repeat n :collect (create-turtle breed))))
(when fn (ask (list->agentset new-turtles :turtles) fn))))
(defun hatch (n &optional fn)
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*))))
+ ((new-turtles (loop :repeat n :collect (create-turtle nil *self*))))
(when fn (ask (list->agentset new-turtles :turtles) fn))))
(defun reset-ticks ()
(defun clear-ticks ()
(setf *ticks* nil))
-(defun create-world (&key dims globals turtles-own-vars)
- "CREATE-WORLD &key DIMS GLOBALS TURTLES-OWN-VARS => RESULT
+(defun 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*
GLOBAL: (GLOBAL-NAME GLOBAL-ACCESS-FUNC)
ARGUMENTS AND VALUES:
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
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 *globals* globals)
- (setf *breeds* (list (list :turtles "default")))
+ (setf *breeds*
+ (append
+ (list (list :turtles "default"))
+ (mapcar (lambda (breed) (list breed "default")) breeds)))
(clear-ticks)
(clear-patches)
(clear-turtles))
(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))))
(defun current-state ()
"CURRENT-STATE => WORLD-STATE
(mapcar
(lambda (turtle)
(format nil
- "\"~A\",\"~A\",\"~A\",\"~A\",\"~A\",\"~A\",\"~A\",\"~A\",\"{all-turtles}\",\"false\",\"~A\",~A~{,\"~A\"~}"
+ "\"~A\",\"~A\",\"~A\",\"~A\",\"~A\",\"~A\",\"~A\",\"~A\",\"~A\",\"false\",\"~A\",~A~{,\"~A\"~}"
(dump-object (turtle-who turtle))
(dump-object (turtle-color turtle))
(dump-object (turtle-heading turtle))
(dump-object (turtle-shape turtle))
(dump-object (turtle-label turtle))
(dump-object (turtle-label-color turtle))
+ (dump-object (turtle-breed turtle))
(dump-object (turtle-size turtle))
"\"1\",\"\"\"up\"\"\""
(mapcar #'dump-object (mapcar (lambda (var) (agent-value-inner turtle var)) *turtles-own-vars*))))
(append
(list
"\"PATCHES\""
- "\"pxcor\",\"pycor\",\"pcolor\",\"plabel\",\"plabel-color\"")
+ (format nil "\"pxcor\",\"pycor\",\"pcolor\",\"plabel\",\"plabel-color\"~{,\"~A\"~}"
+ (mapcar #'string-downcase *patches-own-vars*)))
(mapcar
(lambda (patch)
(format nil
- "\"~A\",\"~A\",\"~A\",\"\"\"\"\"\",\"9.9\""
+ "\"~A\",\"~A\",\"~A\",\"\"\"\"\"\",\"9.9\"~{,\"~A\"~}"
(dump-object (patch-xcor patch))
(dump-object (patch-ycor patch))
- (dump-object (patch-color patch))))
+ (dump-object (patch-color patch))
+ (mapcar #'dump-object (mapcar (lambda (var) (agent-value-inner patch var)) *patches-own-vars*))))
*patches*)))
(defun export-world ()
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~{\"~A\"~^,~}"
- "\"min-pxcor\",\"max-pxcor\",\"min-pycor\",\"max-pycor\",\"perspective\",\"subject\","
- "\"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))
- ""
- (format nil "~{~A~^~%~}" (export-patches))
- ""
- (format nil "~S" "LINKS")
- "\"end1\",\"end2\",\"color\",\"label\",\"label-color\",\"hidden?\",\"breed\",\"thickness\",\"shape\",\"tie-mode\""
- "")))
+ (let
+ ((ordered-globals (sort (copy-list *globals*) #'string< :key (lambda (global) (symbol-name (car global))))))
+ (format nil "~{~A~%~}"
+ (list
+ (format nil "~S" "RANDOM STATE")
+ (format nil "~S" (clnl-random:export))
+ ""
+ (format nil "~S" "GLOBALS")
+ (format nil "~A~A~{\"~A\"~^,~}"
+ "\"min-pxcor\",\"max-pxcor\",\"min-pycor\",\"max-pycor\",\"perspective\",\"subject\","
+ "\"nextIndex\",\"directed-links\",\"ticks\","
+ (mapcar #'string-downcase (mapcar #'car ordered-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 ordered-globals))))
+ ""
+ (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\""
+ ""))))