X-Git-Url: https://code.consxy.com/gitweb/gitweb.cgi?p=clnl;a=blobdiff_plain;f=src%2Fmain%2Fnvm%2Fnvm.lisp;h=96d57894b0d61b7a02fb7720e783e1cdc8cbf090;hp=f8fdd84bde3a72ecdc4c8e87f6db905e5c42ca44;hb=89cb3482de1fefc2d8e5f67e1e04a0790e8cd243;hpb=0a00e056cd1a8f022128525ac3cf3494cc36159d diff --git a/src/main/nvm/nvm.lisp b/src/main/nvm/nvm.lisp index f8fdd84..96d5789 100644 --- a/src/main/nvm/nvm.lisp +++ b/src/main/nvm/nvm.lisp @@ -1,22 +1,5 @@ (in-package #:clnl-nvm) -; Implementations of all the things the nvm can do. - -(defun show (value) - "SHOW VALUE => RESULT - -ARGUMENTS AND VALUES: - - VALUE: a NetLogo value - RESULT: undefined - -DESCRIPTION: - - A command that prints the given NetLogo value to the command center. - - See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#show" - (format t "Showing: ~A~%" (dump-object value))) - (defun lookup-color (color) "LOOKUP-COLOR COLOR => COLOR-NUMBER @@ -48,140 +31,44 @@ 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 die () - "DIE => RESULT - -ARGUMENTS AND VALUES: - - RESULT: undefined, commands don't return - -DESCRIPTION: - - The turtle or link dies - - A dead agent ceases to exist. The effects of this include: - - The agent will not execute any further code. - - The agent will disappear from any agentsets it was in, reducing the size of those agentsets by one. - - Any variable that was storing the agent will now instead have nobody in it. - - If the dead agent was a turtle, every link connected to it also dies. - - If the observer was watching or following the agent, the observer's perspective resets. - - 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*))) - -(defun patches () - "PATCHES => ALL-PATCHES - -ARGUMENTS AND VALUES: - - ALL-PATCHES: a NetLogo agentset, all patches - -DESCRIPTION: - - Reports the agentset consisting of all the patches. - - This agentset is special in that it represents the living patches - 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*) - -(defun turtles () - "TURTLES => ALL-TURTLES - -ARGUMENTS AND VALUES: - - ALL-TURTLES: a NetLogo agentset, all turtles - -DESCRIPTION: - - Reports the agentset consisting of all the turtles. - - This agentset is special in that it represents the living 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*) - -(defun ask (agent-set fn) - "ASK AGENT-SET FN => RESULT - -ARGUMENTS AND VALUES: - - AGENT-SET: a NetLogo agentset - FN: a function, run on each agent - RESULT: undefined, commands don't return - -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. - - 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))))) - -(defun of (fn agent-set) - "OF FN AGENT-SET => RESULT - -ARGUMENTS AND VALUES: - - FN: a function, run on each agent - AGENT-SET: a NetLogo agentset - RESULT: a list - -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. - - 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))))) - -(defun shufflerator (agent-set-list) +(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 shufflerator (agentset-list) (let - ((copy (copy-list agent-set-list)) + ((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 @@ -189,287 +76,28 @@ DESCRIPTION: ((= i (length copy)) (incf i) (car (last copy))) (t (let ((result agent)) (fetch) result))))))) -(defun random-float (n) - "RANDOM-FLOAT N => RANDOM-NUMBER - -ARGUMENTS AND VALUES: - - N: a double, the upper bound of the random float - RANDOM-NUMBER: a double, the random result - -DESCRIPTION: - - Returns a random number strictly closer to zero than N. - - If number is positive, returns a random floating point number greater than - or equal to 0 but strictly less than number. - - If number is negative, returns a random floating point number 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-float" - (clnl-random:next-double n)) - -(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)) - -(defun random-xcor () - "RANDOM-XCOR => 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 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 (agent-set) - "ONE-OF AGENT-SET => RESULT - - RESULT: RANDOM-AGENT | :nobody - -ARGUMENTS AND VALUES: - - AGENT-SET: An agent set - RANDOM-AGENT: an agent if AGENT-SET is non empty - -DESCRIPTION: - - From an agentset, returns a random agent. If the agentset is empty, returns nobody. - - 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)))) - -(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*))))))) - -(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 forward (n) - "FORWARD N => RESULT - -ARGUMENTS AND VALUES: - - N: a double, the amount the turtle moves forward - RESULT: undefined - -DESCRIPTION: - - Moves the current turtle forward N steps, one step at a time. - - This moves forward one at a time in order to make the view updates look - good in the case of a purposefully slow running instance. If the number - is negative, the turtle moves backward. - - If the current agent is not a turtle, it raises an error. - - See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#forward" - (when (not (turtle-p *self*)) (error "Gotta call fd in turtle scope, dude (~A)" *self*)) - (labels - ((internal (i) - (cond - ((< (abs i) 3.2e-15) nil) - ((< (abs i) 1d0) (jump i)) - (t (jump (if (> i 0d0) 1d0 -1d0)) (internal (- i (if (> i 0d0) 1d0 -1d0))))))) - (internal n))) - -(defun turn-right (n) - "TURN-RIGHT N => RESULT - -ARGUMENTS AND VALUES: - - N: a double, the amount the turtle turns - RESULT: undefined - -DESCRIPTION: - - The turtle turns right by number degrees. (If number is negative, it turns left.) - - See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#right" - (when (not (turtle-p *self*)) (error "Gotta call fd in turtle scope, dude (~A)" *self*)) - (let - ((new-heading (+ (turtle-heading *self*) n))) - (setf (turtle-heading *self*) - (cond - ((< new-heading 0) (+ (mod new-heading -360) 360)) - ((>= new-heading 360) (mod new-heading 360)) - (t new-heading))))) - -(defun turn-left (n) - "TURN-LEFT N => RESULT - -ARGUMENTS AND VALUES: - - N: a double, the amount the turtle turns - RESULT: undefined - -DESCRIPTION: - - The turtle turns left by number degrees. (If number is negative, it turns right.) - - See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#right" - (turn-right (- n))) - -(defun create-turtles (n) - "CREATE-TURTLES N => RESULT - -ARGUMENTS AND VALUES: - - N: an integer, the numbers of turtles to create - 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). - - See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#create-turtles" - (loop :for i :from 1 :to n :do (create-turtle))) - -(defun reset-ticks () - "RESET-TICKS => RESULT - -ARGUMENTS AND VALUES: - - RESULT: undefined - -DESCRIPTION: - - Resets the tick counter to zero, sets up all plots, then updates all plots. - - See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#reset-ticks" - (setf *ticks* 0d0)) - -(defun tick () - "RESET-TICKS => RESULT - -ARGUMENTS AND VALUES: - - RESULT: undefined - -DESCRIPTION: - - Advances the tick counter by one and updates all plots. - - If the tick counter has not been started yet with reset-ticks, an error results. - - See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#tick" - - (when (not *ticks*) (error "reset-ticks must be called")) - (incf *ticks*)) - -(defun ticks () - "TICKS => CURRENT-TICKS - -ARGUMENTS AND VALUES: - - CURRENT-TICKS: A positiv double, representing the current number of ticks - -DESCRIPTION: - - Reports the current value of the tick counter. The result is always a number and never negative. - - If the tick counter has not been started yet with reset-ticks, an error results. - - See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#ticks" - (when (not *ticks*) (error "reset-ticks must be called")) - *ticks*) - -(defun create-world (&key dims) - "CREATE-WORLD &key DIMS => RESULT +(defcommand 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* + RESULT: :undefined + GLOBAL: (GLOBAL-NAME GLOBAL-ACCESS-FUNC) ARGUMENTS AND VALUES: - RESULT: undefined XMIN: An integer representing the minimum patch coord in X 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: @@ -477,44 +105,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)) - -; These match netlogo's dump -(defgeneric dump-object (o)) - -(defmethod dump-object ((n double-float)) - (multiple-value-bind (int rem) (floor n) - (if (eql 0d0 rem) - (format nil "~A" int) - (let - ((output (format nil "~D" n))) - ; Someday we'll have d, but this is not that day! - (cl-ppcre:regex-replace "d-" (cl-ppcre:regex-replace "d0" output "") "E-"))))) - -(defmethod dump-object ((o string)) (format nil "~A" (cl-ppcre:regex-replace-all "\"" (format nil "~S" 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 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")) + (setf *globals* globals) + (setf *breeds* + (append + (list (list :turtles "default")) + (mapcar (lambda (breed) (list breed "default")) breeds))) + (clear-ticks) + (clear-patches) + (clear-turtles)) (defun current-state () "CURRENT-STATE => WORLD-STATE @@ -543,6 +144,7 @@ DESCRIPTION: :xcor (turtle-xcor turtle) :ycor (turtle-ycor turtle) :heading (turtle-heading turtle) + :shape (turtle-shape turtle) :size (turtle-size turtle))) *turtles*) (mapcar @@ -551,74 +153,43 @@ DESCRIPTION: :color (patch-color patch) :xcor (patch-xcor patch) :ycor (patch-ycor patch))) - *patches*))) - -(defun export-turtles () - (append - (list - "\"TURTLES\"" - (format nil "~A~A" - "\"who\",\"color\",\"heading\",\"xcor\",\"ycor\",\"shape\",\"label\",\"label-color\"," - "\"breed\",\"hidden?\",\"size\",\"pen-size\",\"pen-mode\"")) + *patches*) (mapcar - (lambda (turtle) - (format nil - "\"~A\",\"~A\",\"~A\",\"~A\",\"~A\",\"\"\"default\"\"\",\"~A\",\"~A\",\"{all-turtles}\",\"false\",\"~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-label turtle)) - (dump-object (turtle-label-color turtle)) - (dump-object (turtle-size turtle)) - "\"1\",\"\"\"up\"\"\"")) - *turtles*))) + (lambda (global) + (list + :name (car global) + :value (funcall (cadr global)))) + *globals*))) -(defun export-patches () - (append - (list - "\"PATCHES\"" - "\"pxcor\",\"pycor\",\"pcolor\",\"plabel\",\"plabel-color\"") - (mapcar - (lambda (patch) - (format nil - "\"~A\",\"~A\",\"~A\",\"\"\"\"\"\",\"9.9\"" - (dump-object (patch-xcor patch)) - (dump-object (patch-ycor patch)) - (dump-object (patch-color patch)))) - *patches*))) +; These match netlogo's dump +(defgeneric dump-object (o)) -(defun export-world () - "EXPORT-WORLD => WORLD-CSV +(defmethod dump-object ((n double-float)) + (multiple-value-bind (int rem) (floor n) + (if (eql 0d0 rem) + (format nil "~A" int) + (let + ((output (format nil "~D" n))) + ; Someday we'll have d, but this is not that day! + (cl-ppcre:regex-replace "d-" (cl-ppcre:regex-replace "d0" output "") "E-"))))) -ARGUMENTS AND VALUES: +(defmethod dump-object ((o string)) (format nil "~A" (cl-ppcre:regex-replace-all "\"" (format nil "~S" o) "\"\""))) - WORLD-CSV: A string, the csv of the world +(defmethod dump-object ((o (eql t))) "true") +(defmethod dump-object ((o (eql nil))) "false") -DESCRIPTION: +(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))))) - Dumps out a csv matching NetLogo's export world. +(defmethod dump-object ((o patch)) + (format nil "(patch ~A ~A)" (dump-object (patch-xcor o)) (dump-object (patch-ycor o)))) - 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\"" - ""))) +(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))))