X-Git-Url: https://code.consxy.com/gitweb/gitweb.cgi?p=clnl;a=blobdiff_plain;f=src%2Fmain%2Fnvm%2Fnvm.lisp;h=dcba15148fee16839967859fd016dea94fb50a6c;hp=f2057bd7605540eb65e94917d580dbadd8e91377;hb=97c390f3cee5094fa6795acd4b25b7598d5dd1bd;hpb=9413d3737ae1c07d7ec2cad29ef3a6d50ab859a9

diff --git a/src/main/nvm/nvm.lisp b/src/main/nvm/nvm.lisp
index f2057bd..dcba151 100644
--- a/src/main/nvm/nvm.lisp
+++ b/src/main/nvm/nvm.lisp
@@ -48,19 +48,22 @@ DESCRIPTION:
   (:magenta 125d0)
   (:pink 135d0)))
 
-(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 create-turtle (&optional base-turtle)
+ (let
+  ((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))
+                :shape (breed-default-shape :turtles)
+                :xcor (if base-turtle (turtle-xcor base-turtle) 0d0)
+                :ycor (if base-turtle (turtle-ycor base-turtle) 0d0))))
+  (setf *turtles* (nconc *turtles* (list new-turtle)))
+  (incf *current-id*)
+  new-turtle))
 
 (defun die ()
  "DIE => RESULT
@@ -85,6 +88,23 @@ DESCRIPTION:
  (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
 
@@ -100,36 +120,171 @@ DESCRIPTION:
   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*)
+ :turtles)
+
+(defun ask (agent-or-agentset fn)
+ "ASK AGENT-OR-AGENTSET FN => RESULT
 
-(defun ask (agent-set fn)
- "ASK AGENT-SET FN => RESULT
+  AGENT-OR-AGENTSET: AGENT | AGENTSET
 
 ARGUMENTS AND VALUES:
 
-  AGENT-SET: a NetLogo agentset
   FN: a function, run on each agent
   RESULT: undefined, commands don't return
+  AGENT: a NetLogo agent
+  AGENTSET: a NetLogo agentset
 
 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.
+  The specified AGENTSET or AGENT runs the given FN.  In the case of an
+  AGENTSET, 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)))))
+ (cond
+  ((agentset-p agent-or-agentset)
+   (let
+    ((iter (shufflerator (agentset-list agent-or-agentset))))
+    (loop
+     :for agent := (funcall iter)
+     :while agent
+     :do (let ((*myself* *self*) (*self* agent)) (with-stop-handler (funcall fn))))))
+  ((agent-p agent-or-agentset)
+   (let ((*myself* *self*) (*self* agent-or-agentset)) (with-stop-handler (funcall fn))))
+  (t
+   (error "Ask requires an agentset or agent but got: ~A" agent-or-agentset))))
+
+(defun count (agentset)
+ "COUNT AGENTSET => N
+
+ARGUMENTS AND VALUES:
+
+  AGENTSET: a NetLogo agentset
+  N: a number
+
+DESCRIPTION:
+
+  COUNT is equivalent to count in NetLogo.  Returns N, the number of
+  agents in AGENTSET.
+
+  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
+
+  AGENT-OR-AGENTSET: AGENT | AGENTSET
+  RESULT: RESULT-LIST | RESULT-VALUE
+
+ARGUMENTS AND VALUES:
+
+  FN: a function, run on each agent
+  AGENT: a NetLogo agent
+  AGENTSET: a NetLogo agentset
+  RESULT-LIST: a list
+  RESULT-VALUE: a single value
+
+DESCRIPTION:
+
+  OF is equivalent to of in NetLogo.
+
+  The specified AGENTSET or AGENT runs the given FN.  In the case of an
+  AGENTSET, 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.
+
+  RESULT-LIST is returned when the input is an AGENTSET, but RESULT-VALUE
+  is returned when only passed an AGENT.
+
+  See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#of"
+ (cond
+  ((agentset-p agent-or-agentset)
+   (let
+    ((iter (shufflerator (agentset-list agent-or-agentset))))
+    (loop
+     :for agent := (funcall iter)
+     :while agent
+     :collect (let ((*myself* *self*) (*self* agent)) (funcall fn)))))
+  ((agent-p agent-or-agentset)
+   (let ((*myself* *self*) (*self* agent-or-agentset)) (funcall fn)))
+  (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:
 
-(defun shufflerator (agent-set)
+  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 agent-set))
+  ((copy (copy-list agentset-list))
    (i 0)
    (agent nil))
   (flet
@@ -169,8 +324,104 @@ DESCRIPTION:
   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 (list-or-agentset)
+ "ONE-OF LIST-OR-AGENTSET => RESULT
+
+  LIST-OR-AGENTSET: LIST | AGENTSET
+  RESULT: RANDOM-VALUE | RANDOM-AGENT | :nobody
+
+ARGUMENTS AND VALUES:
+
+  LIST: A list
+  AGENTSET: An agent set
+  RANDOM-VALUE: a value in LIST
+  RANDOM-AGENT: an agent if AGENTSET is non empty
+
+DESCRIPTION:
+
+  From an AGENTSET, returns a RANDOM-AGENT. If the agentset is empty, returns :nobody.
+  From a list, returns a RANDOM-VALUE.  If the list is empty, an error occurs.
+
+  See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#one-of"
+ (cond
+  ((agentset-p list-or-agentset)
+   (let*
+    ((agentset-list (agentset-list list-or-agentset))
+     (length (length agentset-list)))
+    (if (zerop length) :nobody (nth (clnl-random:next-int length) agentset-list))))
+  ((listp list-or-agentset)
+   (let*
+    ((length (length list-or-agentset)))
+    (if (zerop length)
+     (error "one-of requires a nonempty list")
+     (nth (clnl-random:next-int length) list-or-agentset))))
+  (t (error "one-of requires a list or agentset"))))
+
 (defun jump (n)
- (when (not (turtle-p *self*)) (error "Gotta call fd in turtle scope, dude (~A)" *self*))
+ (when (not (turtle-p *self*)) (error "Gotta call jump in turtle scope, dude (~A)" *self*))
  (setf
   (turtle-xcor *self*)
   (wrap-x *topology*
@@ -180,6 +431,45 @@ DESCRIPTION:
   (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 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
 
@@ -245,12 +535,13 @@ 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 fn)
+ "CREATE-TURTLES N &optional FN => RESULT
 
 ARGUMENTS AND VALUES:
 
   N: an integer, the numbers of turtles to create
+  FN: A function, applied to each turtle after creation
   RESULT: undefined
 
 DESCRIPTION:
@@ -258,11 +549,35 @@ 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).
+  from the 14 primary colors.  If a function is supplied, the new turtles
+  immediately run it.
 
   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))))
