X-Git-Url: https://code.consxy.com/gitweb/gitweb.cgi?a=blobdiff_plain;f=src%2Fmain%2Fnvm%2Fnvm.lisp;h=5540caea05bad45b54cb49f30cd6e8f9138c4004;hb=807df6b;hp=766df5379bf232623274271bbc58c7273cdf23ce;hpb=762ab38881c8870c9a61ca6857a28159f9fef9fc;p=clnl diff --git a/src/main/nvm/nvm.lisp b/src/main/nvm/nvm.lisp index 766df53..5540cae 100644 --- a/src/main/nvm/nvm.lisp +++ b/src/main/nvm/nvm.lisp @@ -48,9 +48,10 @@ DESCRIPTION: (: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) @@ -58,9 +59,16 @@ DESCRIPTION: :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)) @@ -86,7 +94,11 @@ DESCRIPTION: 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 @@ -122,6 +134,26 @@ DESCRIPTION: 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 @@ -150,9 +182,10 @@ DESCRIPTION: (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)))) @@ -287,13 +320,14 @@ DESCRIPTION: ((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 @@ -422,14 +456,15 @@ DESCRIPTION: (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 @@ -535,26 +570,28 @@ DESCRIPTION: 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) @@ -576,7 +613,7 @@ DESCRIPTION: 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 () @@ -647,12 +684,15 @@ DESCRIPTION: (defun clear-ticks () (setf *ticks* nil)) -(defun create-world (&key dims globals) - "CREATE-WORLD &key DIMS GLOBALS => 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* - GLOBAL: (NAME ACCESS-FUNC) + TURTLES-OWN-VARS: TURTLES-OWN-VAR* + PATCHES-OWN-VARS: PATCHES-OWN-VAR* + BREEDS: BREED* + GLOBAL: (GLOBAL-NAME GLOBAL-ACCESS-FUNC) ARGUMENTS AND VALUES: @@ -661,8 +701,11 @@ 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 - NAME: Symbol for the global in the keyword package - ACCESS-FUNC: Function to get the value of the global + 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: @@ -670,9 +713,14 @@ 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 *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)) @@ -704,6 +752,11 @@ DESCRIPTION: (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 @@ -746,13 +799,14 @@ DESCRIPTION: (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)) @@ -761,22 +815,26 @@ DESCRIPTION: (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 () @@ -793,24 +851,26 @@ DESCRIPTION: 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\"" + ""))))