Wolf sheep works in tests
authorFrank Duncan <frank@kank.net>
Sat, 14 May 2016 06:30:49 +0000 (01:30 -0500)
committerFrank Duncan <frank@kank.net>
Sat, 14 May 2016 06:30:49 +0000 (01:30 -0500)
12 files changed:
bin/runcmd.scala
src/main/clnl.asd
src/main/code-parse.lisp
src/main/main.lisp
src/main/nvm/agent.lisp
src/main/nvm/base.lisp
src/main/nvm/nvm.lisp
src/main/nvm/utils.lisp
src/main/transpile.lisp
src/test/main.lisp
src/test/modeltests.lisp
src/test/simpletests.lisp

index b91ed4e482999eacf455b99f600ce6d81f85894b..12e49a7703d77ecdcde971af46f2594c5d9dc42f 100755 (executable)
@@ -86,6 +86,8 @@ Polygon -7500403 true false 219 85 210 105 193 99 201 83
 
 @#$#@#$#@
 NetLogo 5.2.0""")
 
 @#$#@#$#@
 NetLogo 5.2.0""")
+} else if (input.length > 3 && input(3).length > 0) {
+  workspace.openFromSource(url2String("file:" + input(3)))
 } else {
   workspace.openFromSource(url2String("file:resources/empty.nlogo"))
 }
 } else {
   workspace.openFromSource(url2String("file:resources/empty.nlogo"))
 }
index 1f901411e37ceb347ea0c66fa9f0212b4c69fd76..c3ec27e3af697586c8e6a8a167010ce573162e06 100644 (file)
@@ -10,8 +10,8 @@
               (:file "parse")
               (:file "code-parse")
               (:file "nvm/base")
               (:file "parse")
               (:file "code-parse")
               (:file "nvm/base")
-              (:file "nvm/agent")
               (:file "nvm/utils")
               (:file "nvm/utils")
+              (:file "nvm/agent")
               (:file "nvm/nvm")
               (:file "nvm/topology")
               (:file "transpile")
               (:file "nvm/nvm")
               (:file "nvm/topology")
               (:file "transpile")
