(: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)
+ :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))))
+ (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*))
+ (error (make-condition 'stop)))
(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)) (funcall fn)))))
+ :do (let ((*myself* *self*) (*self* agent)) (with-stop-handler (funcall fn))))))
((agent-p agent-or-agentset)
- (let ((*myself* *self*) (*self* agent-or-agentset)) (funcall fn)))
+ (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))))
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
+
+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
(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 ()
(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 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:
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 *breeds* (list (list :turtles "default")))
- (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*
+ (append
+ (list (list :turtles "default"))
+ (mapcar (lambda (breed) (list breed "default")) breeds)))
+ (clear-ticks)
+ (clear-patches)
+ (clear-turtles))
; These match netlogo's dump
(defgeneric dump-object (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))))
(defun current-state ()
"CURRENT-STATE => WORLD-STATE
(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\",\"~A\",\"~A\",\"~A\",\"{all-turtles}\",\"false\",\"~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\"\"\""))
+ "\"1\",\"\"\"up\"\"\""
+ (mapcar #'dump-object (mapcar (lambda (var) (agent-value-inner turtle var)) *turtles-own-vars*))))
*turtles*)))
(defun export-patches ()
(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 ()
(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