Prims - Implement turtles-here

diff --git a/src/main/nvm/base.lisp b/src/main/nvm/base.lisp
index 945c5e8ea01e02dbad5d87b7ad9ba45f48960357..294715abec2b8aa53303375d21b47696decdb8e1 100644 (file)
--- a/src/main/nvm/base.lisp
+++ b/src/main/nvm/base.lisp
@@ -32,7 +32,7 @@ DESCRIPTION:
  `(handler-case (progn ,@forms) (stop (s) (declare (ignore s)) :stop)))
 
 (defstruct turtle who color heading xcor ycor (label "") (label-color 9.9d0) (size 1d0) shape own-vars)
-(defstruct patch color xcor ycor own-vars)
+(defstruct patch color xcor ycor own-vars turtles)
 
 (defun agentset-list (agentset)
  (cond

diff --git a/src/main/nvm/nvm.lisp b/src/main/nvm/nvm.lisp
index 42a269a35be376cb7ab50b8bdf70e1163026b62c..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

diff --git a/src/main/nvm/utils.lisp b/src/main/nvm/utils.lisp
index a656df32eb37dd6b89f12d444d40d25f51b42248..f95fb7fd8e5dd55044acb9fd7b86da7bd1e6502b 100644 (file)
--- a/src/main/nvm/utils.lisp
+++ b/src/main/nvm/utils.lisp
@@ -26,3 +26,25 @@
 
 (defun using-cached-cos (n)
  (if (= (floor n) n) (nth (floor n) *cached-coses*) (strictmath:cos (strictmath:to-radians n))))
+
+(defun patch-at (xcor ycor)
+ (flet
+  ((rnd (d) (truncate (if (< d 0) (- d 0.5d0) (+ d 0.5d0)))))
+  (or
+   (find-if
+    (lambda (patch)
+     (and (equalp (patch-xcor patch) (rnd xcor)) (equalp (patch-ycor patch) (rnd ycor))))
+    *patches*)
+   (error "This shouldn't be possible: ~S ~S ~S" (rnd xcor) (rnd ycor) *patches*))))
+
+(defmacro with-patch-update (turtle &rest forms)
+ (let
+  ((patch (gensym)) (new-patch (gensym)))
+  `(let
+    ((,patch (patch-at (turtle-xcor ,turtle) (turtle-ycor ,turtle)))
+     (retn (progn ,@forms)))
+    (let
+     ((,new-patch (patch-at (turtle-xcor ,turtle) (turtle-ycor ,turtle))))
+     (when (not (eql ,patch ,new-patch))
+      (setf (patch-turtles ,patch) (remove ,turtle (patch-turtles ,patch)))
+      (setf (patch-turtles ,new-patch) (nconc (patch-turtles ,new-patch) (list ,turtle))))))))

diff --git a/src/main/package.lisp b/src/main/package.lisp
index 92796dc095a346d491bcf6ffd2517721daaa433c..ac81d3f08bc6afb43abbd60587cfb28deb543f24 100644 (file)
--- a/src/main/package.lisp
+++ b/src/main/package.lisp
@@ -92,6 +92,7 @@ into an ast that can be transpiled later."))
   #:show
   #:stop
   #:turtles
+  #:turtles-here
   #:tick
   #:ticks
   #:turn-right #:turn-left

diff --git a/src/main/parse.lisp b/src/main/parse.lisp
index 6d45ed52cffb74e54f563a789d4793008ff7bc23..a44caeaa0df8704d984116dcde11d6c233bd03d1 100644 (file)
--- a/src/main/parse.lisp
+++ b/src/main/parse.lisp
@@ -321,6 +321,7 @@ DESCRIPTION:
 (defprim :tick () 0)
 (defprim :ticks () 10)
 (defprim :turtles () 10)
+(defprim :turtles-here () 10)
 (defprim :who () 10)
 
 ; colors

diff --git a/src/main/transpile.lisp b/src/main/transpile.lisp
index 327bdbd6d96c43e86a12394a5631cf994fbf67a8..b1406533bbe5dc214c79dad724752382e74e325a 100644 (file)
--- a/src/main/transpile.lisp
+++ b/src/main/transpile.lisp
@@ -226,6 +226,7 @@ DESCRIPTION:
 (defsimpleprim :tick :command clnl-nvm:tick)
 (defsimpleprim :ticks :reporter clnl-nvm:ticks)
 (defsimpleprim :turtles :reporter clnl-nvm:turtles)
+(defsimpleprim :turtles-here :reporter clnl-nvm:turtles-here)
 (defagentvalueprim :who)
 (defsimpleprim :with :reporter clnl-nvm:with)
 

diff --git a/src/test/simpletests.lisp b/src/test/simpletests.lisp
index 49631642fb7220e13a0daca9ee62b550a3e1f67d..9bf58d303f84901a02d9317140e66780869cc901 100644 (file)
--- a/src/test/simpletests.lisp
+++ b/src/test/simpletests.lisp
@@ -265,3 +265,7 @@
 
 (defsimplecommandtest "stop 2" "crt 10 ask turtles [ fd 1 stop fd 1 ]"
  "A6C980CC9843CDD211ABD9C13899010D555F3DC5")
+
+(defsimplecommandtest "turtles-here 1"
+ "crt 1000 ask turtles [ fd random-float 10 ] ask turtles [ set label [ who ] of one-of turtles-here ]"
+ "F34192513765D221A15D939A2BC8FFE18B6ADF4C")