X-Git-Url: https://code.consxy.com/gitweb/gitweb.cgi?a=blobdiff_plain;f=src%2Fmain%2Fnvm%2Fnvm.lisp;h=7927909859eed04ba570018eb03a133c8003aef3;hb=885270b;hp=b18faf1f3552a4502c926d63279f4ef1dfac5773;hpb=75a961089cba4b6aa4a3e947616ee4026ec3b057;p=clnl diff --git a/src/main/nvm/nvm.lisp b/src/main/nvm/nvm.lisp index b18faf1..7927909 100644 --- a/src/main/nvm/nvm.lisp +++ b/src/main/nvm/nvm.lisp @@ -1,90 +1,74 @@ (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 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 turtles () - "TURTLES => ALL-TURTLES +(defun lookup-color (color) + "LOOKUP-COLOR COLOR => COLOR-NUMBER ARGUMENTS AND VALUES: - ALL-TURTLES: a NetLogo agentset, all turtles + COLOR: a symbol representing a color + COLOR-NUMBER: the NetLogo color integer 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 @@ -92,94 +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 (strictmath:sin (strictmath:to-radians (turtle-heading *self*))))))) - (setf - (turtle-ycor *self*) - (wrap-y *topology* - (+ (turtle-ycor *self*) (* n (strictmath:cos (strictmath:to-radians (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. +(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 - 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 create-turtles (n) - "CREATE-TURTLES N => 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: - 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 (model) - "CREATE-WORLD MODEL => RESULT - -ARGUMENTS AND VALUES: - - MODEL: A clnl-model:model to use to initialize the vm 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: @@ -187,23 +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 *model* model) - (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) + (setf *turtles-own-vars* turtles-own-vars) + (setf *patches-own-vars* patches-own-vars) + (setf *dimensions* dims) + (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 @@ -220,77 +132,58 @@ 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\"")) + (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*))) -(defun export-world () - "EXPORT-WORLD => WORLD-CSV +; These match netlogo's dump +(defgeneric dump-object (o)) -ARGUMENTS AND VALUES: +(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-"))))) - WORLD-CSV: A string, the csv of the world +(defmethod dump-object ((o string)) (format nil "~A" (cl-ppcre:regex-replace-all "\"" (format nil "~S" o) "\"\""))) -DESCRIPTION: +(defmethod dump-object ((o (eql t))) "true") +(defmethod dump-object ((o (eql nil))) "false") + +(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 "~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 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))))