UI/Model Parse - Sliders - WIP

[clnl] / src / main / nvm / nvm.lisp

diff --git a/src/main/nvm/nvm.lisp b/src/main/nvm/nvm.lisp
index c5f0865e73bd5c57669dc29ed234eeb976d81134..96d57894b0d61b7a02fb7720e783e1cdc8cbf090 100644 (file)
--- a/src/main/nvm/nvm.lisp
+++ b/src/main/nvm/nvm.lisp
@@ -1,113 +1,74 @@
 (in-package #:clnl-nvm)
 
 (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:
 
 
 ARGUMENTS AND VALUES:
 

-  VALUE: a NetLogo value
-  RESULT: undefined
+  COLOR: a symbol representing a color
+  COLOR-NUMBER: the NetLogo color integer

 
 DESCRIPTION:
 
 
 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
  (let

-  ((copy (copy-list agent-set))
+  ((copy (copy-list agentset-list))

    (i 0)
    (agent nil))
    (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)))
    ((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
    (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)))))))
 
      ((= 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)
 
   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:
 
 
 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
   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:
 
 
 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."
 
   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 *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<posint>, 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
 
 (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.
 
   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."
 
   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
  (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<posint>, 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))))