X-Git-Url: https://code.consxy.com/gitweb/gitweb.cgi?p=clnl;a=blobdiff_plain;f=src%2Fmain%2Fnvm%2Fnvm.lisp;h=96d57894b0d61b7a02fb7720e783e1cdc8cbf090;hp=c5f0865e73bd5c57669dc29ed234eeb976d81134;hb=89cb3482de1fefc2d8e5f67e1e04a0790e8cd243;hpb=2c338ef0bdabd1e327bbf474221239c2eead88e4 diff --git a/src/main/nvm/nvm.lisp b/src/main/nvm/nvm.lisp index c5f0865..96d5789 100644 --- a/src/main/nvm/nvm.lisp +++ b/src/main/nvm/nvm.lisp @@ -1,113 +1,74 @@ (in-package #:clnl-nvm) -; Implementations of all the things the nvm can do. - -(defun show (value) - "SHOW VALUE => RESULT +(defun lookup-color (color) + "LOOKUP-COLOR COLOR => COLOR-NUMBER ARGUMENTS AND VALUES: - VALUE: a NetLogo value - RESULT: undefined + COLOR: a symbol representing a color + COLOR-NUMBER: the NetLogo color integer 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 create-turtle () - (setf - *turtles* - (nconc - *turtles* - (list - (make-turtle - :who *current-id* - :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 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))) - (loop - :for agent := (funcall iter) - :while agent - :do (let ((*myself* *self*) (*self* agent)) (funcall fn))))) - -(defun shufflerator (agent-set) + Returns the number used to represent colors in NetLogo. + + See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#Constants" + (case color + (:black 0d0) + (:gray 5d0) + (:white 9.9d0) + (:red 15d0) + (:orange 25d0) + (:brown 35d0) + (:yellow 45d0) + (:green 55d0) + (:lime 65d0) + (:turquoise 75d0) + (:cyan 85d0) + (:sky 95d0) + (:blue 105d0) + (:violet 115d0) + (:magenta 125d0) + (:pink 135d0))) + +(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)) + ((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 @@ -115,136 +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 jump (n) - (when (not (turtle-p *self*)) (error "Gotta call fd 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 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 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: @@ -252,26 +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 *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)) o) - -(defmethod dump-object ((o (eql t))) "true") -(defmethod dump-object ((o (eql nil))) "false") + (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 @@ -288,77 +132,64 @@ DESCRIPTION: data structure for easy usage in a common lisp instance. It's preferable to use this when working with the nvm than the output done by export-world. - Currently this only dumps out turtle information. + Currently this only dumps out turtle and patch information. This is called CURRENT-STATE because export-world is an actual primitive used by NetLogo." - (mapcar - (lambda (turtle) - (list - :color (turtle-color turtle) - :xcor (turtle-xcor turtle) - :ycor (turtle-ycor turtle) - :heading (turtle-heading turtle))) - *turtles*)) - -(defun export-patches () (list - "\"pxcor\",\"pycor\",\"pcolor\",\"plabel\",\"plabel-color\"" - "\"-1\",\"1\",\"0\",\"\"\"\"\"\",\"9.9\"" - "\"0\",\"1\",\"0\",\"\"\"\"\"\",\"9.9\"" - "\"1\",\"1\",\"0\",\"\"\"\"\"\",\"9.9\"" - "\"-1\",\"0\",\"0\",\"\"\"\"\"\",\"9.9\"" - "\"0\",\"0\",\"0\",\"\"\"\"\"\",\"9.9\"" - "\"1\",\"0\",\"0\",\"\"\"\"\"\",\"9.9\"" - "\"-1\",\"-1\",\"0\",\"\"\"\"\"\",\"9.9\"" - "\"0\",\"-1\",\"0\",\"\"\"\"\"\",\"9.9\"" - "\"1\",\"-1\",\"0\",\"\"\"\"\"\",\"9.9\"")) - -(defun export-world () - "EXPORT-WORLD => WORLD-CSV + (mapcar + (lambda (turtle) + (list + :color (turtle-color turtle) + :xcor (turtle-xcor turtle) + :ycor (turtle-ycor turtle) + :heading (turtle-heading turtle) + :shape (turtle-shape turtle) + :size (turtle-size turtle))) + *turtles*) + (mapcar + (lambda (patch) + (list + :color (patch-color patch) + :xcor (patch-xcor patch) + :ycor (patch-ycor patch))) + *patches*) + (mapcar + (lambda (global) + (list + :name (car global) + :value (funcall (cadr global)))) + *globals*))) -ARGUMENTS AND VALUES: +; These match netlogo's dump +(defgeneric dump-object (o)) - WORLD-CSV: A string, the csv of the world +(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-"))))) -DESCRIPTION: +(defmethod dump-object ((o string)) (format nil "~A" (cl-ppcre:regex-replace-all "\"" (format nil "~S" o) "\"\""))) - Dumps out a csv matching NetLogo's export world. +(defmethod dump-object ((o (eql t))) "true") +(defmethod dump-object ((o (eql nil))) "false") - 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 "~S" "TURTLES") - (format nil "~A~A" - "\"who\",\"color\",\"heading\",\"xcor\",\"ycor\",\"shape\",\"label\",\"label-color\"," - "\"breed\",\"hidden?\",\"size\",\"pen-size\",\"pen-mode\"") - (format nil "~{~A~%~}" - (mapcar - (lambda (turtle) - (format nil - "\"~A\",\"~A\",\"~A\",\"~A\",\"~A\",~A" - (turtle-who turtle) - (dump-object (turtle-color turtle)) - (dump-object (turtle-heading turtle)) - (dump-object (turtle-xcor turtle)) - (dump-object (turtle-ycor turtle)) - "\"\"\"default\"\"\",\"\"\"\"\"\",\"9.9\",\"{all-turtles}\",\"false\",\"1\",\"1\",\"\"\"up\"\"\"")) - *turtles*)) - (format nil "~S" "PATCHES") - (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 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))))