index 1cb666211151e9f3e630fa356e11131336b2d3da..5fe98b8d32b89d94d53a72447c14a68897482557 100644 (file)
@@ -67,7 +67,7 @@ DESCRIPTION:
  (let*
   ((*dynamic-prims*
     (append
  (let*
   ((*dynamic-prims*
     (append
-     (mapcar #'global->prim external-globals)
+     (mapcar #'global->prim (mapcar #'car external-globals))
      (procedures->prims lexed-ast)))
    (parsed (parse-internal lexed-ast)))
   (values
      (procedures->prims lexed-ast)))
    (parsed (parse-internal lexed-ast)))
   (values
index 5d8856e3522c9eec429a58b1d38f3c3963262919..0997963960d63dff7d1b8d51ec73ea96b118ed2d 100644 (file)
@@ -132,28 +132,23 @@ DESCRIPTION:
   (let
    ((globals
      (append
   (let
    ((globals
      (append
-      (clnl-model:widget-globals model)
-      (clnl-code-parser:globals code-ast))))
-   `(prog ()
-     ; First declare is in case we don't use it, it shows up in export correctly
-     ,@(when (and (> (length globals) 0) netlogo-callback)
-        `((declare (special ,@(mapcar (lambda (pair) (intern (string-upcase (car pair)) *model-package*)) globals)))))
-     (let
-      ,(mapcar (lambda (pair) (list (intern (string-upcase (car pair)) *model-package*) (cadr pair))) globals)
-      ; We declare twice rather than once and doing a bunch of setfs
-      ,@(when (and (> (length globals) 0) netlogo-callback)
-         `((declare (special ,@(mapcar (lambda (pair) (intern (string-upcase (car pair)) *model-package*)) globals)))))
-      (labels
-       ,(mapcar
-         (lambda (proc) (create-proc-body proc prims))
-         (clnl-code-parser:procedures code-ast))
-       (clnl-random:set-seed ,seed)
-       ,(create-world-call model globals code-ast)
-       ,@(when netlogo-callback
-          `((funcall ,netlogo-callback
-             (lambda (,(intern "NETLOGO-CODE" *model-package*))
-              ,(netlogo-callback-body prims)))))
-       ,@(when initialize-interface `((clnl-interface:initialize :dims ',(clnl-model:world-dimensions model))))))))))
+      (clnl-code-parser:globals code-ast)
+      (clnl-model:widget-globals model))))
+   `(progn
+     ,@(mapcar
+        (lambda (pair) `(defparameter ,(intern (string-upcase (car pair)) *model-package*) ,(cadr pair)))
+        globals)
+     (labels
+      ,(mapcar
+        (lambda (proc) (create-proc-body proc prims))
+        (clnl-code-parser:procedures code-ast))
+      (clnl-random:set-seed ,seed)
+      ,(create-world-call model globals code-ast)
+      ,@(when netlogo-callback
+         `((funcall ,netlogo-callback
+            (lambda (,(intern "NETLOGO-CODE" *model-package*))
+             ,(netlogo-callback-body prims)))))
+      ,@(when initialize-interface `((clnl-interface:initialize :dims ',(clnl-model:world-dimensions model)))))))))
 
 (setf (documentation 'model->single-form-lisp 'function)
  "MODEL->SINGLE-FORM-LISP MODEL &key SEED INITIALIZE-INTERFACE NETLOGO-CALLBACK => FORM
 
 (setf (documentation 'model->single-form-lisp 'function)
  "MODEL->SINGLE-FORM-LISP MODEL &key SEED INITIALIZE-INTERFACE NETLOGO-CALLBACK => FORM
index 8e97ea002c5bdf5ff4c06e12c8cd5a2b04ef9283..e20efa20fcbd4f39233e14572cc311244b944de4 100644 (file)
@@ -38,6 +38,12 @@ DESCRIPTION:
 ; Don't want the setter for :who
 (defmethod agent-value-inner ((turtle turtle) (var (eql :who))) (turtle-who turtle))
 
 ; Don't want the setter for :who
 (defmethod agent-value-inner ((turtle turtle) (var (eql :who))) (turtle-who turtle))
 
+(defmethod agent-value-inner ((turtle turtle) (var (eql :pcolor)))
+ (patch-color (patch-at (turtle-xcor turtle) (turtle-ycor turtle))))
+
+(defmethod set-agent-value-inner ((turtle turtle) (var (eql :pcolor)) new-val)
+ (setf (patch-color (patch-at (turtle-xcor turtle) (turtle-ycor turtle))) new-val))
+
 (defagent-value patch :pcolor patch-color)
 
 (defagent-value turtle :color)
 (defagent-value patch :pcolor patch-color)
 
 (defagent-value turtle :color)
index 063dfb5523bd7105f0698b5e11bbb59fb86da2bd..7fec1df58b86f5cef20f5c37cd98b8fc093939da 100644 (file)
@@ -15,6 +15,7 @@
 (defvar *breeds* nil)
 
 (define-condition stop nil nil)
 (defvar *breeds* nil)
 
 (define-condition stop nil nil)
+(define-condition death nil nil)
 
 (defmacro with-stop-handler (&rest forms)
  "MACRO WITH-STOP-HANDLER &rest FORMS => HANDLED-FORM
 
 (defmacro with-stop-handler (&rest forms)
  "MACRO WITH-STOP-HANDLER &rest FORMS => HANDLED-FORM
@@ -31,7 +32,13 @@ DESCRIPTION:
   :stop is returned."
  `(handler-case (progn ,@forms) (stop (s) (declare (ignore s)) :stop)))
 
   :stop is returned."
  `(handler-case (progn ,@forms) (stop (s) (declare (ignore s)) :stop)))
 
-(defstruct turtle who breed color heading xcor ycor (label "") (label-color 9.9d0) (size 1d0) shape own-vars)
+(defmacro with-stop-and-death-handler (&rest forms)
+ `(handler-case
+   (progn ,@forms)
+   (stop (s) (declare (ignore s)) :stop)
+   (death (d) (declare (ignore d)) :death)))
+
+(defstruct turtle who breed color heading xcor ycor (label "") label-color size shape own-vars)
 (defstruct patch color xcor ycor own-vars turtles)
 
 (defun agentset-list (agentset)
 (defstruct patch color xcor ycor own-vars turtles)
 
 (defun agentset-list (agentset)
index c31640e24b1333bd2fdd8dc4f7416a93331d2701..5540caea05bad45b54cb49f30cd6e8f9138c4004 100644 (file)
@@ -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\""
+    ""))))
index f95fb7fd8e5dd55044acb9fd7b86da7bd1e6502b..0a5f60486a61cee023770b7cddd5332d3e046b62 100644 (file)
 
 (defmacro with-patch-update (turtle &rest forms)
  (let
 
 (defmacro with-patch-update (turtle &rest forms)
  (let
-  ((patch (gensym)) (new-patch (gensym)))
+  ((patch (gensym)) (new-patch (gensym)) (retn (gensym)))
   `(let
     ((,patch (patch-at (turtle-xcor ,turtle) (turtle-ycor ,turtle)))
   `(let
     ((,patch (patch-at (turtle-xcor ,turtle) (turtle-ycor ,turtle)))
-     (retn (progn ,@forms)))
+     (,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)))
     (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))))))))
+      (setf (patch-turtles ,new-patch) (nconc (patch-turtles ,new-patch) (list ,turtle))))
+     ,retn))))
index 91af23a000d0d6208725416968e290ed5f98e19e..956b226eaea577f61fb3de51b4ac0417e8761a4d 100644 (file)
@@ -196,9 +196,12 @@ DESCRIPTION:
 (defprim :if :command (lambda (pred a) `(when ,pred ,@(make-command-block-inline a))))
 (defprim '(:ifelse :if-else)
  :command (lambda (pred a b)
 (defprim :if :command (lambda (pred a) `(when ,pred ,@(make-command-block-inline a))))
 (defprim '(:ifelse :if-else)
  :command (lambda (pred a b)
-           `(if ,pred
-             ,@(make-command-block-inline a)
-             ,@(make-command-block-inline b))))
+           (let
+            ((then (make-command-block-inline a))
+             (else (make-command-block-inline b)))
+            `(if ,pred
+              ,@(if (= (length then) 1) then `((progn ,@then)))
+              ,@(if (= (length else) 1) else `((progn ,@else)))))))
 
 (defagentvalueprim :label)
 (defagentvalueprim :label-color)
 
 (defagentvalueprim :label)
 (defagentvalueprim :label-color)
index e02a5d45dc20bb234703ae90172f825fe0e98a47..ca65797028f4b37b219fcf75719b536f9dda9686 100644 (file)
@@ -166,6 +166,47 @@ GRAPHICS-WINDOW~%210~%10~%649~%470~%-1~%-1~%13.0~%1~%10~%1~%1~%1~%0~%1~%1~%1~%-1
 (defmacro defmodelreportertest (name model commands reporter value checksum)
  `(defmodeltest (format nil "Model Reporter - ~A" ,name) ,model ,commands ,reporter ,value ,checksum))
 
 (defmacro defmodelreportertest (name model commands reporter value checksum)
  `(defmodeltest (format nil "Model Reporter - ~A" ,name) ,model ,commands ,reporter ,value ,checksum))
 
+(defmacro defmodelfiletest (name file commands checksum)
+ `(defsimpletest
+   ,(format nil "File Model - ~A" name)
+   (lambda ()
+    (let
+     ((model (with-open-file (str ,file) (clnl-model:read-from-nlogo str))))
+     (and
+      (let
+       ((callback nil))
+       (declaim (sb-ext:muffle-conditions cl:warning))
+       (eval (clnl:model->single-form-lisp model :netlogo-callback (lambda (f) (setf callback f))))
+       (when ,commands (funcall callback ,commands))
+       (checksum= ,checksum (checksum-world)))
+      (let*
+       ((pkg (make-package (gensym)))
+        (clnl:*model-package* pkg)
+        (prev-package *package*))
+       (eval
+        (cons
+         'progn
+         (clnl:model->multi-form-lisp model (intern "BOOT-ME" pkg)
+          :netlogo-callback-fn (intern "NETLOGO-CALLBACK" pkg))))
+       (eval `(in-package ,(package-name prev-package)))
+       (funcall (symbol-function (intern "BOOT-ME" pkg)))
+       (when ,commands (funcall (symbol-function (intern "NETLOGO-CALLBACK" pkg)) ,commands))
+       (checksum= ,checksum (checksum-world))))))
+   (lambda ()
+    (let
+     ((callback nil))
+     (declaim (sb-ext:muffle-conditions cl:warning))
+     (eval
+      (clnl:model->single-form-lisp
+       (with-open-file (str ,file) (clnl-model:read-from-nlogo str))
+       :netlogo-callback (lambda (f) (setf callback f))))
+     (when ,commands (funcall callback ,commands))
+     (format nil "~A~A"
+      (clnl-nvm:export-world)
+      (checksum-world))))
+   "bin/runcmd.scala"
+   (format nil "~A@#$#@#$#@@#$#@#$#@@#$#@#$#@~A" ,commands ,file)))
+
 (defmacro defviewtest (name commands checksum)
  `(defsimpletest
    (format nil "Simple View - ~A" ,name)
 (defmacro defviewtest (name commands checksum)
  `(defsimpletest
    (format nil "Simple View - ~A" ,name)
index 8f2d12a094e9ddbaaf63e1edf3179d8d7e8b2c33..144b5491eaf477bf2e76329e88befb65f6bf7c44 100644 (file)
@@ -122,3 +122,11 @@ to go
 end"
  "setup go go"
  "438848EF35C6B0D28D50961072C70FCC02BB4FD8")
 end"
  "setup go go"
  "438848EF35C6B0D28D50961072C70FCC02BB4FD8")
