Code - turtles-own

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

diff --git a/src/main/nvm/nvm.lisp b/src/main/nvm/nvm.lisp
index 6fdc812964cb72e5f4c0a73b58d955615bcd3b52..dcba15148fee16839967859fd016dea94fb50a6c 100644 (file)
--- a/src/main/nvm/nvm.lisp
+++ b/src/main/nvm/nvm.lisp
@@ -58,6 +58,7 @@ DESCRIPTION:
                 :heading (if base-turtle
                           (turtle-heading base-turtle)
                           (coerce (clnl-random:next-int 360) '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)))
                 :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)))


@@ -149,9 +150,9 @@ DESCRIPTION:
     (loop
      :for agent := (funcall iter)
      :while agent
     (loop
      :for agent := (funcall iter)
      :while agent

-     :do (let ((*myself* *self*) (*self* agent)) (funcall fn)))))
+     :do (let ((*myself* *self*) (*self* agent)) (with-stop-handler (funcall fn))))))

   ((agent-p agent-or-agentset)
   ((agent-p agent-or-agentset)

-   (let ((*myself* *self*) (*self* agent-or-agentset)) (funcall fn)))
+   (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))))
 
   (t
    (error "Ask requires an agentset or agent but got: ~A" agent-or-agentset))))
 


@@ -171,6 +172,53 @@ DESCRIPTION:
   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#count"
  (coerce (length (agentset-list agentset)) 'double-float))
 
   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
 
 (defun of (fn agent-or-agentset)
  "OF FN AGENT-OR-AGENTSET => RESULT
 


@@ -402,6 +450,26 @@ DESCRIPTION:
  (setf (turtle-xcor *self*) (wrap-x *topology* x))
  (setf (turtle-ycor *self*) (wrap-y *topology* y)))
 
  (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
 
 (defun forward (n)
  "FORWARD N => RESULT
 


@@ -560,10 +628,32 @@ DESCRIPTION:
  (when (not *ticks*) (error "reset-ticks must be called"))
  *ticks*)
 
  (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)
 
   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:
 
 
 ARGUMENTS AND VALUES:
 


@@ -572,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
   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:
 
 
 DESCRIPTION:
 


@@ -579,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."
 
   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 *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))
 
 ; These match netlogo's dump
 (defgeneric dump-object (o))


@@ -662,22 +749,25 @@ DESCRIPTION:
  (append
   (list
    "\"TURTLES\""
  (append
   (list
    "\"TURTLES\""

-   (format nil "~A~A"
+   (format nil "~A~A~{,\"~A\"~}"

     "\"who\",\"color\",\"heading\",\"xcor\",\"ycor\",\"shape\",\"label\",\"label-color\","
     "\"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
   (mapcar
    (lambda (turtle)
     (format nil

-     "\"~A\",\"~A\",\"~A\",\"~A\",\"~A\",\"\"\"default\"\"\",\"~A\",\"~A\",\"{all-turtles}\",\"false\",\"~A\",~A"
+     "\"~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))
      (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-shape turtle))

      (dump-object (turtle-label turtle))
      (dump-object (turtle-label-color turtle))
      (dump-object (turtle-size turtle))
      (dump-object (turtle-label turtle))
      (dump-object (turtle-label-color turtle))
      (dump-object (turtle-size turtle))

-     "\"1\",\"\"\"up\"\"\""))
+     "\"1\",\"\"\"up\"\"\""
+     (mapcar #'dump-object (mapcar (lambda (var) (agent-value-inner turtle var)) *turtles-own-vars*))))

    *turtles*)))
 
 (defun export-patches ()
    *turtles*)))
 
 (defun export-patches ()


@@ -714,11 +804,13 @@ DESCRIPTION:
    (format nil "~S" (clnl-random:export))
    ""
    (format nil "~S" "GLOBALS")
    (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\","
     "\"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))
    ""
    ""
    (format nil "~{~A~^~%~}" (export-turtles))
    ""