@#$#@#$#@
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"))
}
(: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")
(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
(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
; 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)
(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
: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)
: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))))
(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
(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))))
((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
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\""
+ ""))))
(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))))
(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)
(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)
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")
(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")
(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")
projects / clnl / commitdiff