+  (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 *self*))))
+  (when fn (ask (list->agentset new-turtles :turtles) fn))))
 
 (defun reset-ticks ()
  "RESET-TICKS => RESULT
@@ -313,10 +628,32 @@ 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)
+ "CREATE-WORLD &key DIMS GLOBALS TURTLES-OWN-VARS => RESULT
 
   DIMS: (:xmin XMIN :xmax XMAX :ymin YMIN :ymax YMAX)
+  GLOBALS: GLOBAL*
+  TURTLES-OWN-VARS: TURTLES-OWN-VAR*
+  GLOBAL: (GLOBAL-NAME GLOBAL-ACCESS-FUNC)
 
 ARGUMENTS AND VALUES:
 
@@ -325,6 +662,9 @@ 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
+  GLOBAL-NAME: Symbol for the global in the keyword package
+  GLOBAL-ACCESS-FUNC: Function to get the value of the global
 
 DESCRIPTION:
 
@@ -332,19 +672,13 @@ 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 *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* (list (list :turtles "default")))
+ (clear-ticks)
+ (clear-patches)
+ (clear-turtles))
 
 ; These match netlogo's dump
 (defgeneric dump-object (o))
@@ -358,11 +692,22 @@ DESCRIPTION:
     ; 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 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))
+ (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"))
+
 (defun current-state ()
  "CURRENT-STATE => WORLD-STATE
 
@@ -389,7 +734,8 @@ DESCRIPTION:
      :color (turtle-color turtle)
      :xcor (turtle-xcor turtle)
      :ycor (turtle-ycor turtle)
-     :heading (turtle-heading turtle)))
+     :heading (turtle-heading turtle)
+     :size (turtle-size turtle)))
    *turtles*)
   (mapcar
    (lambda (patch)
@@ -403,19 +749,25 @@ 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\",~A"
-     (turtle-who turtle)
+     "\"~A\",\"~A\",\"~A\",\"~A\",\"~A\",\"~A\",\"~A\",\"~A\",\"{all-turtles}\",\"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))
-     "\"\"\"default\"\"\",\"\"\"\"\"\",\"9.9\",\"{all-turtles}\",\"false\",\"1\",\"1\",\"\"\"up\"\"\""))
+     (dump-object (turtle-shape turtle))
+     (dump-object (turtle-label turtle))
+     (dump-object (turtle-label-color turtle))
+     (dump-object (turtle-size turtle))
+     "\"1\",\"\"\"up\"\"\""
+     (mapcar #'dump-object (mapcar (lambda (var) (agent-value-inner turtle var)) *turtles-own-vars*))))
    *turtles*)))
 
 (defun export-patches ()
@@ -452,11 +804,13 @@ DESCRIPTION:
    (format nil "~S" (clnl-random:export))
    ""
    (format nil "~S" "GLOBALS")
-   (format nil "~A~A"
+   (format nil "~A~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*)
+    "\"nextIndex\",\"directed-links\",\"ticks\","
+    (mapcar #'string-downcase (mapcar #'car *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 *globals*))))
    ""
    (format nil "~{~A~^~%~}" (export-turtles))
    ""