From 807df6b6f160d82cc04ca02ce88d61ee58439ad1 Mon Sep 17 00:00:00 2001 From: Frank Duncan Date: Sat, 14 May 2016 01:30:49 -0500 Subject: [PATCH] Wolf sheep works in tests --- bin/runcmd.scala | 2 ++ src/main/clnl.asd | 2 +- src/main/code-parse.lisp | 2 +- src/main/main.lisp | 39 +++++++++++------------- src/main/nvm/agent.lisp | 6 ++++ src/main/nvm/base.lisp | 9 +++++- src/main/nvm/nvm.lisp | 64 ++++++++++++++++++++++----------------- src/main/nvm/utils.lisp | 7 +++-- src/main/transpile.lisp | 9 ++++-- src/test/main.lisp | 41 +++++++++++++++++++++++++ src/test/modeltests.lisp | 8 +++++ src/test/simpletests.lisp | 9 ++++++ 12 files changed, 140 insertions(+), 58 deletions(-) diff --git a/bin/runcmd.scala b/bin/runcmd.scala index b91ed4e..12e49a7 100755 --- a/bin/runcmd.scala +++ b/bin/runcmd.scala @@ -86,6 +86,8 @@ Polygon -7500403 true false 219 85 210 105 193 99 201 83 @#$#@#$#@ 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")) } diff --git a/src/main/clnl.asd b/src/main/clnl.asd index 1f90141..c3ec27e 100644 --- a/src/main/clnl.asd +++ b/src/main/clnl.asd @@ -10,8 +10,8 @@ (:file "parse") (:file "code-parse") (:file "nvm/base") - (:file "nvm/agent") (:file "nvm/utils") + (:file "nvm/agent") (:file "nvm/nvm") (:file "nvm/topology") (:file "transpile") diff --git a/src/main/code-parse.lisp b/src/main/code-parse.lisp index 1cb6662..5fe98b8 100644 --- a/src/main/code-parse.lisp +++ b/src/main/code-parse.lisp @@ -67,7 +67,7 @@ DESCRIPTION: (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 diff --git a/src/main/main.lisp b/src/main/main.lisp index 5d8856e..0997963 100644 --- a/src/main/main.lisp +++ b/src/main/main.lisp @@ -132,28 +132,23 @@ DESCRIPTION: (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 diff --git a/src/main/nvm/agent.lisp b/src/main/nvm/agent.lisp index 8e97ea0..e20efa2 100644 --- a/src/main/nvm/agent.lisp +++ b/src/main/nvm/agent.lisp @@ -38,6 +38,12 @@ DESCRIPTION: ; 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) diff --git a/src/main/nvm/base.lisp b/src/main/nvm/base.lisp index 063dfb5..7fec1df 100644 --- a/src/main/nvm/base.lisp +++ b/src/main/nvm/base.lisp @@ -15,6 +15,7 @@ (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 @@ -31,7 +32,13 @@ DESCRIPTION: :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) diff --git a/src/main/nvm/nvm.lisp b/src/main/nvm/nvm.lisp index c31640e..5540cae 100644 --- 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)) + :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) - :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)))) @@ -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*)) - (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 @@ -176,9 +182,10 @@ DESCRIPTION: (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) - (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)))) @@ -313,13 +320,14 @@ DESCRIPTION: ((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))) - (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 @@ -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." - (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\"" + "")))) diff --git a/src/main/nvm/utils.lisp b/src/main/nvm/utils.lisp index f95fb7f..0a5f604 100644 --- a/src/main/nvm/utils.lisp +++ b/src/main/nvm/utils.lisp @@ -39,12 +39,13 @@ (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))) - (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))) - (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)))) diff --git a/src/main/transpile.lisp b/src/main/transpile.lisp index 91af23a..956b226 100644 --- a/src/main/transpile.lisp +++ b/src/main/transpile.lisp @@ -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) - `(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) diff --git a/src/test/main.lisp b/src/test/main.lisp index e02a5d4..ca65797 100644 --- a/src/test/main.lisp +++ b/src/test/main.lisp @@ -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 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) diff --git a/src/test/modeltests.lisp b/src/test/modeltests.lisp index 8f2d12a..144b549 100644 --- a/src/test/modeltests.lisp +++ b/src/test/modeltests.lisp @@ -122,3 +122,11 @@ to go 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") diff --git a/src/test/simpletests.lisp b/src/test/simpletests.lisp index 78293e0..aa6a309 100644 --- a/src/test/simpletests.lisp +++ b/src/test/simpletests.lisp @@ -117,6 +117,9 @@ (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") @@ -144,6 +147,12 @@ (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") -- 2.25.1