X-Git-Url: https://code.consxy.com/gitweb/gitweb.cgi?a=blobdiff_plain;f=src%2Fmain%2Fnvm%2Fnvm.lisp;h=5540caea05bad45b54cb49f30cd6e8f9138c4004;hb=807df6b;hp=31d2f31ae4287af0e806e3b5f0a182d4cd11c6aa;hpb=5a7fb5cf4e703d4cb8d6b89052265368323edd94;p=clnl diff --git a/src/main/nvm/nvm.lisp b/src/main/nvm/nvm.lisp index 31d2f31..5540cae 100644 --- a/src/main/nvm/nvm.lisp +++ b/src/main/nvm/nvm.lisp @@ -48,19 +48,30 @@ DESCRIPTION: (: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 (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 die () "DIE => RESULT @@ -83,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 @@ -119,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 @@ -147,9 +182,10 @@ DESCRIPTION: (loop :for agent := (funcall iter) :while agent - :do (let ((*myself* *self*) (*self* agent)) (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)) (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)))) @@ -169,6 +205,53 @@ DESCRIPTION: 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 @@ -208,18 +291,43 @@ DESCRIPTION: (t (error "Of requires an agentset or agent but got: ~A" agent-or-agentset)))) +(defun with (agentset fn) + "WITH AGENTSET FN => RESULT-AGENTSET + +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 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 @@ -348,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 @@ -376,6 +485,26 @@ DESCRIPTION: (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 @@ -441,24 +570,51 @@ DESCRIPTION: 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 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 commands are supplied, the new turtles - immediately run them (unimplemented). + 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" - (loop :for i :from 1 :to n :do (create-turtle))) + (let + ((new-turtles (loop :repeat n :collect (create-turtle breed)))) + (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 nil *self*)))) + (when fn (ask (list->agentset new-turtles :turtles) fn)))) (defun reset-ticks () "RESET-TICKS => RESULT @@ -509,10 +665,34 @@ DESCRIPTION: (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: @@ -521,6 +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 + 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: @@ -528,19 +713,17 @@ 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)) + (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)) @@ -559,13 +742,21 @@ DESCRIPTION: (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)))) (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 @@ -608,36 +799,42 @@ 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\",\"\"\"default\"\"\",\"~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-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-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 () @@ -654,22 +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" - "\"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\"" - ""))) + (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\"" + ""))))