+
+(defmodelfiletest "Wolf Sheep 1" "resources/models/Wolf Sheep Predation.nlogo"
+ "setup go go go go go go go go go go go go go go"
+ "9777CCF18935E52D8380C9C6DC02BFFBEE1F1149")
+
+(defmodelfiletest "Wolf Sheep 2" "resources/models/Wolf Sheep Predation.nlogo"
+ "set grass? not grass? setup go go go go go go go go go go go go go go"
+ "FC38F01DC0058C5EFF93F2228535ED7C616ECFF0")
index 78293e0f3a2a0cc8231d764b0a84e8af17e68b19..aa6a309d9dc786f84fcb7e7ae580aa27a867a053 100644 (file)
 (defsimplecommandtest "die 2" "crt 10 ask turtles [ hatch 1 die hatch 1 ]"
  "DFB46C61ACB9A24004FF26B04DCB0AC32E90AA36")
 
 (defsimplecommandtest "die 2" "crt 10 ask turtles [ hatch 1 die hatch 1 ]"
  "DFB46C61ACB9A24004FF26B04DCB0AC32E90AA36")
 
+(defsimplecommandtest "die 3" "crt 5 ask turtles [ ask one-of turtles-here [ die ] hatch 1 ]"
+ "6D3B8351E71C03E479706C22172F6FACD2C558CE")
+
 (defreportertestwithsetup "any? 3" "crt 10 ask turtles [ die ]" "any? turtles" "false"
  "A665C1BF95E1F9CAAE9B9F8B2FBE3DAA45453136")
 
 (defreportertestwithsetup "any? 3" "crt 10 ask turtles [ die ]" "any? turtles" "false"
  "A665C1BF95E1F9CAAE9B9F8B2FBE3DAA45453136")
 
 (defsimplecommandtest "ifelse 2" "ifelse 5 = 4 [ crt 10 ] [ crt 5 ] if-else 5 = 4 [ crt 10 ] [ crt 5 ]"
  "A925E39EC022967568D238D31F70F0A375024A89")
 
 (defsimplecommandtest "ifelse 2" "ifelse 5 = 4 [ crt 10 ] [ crt 5 ] if-else 5 = 4 [ crt 10 ] [ crt 5 ]"
  "A925E39EC022967568D238D31F70F0A375024A89")
 
+(defsimplecommandtest "ifelse 3" "ifelse 4 = 4 [ crt 5 crt 5 ] [ crt 10 crt 10 ]"
+ "A925E39EC022967568D238D31F70F0A375024A89")
+
+(defsimplecommandtest "ifelse 4" "ifelse 4 = 5 [ crt 5 crt 5 ] [ crt 10 crt 10 ]"
+ "2CF70DC9135754E77B64422C10E947E776E731E6")
+
 (defsimplecommandtest "not 1" "if not (5 = 5) [ crt 10 ]"
  "E1DE30F072D785E0D0B59F28B0F7853E3D3E0D8B")
 
 (defsimplecommandtest "not 1" "if not (5 = 5) [ crt 10 ]"
  "E1DE30F072D785E0D0B59F28B0F7853E3D3E0D8B")