Prims - Implement turtles-here

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

diff --git a/src/main/nvm/nvm.lisp b/src/main/nvm/nvm.lisp
index 766df5379bf232623274271bbc58c7273cdf23ce..bcf4be1d9ffdd055850ed130c2cb17ba67839bda 100644 (file)
--- a/src/main/nvm/nvm.lisp
+++ b/src/main/nvm/nvm.lisp
@@ -61,6 +61,9 @@ DESCRIPTION:
                 :shape (breed-default-shape :turtles)
                 :xcor (if base-turtle (turtle-xcor base-turtle) 0d0)
                 :ycor (if base-turtle (turtle-ycor base-turtle) 0d0))))
+  (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))
@@ -122,6 +125,22 @@ DESCRIPTION:
   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#turtles"
  :turtles)
 
+(defun turtles-here ()
+ "TURTLES-HERE => TURTLES
+
+ARGUMENTS AND VALUES:
+
+  TURTLES: an agentset
+
+DESCRIPTION:
+
+  Returns the agentset consisting of all the turtles sharing the patch
+  with the agent in by *self*
+
+  See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#turtles-here"
+ (when (not (turtle-p *self*)) (error "Gotta call turtles-here with a turtle"))
+ (list->agentset (patch-turtles (patch-at (turtle-xcor *self*) (turtle-ycor *self*))) :turtles))
+
 (defun ask (agent-or-agentset fn)
  "ASK AGENT-OR-AGENTSET FN => RESULT
 
@@ -422,14 +441,15 @@ DESCRIPTION:
 
 (defun jump (n)
  (when (not (turtle-p *self*)) (error "Gotta call jump 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*)))))))
+ (with-patch-update *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 setxy (x y)
  "SETXY X Y => RESULT
@@ -647,12 +667,14 @@ DESCRIPTION:
 (defun clear-ticks ()
  (setf *ticks* nil))
 
-(defun create-world (&key dims globals)
- "CREATE-WORLD &key DIMS GLOBALS => RESULT
+(defun create-world (&key dims globals turtles-own-vars patches-own-vars)
+ "CREATE-WORLD &key DIMS GLOBALS TURTLES-OWN-VARS PATCHES-OWN-VARS => RESULT
 
   DIMS: (:xmin XMIN :xmax XMAX :ymin YMIN :ymax YMAX)
   GLOBALS: GLOBAL*
-  GLOBAL: (NAME ACCESS-FUNC)
+  TURTLES-OWN-VARS: TURTLES-OWN-VAR*
+  PATCHES-OWN-VARS: PATCHES-OWN-VAR*
+  GLOBAL: (GLOBAL-NAME GLOBAL-ACCESS-FUNC)
 
 ARGUMENTS AND VALUES:
 
@@ -661,8 +683,10 @@ 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
-  NAME: Symbol for the global in the keyword package
-  ACCESS-FUNC: Function to get the value of the global
+  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
+  GLOBAL-NAME: Symbol for the global in the keyword package
+  GLOBAL-ACCESS-FUNC: Function to get the value of the global
 
 DESCRIPTION:
 
@@ -670,6 +694,8 @@ 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 *globals* globals)
  (setf *breeds* (list (list :turtles "default")))
@@ -746,13 +772,14 @@ 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\",\"~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))
@@ -762,21 +789,24 @@ DESCRIPTION:
      (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 ()
  (append
   (list
    "\"PATCHES\""
-   "\"pxcor\",\"pycor\",\"pcolor\",\"plabel\",\"plabel-color\"")
+   (format nil "\"pxcor\",\"pycor\",\"pcolor\",\"plabel\",\"plabel-color\"~{,\"~A\"~}"
+    (mapcar #'string-downcase *patches-own-vars*)))
   (mapcar
    (lambda (patch)
     (format nil
-     "\"~A\",\"~A\",\"~A\",\"\"\"\"\"\",\"9.9\""
+     "\"~A\",\"~A\",\"~A\",\"\"\"\"\"\",\"9.9\"~{,\"~A\"~}"
      (dump-object (patch-xcor patch))
      (dump-object (patch-ycor patch))
-     (dump-object (patch-color patch))))
+     (dump-object (patch-color patch))
+     (mapcar #'dump-object (mapcar (lambda (var) (agent-value-inner patch var)) *patches-own-vars*))))
    *patches*)))
 
 (defun export-world ()