Wolf sheep works in tests

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

diff --git a/src/main/nvm/nvm.lisp b/src/main/nvm/nvm.lisp
index c31640e24b1333bd2fdd8dc4f7416a93331d2701..5540caea05bad45b54cb49f30cd6e8f9138c4004 100644 (file)
--- a/src/main/nvm/nvm.lisp
+++ b/src/main/nvm/nvm.lisp
@@ -59,10 +59,13 @@ 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))

+                :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)
                 :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))))
+                :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))))
   (let
    ((patch (patch-at (turtle-xcor new-turtle) (turtle-ycor new-turtle))))
    (setf (patch-turtles patch) (nconc (patch-turtles patch) (list new-turtle))))


@@ -92,7 +95,10 @@ DESCRIPTION:
  (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*))
  (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*))

- (error (make-condition 'stop)))
+ (let
+  ((patch (patch-at (turtle-xcor *self*) (turtle-ycor *self*))))
+  (setf (patch-turtles patch) (remove *self* (patch-turtles patch))))
+ (error (make-condition 'death)))

 
 (defun patches ()
  "PATCHES => ALL-PATCHES
 
 (defun patches ()
  "PATCHES => ALL-PATCHES


@@ -176,9 +182,10 @@ DESCRIPTION:
     (loop
      :for agent := (funcall iter)
      :while agent
     (loop
      :for agent := (funcall iter)
      :while agent

-     :do (let ((*myself* *self*) (*self* agent)) (with-stop-handler (funcall fn))))))
+     :do (when (not (and (turtle-p agent) (= -1 (turtle-who agent))))
+          (let ((*myself* *self*) (*self* agent)) (with-stop-and-death-handler (funcall fn)))))))

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

-   (let ((*myself* *self*) (*self* agent-or-agentset)) (with-stop-handler (funcall fn))))
+   (let ((*myself* *self*) (*self* agent-or-agentset)) (with-stop-and-death-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))))
 


@@ -313,13 +320,14 @@ DESCRIPTION:
   ((copy (copy-list agentset-list))
    (i 0)
    (agent nil))
   ((copy (copy-list agentset-list))
    (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


@@ -843,24 +851,26 @@ DESCRIPTION:
   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."
   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~{\"~A\"~^,~}"
-    "\"min-pxcor\",\"max-pxcor\",\"min-pycor\",\"max-pycor\",\"perspective\",\"subject\","
-    "\"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-patches))
-   ""
-   (format nil "~S" "LINKS")
-   "\"end1\",\"end2\",\"color\",\"label\",\"label-color\",\"hidden?\",\"breed\",\"thickness\",\"shape\",\"tie-mode\""
-   "")))
+ (let
+  ((ordered-globals (sort (copy-list *globals*) #'string< :key (lambda (global) (symbol-name (car global))))))
+  (format nil "~{~A~%~}"
+   (list
+    (format nil "~S" "RANDOM STATE")
+    (format nil "~S" (clnl-random:export))
+    ""
+    (format nil "~S" "GLOBALS")
+    (format nil "~A~A~{\"~A\"~^,~}"
+     "\"min-pxcor\",\"max-pxcor\",\"min-pycor\",\"max-pycor\",\"perspective\",\"subject\","
+     "\"nextIndex\",\"directed-links\",\"ticks\","
+     (mapcar #'string-downcase (mapcar #'car ordered-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 ordered-globals))))
+    ""
+    (format nil "~{~A~^~%~}" (export-turtles))
+    ""
+    (format nil "~{~A~^~%~}" (export-patches))
+    ""
+    (format nil "~S" "LINKS")
+    "\"end1\",\"end2\",\"color\",\"label\",\"label-color\",\"hidden?\",\"breed\",\"thickness\",\"shape\",\"tie-mode\""
+    ""))))