@#$#@#$#@
@#$#@#$#@
+default
+true
+0
+Polygon -7500403 true true 150 5 40 250 150 205 260 250
+
+sheep
+false
+15
+Circle -1 true true 203 65 88
+Circle -1 true true 70 65 162
+Circle -1 true true 150 105 120
+Polygon -7500403 true false 218 120 240 165 255 165 278 120
+Circle -7500403 true false 214 72 67
+Rectangle -1 true true 164 223 179 298
+Polygon -1 true true 45 285 30 285 30 240 15 195 45 210
+Circle -1 true true 3 83 150
+Rectangle -1 true true 65 221 80 296
+Polygon -1 true true 195 285 210 285 210 240 240 210 195 210
+Polygon -7500403 true false 276 85 285 105 302 99 294 83
+Polygon -7500403 true false 219 85 210 105 193 99 201 83
+
@#$#@#$#@
NetLogo 5.2.0""")
} else {
(defvar *dynamic-prims* nil)
(defun global->prim (global)
- (list :name global :type :reporter :macro `(lambda () ',(intern (symbol-name global) clnl:*model-package*))))
+ (list
+ :name global
+ :type :reporter
+ :precedence 10
+ :macro `(lambda () ',(intern (symbol-name global) clnl:*model-package*))))
(defun own->prim (symb)
- (list :name symb :type :reporter :macro `(lambda () '(clnl-nvm:agent-value ,symb))))
+ (list :name symb :type :reporter :precedence 10 :macro `(lambda () '(clnl-nvm:agent-value ,symb))))
(defun breed->prims (breed-list)
- (let
- ((plural-name (symbol-name (car breed-list))))
+ (let*
+ ((plural (car breed-list))
+ (singular (cadr breed-list))
+ (plural-name (symbol-name plural)))
(list
- (list :name (car breed-list))
- (list :name (intern (format nil "~A-HERE" plural-name) :keyword))
- (list :name (intern (format nil "CREATE-~A" plural-name) :keyword) :args '(:number :command-block)))))
+ (list :name plural :type :reporter :precedence 10 :macro `(lambda () ,plural))
+ (list
+ :name (intern (format nil "~A-HERE" plural-name) :keyword)
+ :type :reporter
+ :precedence 10
+ :macro `(lambda () '(clnl-nvm:turtles-here ,plural)))
+ (list
+ :name (intern (format nil "CREATE-~A" plural-name) :keyword)
+ :type :command
+ :args '(:number (:command-block :optional))
+ :precedence 0
+ :macro `(lambda (num &optional command-block)
+ `(clnl-nvm:create-turtles ,num ,,plural ,command-block))))))
(defun parse (lexed-ast &optional external-globals)
"PARSE LEXED-AST &optional EXTERNAL-GLOBALS => AST, PRIMS
(list
:name (cadr lexed-ast)
:type :command
+ :precedence 0
:func `(function ,(intern (symbol-name (cadr lexed-ast)) clnl:*model-package*)))
(procedures->prims (cddr lexed-ast))))
(t (procedures->prims (cdr lexed-ast)))))
DESCRIPTION:
Returns the turtles own variables that get declared in the code."
- (mapcar
- (lambda (turtles-own-var) (intern (symbol-name turtles-own-var) :keyword))
- (cdr (second (find :turtles-own code-parsed-ast :key #'car)))))
+ (cdr (second (find :turtles-own code-parsed-ast :key #'car))))
(defun patches-own-vars (code-parsed-ast)
"PATCHES-OWN-VARS CODE-PARSED-AST => PATCHES-OWN-VARS
DESCRIPTION:
Returns the turtles own variables that get declared in the code."
- (mapcar
- (lambda (patches-own-var) (intern (symbol-name patches-own-var) :keyword))
- (cdr (second (find :patches-own code-parsed-ast :key #'car)))))
+ (cdr (second (find :patches-own code-parsed-ast :key #'car))))
+
+(defun breeds (code-parsed-ast)
+ "BREEDS CODE-PARSED-AST => BREEDS
+
+ BREEDS: BREED*
+
+ARGUMENTS AND VALUES:
+
+ CODE-PARSED-AST: An ast as created by clnl-code-parse:parse
+ BREED: A symbol interned in :keyword
+
+DESCRIPTION:
+
+ Returns the breeds that get declared in the code."
+ (mapcar #'cadadr (remove :breed code-parsed-ast :test-not #'equal :key #'car)))
(defun procedures (code-parsed-ast)
"PROCEDURES CODE-PARSED-AST => PROCEDURES
stages need to turn them into Common Lisp code, run it, and return the RESULT."
(eval (clnl-transpiler:transpile (clnl-parser:parse (clnl-lexer:lex reporter)))))
+; Because prims are used both at generation time and later at runtime, certain things in
+; them must be escaped a little bit more, such as wrapping the whole thing in a list
+; primitive. This way, the output of these things looks like halfway decent lisp,
+; and everything works nicely. We don't want any <FUNC #> showing up or anything
+(defun munge-prim (prim)
+ (let
+ ((copied (copy-list prim)))
+ (when (getf copied :args) (setf (getf copied :args) `(quote ,(getf copied :args))))
+ `(list ,@copied)))
+
+(defun netlogo-callback-body (prims)
+ `(eval
+ (clnl-transpiler:transpile
+ (clnl-parser:parse
+ (clnl-lexer:lex ,(intern "NETLOGO-CODE" *model-package*))
+ (list ,@(mapcar #'munge-prim prims)))
+ (list ,@(mapcar #'munge-prim prims)))))
+
+(defun create-world-call (model globals code-ast)
+ `(clnl-nvm:create-world
+ :dims ',(clnl-model:world-dimensions model)
+ :globals (list
+ ,@(mapcar
+ (lambda (pair)
+ `(list ,(car pair) (lambda () ,(intern (string-upcase (car pair)) *model-package*))))
+ globals))
+ :turtles-own-vars ',(clnl-code-parser:turtles-own-vars code-ast)
+ :patches-own-vars ',(clnl-code-parser:patches-own-vars code-ast)
+ :breeds ',(clnl-code-parser:breeds code-ast)))
+
+(defun create-proc-body (proc prims)
+ `(,(intern (string-upcase (car proc)) *model-package*) ()
+ ,@(cdr ; remove the progn, cuz it looks nicer
+ (clnl-transpiler:transpile (cadr proc)
+ (mapcar
+ (lambda (prim)
+ (if (getf prim :macro) ; The reason we do this is because with macros, we want to evaluate them in
+ ; this scope while preserving them for the generational purposes below
+ (append (list :macro (eval (getf prim :macro))) prim)
+ prim)) prims)))))
+
(defun model->single-form-lisp (model &key (seed 15) initialize-interface netlogo-callback)
(multiple-value-bind
(code-ast prims)
(clnl-code-parser:globals code-ast))))
`(prog ()
; First declare is in case we don't use it, it shows up in export correctly
- (declare (special ,@(mapcar (lambda (pair) (intern (string-upcase (car pair)) *model-package*)) globals)))
+ ,@(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
- (declare (special ,@(mapcar (lambda (pair) (intern (string-upcase (car pair)) *model-package*)) globals)))
+ ,@(when (and (> (length globals) 0) netlogo-callback)
+ `((declare (special ,@(mapcar (lambda (pair) (intern (string-upcase (car pair)) *model-package*)) globals)))))
(labels
,(mapcar
- (lambda (proc)
- `(,(intern (string-upcase (car proc)) *model-package*) ()
- ,@(cdr ; remove the progn, cuz it looks nicer
- (clnl-transpiler:transpile (cadr proc)
- (mapcar
- (lambda (prim)
- (if (getf prim :macro) ; The reason we do this is because with macros, we want to evaluate them in
- ; this scope while preserving them for the generational purposes below
- (append (list :macro (eval (getf prim :macro))) prim)
- prim)) prims)))))
+ (lambda (proc) (create-proc-body proc prims))
(clnl-code-parser:procedures code-ast))
(clnl-random:set-seed ,seed)
- (clnl-nvm:create-world
- :dims ',(clnl-model:world-dimensions model)
- :globals (list
- ,@(mapcar
- (lambda (pair)
- `(list ,(car pair) (lambda () ,(intern (string-upcase (car pair)) *model-package*))))
- globals))
- :turtles-own-vars ',(clnl-code-parser:turtles-own-vars code-ast)
- :patches-own-vars ',(clnl-code-parser:patches-own-vars code-ast))
+ ,(create-world-call model globals code-ast)
,@(when netlogo-callback
`((funcall ,netlogo-callback
- (lambda (netlogo-code)
- (eval
- (clnl-transpiler:transpile
- (clnl-parser:parse
- (clnl-lexer:lex netlogo-code)
- (list ,@(mapcar (lambda (prim) `(list ,@prim)) prims)))
- (list ,@(mapcar (lambda (prim) `(list ,@prim)) prims))))))))
+ (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)
`(defvar ,(intern (string-upcase (car pair)) *model-package*) ,(cadr pair)))
globals)
,@(mapcar
- (lambda (proc)
- `(defun ,(intern (string-upcase (car proc)) *model-package*) ()
- ,@(cdr ; remove the progn, cuz it looks nicer
- (clnl-transpiler:transpile (cadr proc)
- (mapcar
- (lambda (prim)
- (if (getf prim :macro) ; The reason we do this is because with macros, we want to evaluate them in
- ; this scope while preserving them for the generational purposes below
- (append (list :macro (eval (getf prim :macro))) prim)
- prim)) prims)))))
+ (lambda (proc) `(defun ,@(create-proc-body proc prims)))
(clnl-code-parser:procedures code-ast))
(defun ,boot-fn ()
(clnl-random:set-seed ,seed)
- (clnl-nvm:create-world
- :dims ',(clnl-model:world-dimensions model)
- :globals (list
- ,@(mapcar
- (lambda (pair) `(list ,(car pair) (lambda () ,(intern (string-upcase (car pair)) *model-package*))))
- globals))
- :turtles-own-vars ',(clnl-code-parser:turtles-own-vars code-ast)
- :patches-own-vars ',(clnl-code-parser:patches-own-vars code-ast))
+ ,(create-world-call model globals code-ast)
,@(when initialize-interface `((clnl-interface:initialize :dims ',(clnl-model:world-dimensions model)))))
,@(when netlogo-callback-fn
`((defun ,netlogo-callback-fn (,(intern "NETLOGO-CODE" *model-package*))
- (eval
- (clnl-transpiler:transpile
- (clnl-parser:parse
- (clnl-lexer:lex ,(intern "NETLOGO-CODE" *model-package*))
- (list ,@(mapcar (lambda (prim) `(list ,@prim)) prims)))
- (list ,@(mapcar (lambda (prim) `(list ,@prim)) prims)))))))))))
+ ,(netlogo-callback-body prims))))))))
(setf (documentation 'model->multi-form-lisp 'function)
"MODEL->MULTI-FORM-LISP MODEL BOOT-FN &key SEED INITIALIZE-INTERFACE NETLOGO-CALLBACK-FN => FORMS
:stop is returned."
`(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 turtle who breed color heading xcor ycor (label "") (label-color 9.9d0) (size 1d0) shape own-vars)
(defstruct patch color xcor ycor own-vars turtles)
(defun agentset-list (agentset)
((eql agentset :turtles) *turtles*)
((eql agentset :patches) *patches*)
((and (listp agentset) (eql :agentset (car agentset))) (cddr agentset))
+ ((find agentset *breeds* :key #'car)
+ (remove agentset *turtles* :key #'turtle-breed :test-not #'eql))
(t (error "Doesn't seem to be an agentset: ~A" agentset))))
(defun agentset-breed (agentset)
(cond
((eql agentset :turtles) :turtles)
((eql agentset :patches) :patches)
+ ((find agentset *breeds* :key #'car) agentset)
((and (listp agentset) (eql :agentset (car agentset))) (second agentset))
(t (error "Doesn't seem to be an agentset: ~A" agentset))))
(or
(eql o :turtles)
(eql o :patches)
+ (find o *breeds* :key #'car)
(and (listp o) (eql :agentset (car o)))))
(defun agent-p (o)
(:magenta 125d0)
(:pink 135d0)))
-(defun create-turtle (&optional base-turtle)
- (let
- ((new-turtle (make-turtle
+(defun create-turtle (breed &optional base-turtle)
+ (let*
+ ((breed (or breed (and base-turtle (turtle-breed base-turtle)) :turtles))
+ (new-turtle (make-turtle
:who (coerce *current-id* 'double-float)
:color (if base-turtle
(turtle-color base-turtle)
:heading (if base-turtle
(turtle-heading base-turtle)
(coerce (clnl-random:next-int 360) 'double-float))
- :shape (breed-default-shape :turtles)
+ :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))))
(let
See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#turtles"
:turtles)
-(defun turtles-here ()
+(defun turtles-here (&optional breed)
"TURTLES-HERE => TURTLES
ARGUMENTS AND VALUES:
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))
+ (let
+ ((patch-turtles (patch-turtles (patch-at (turtle-xcor *self*) (turtle-ycor *self*)))))
+ (list->agentset
+ (if breed (remove breed patch-turtles :key #'turtle-breed :test-not #'eql) patch-turtles)
+ (or breed :turtles))))
(defun ask (agent-or-agentset fn)
"ASK AGENT-OR-AGENTSET FN => RESULT
See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#right"
(turn-right (- n)))
-(defun create-turtles (n &optional fn)
- "CREATE-TURTLES N &optional FN => RESULT
+(defun create-turtles (n &optional breed fn)
+ "CREATE-TURTLES N &optional BREED FN => RESULT
ARGUMENTS AND VALUES:
N: an integer, the numbers of turtles to create
+ BREED: a breed
FN: A function, applied to each turtle after creation
RESULT: undefined
DESCRIPTION:
- Creates number new turtles at the origin.
+ Creates N new turtles at the origin.
New turtles have random integer headings and the color is randomly selected
- from the 14 primary colors. If a function is supplied, the new turtles
- immediately run it.
+ from the 14 primary colors. If FN is supplied, the new turtles immediately
+ run it. If a BREED is supplied, that is the breed the new turtles are set
+ to.
See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#create-turtles"
(let
- ((new-turtles (loop :repeat n :collect (create-turtle))))
+ ((new-turtles (loop :repeat n :collect (create-turtle breed))))
(when fn (ask (list->agentset new-turtles :turtles) fn))))
(defun hatch (n &optional fn)
See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#hatch"
(when (not (turtle-p *self*)) (error "Can only hatch from turtle scope"))
(let
- ((new-turtles (loop :repeat n :collect (create-turtle *self*))))
+ ((new-turtles (loop :repeat n :collect (create-turtle nil *self*))))
(when fn (ask (list->agentset new-turtles :turtles) fn))))
(defun reset-ticks ()
(defun clear-ticks ()
(setf *ticks* nil))
-(defun create-world (&key dims globals turtles-own-vars patches-own-vars)
- "CREATE-WORLD &key DIMS GLOBALS TURTLES-OWN-VARS PATCHES-OWN-VARS => RESULT
+(defun create-world (&key dims globals turtles-own-vars patches-own-vars breeds)
+ "CREATE-WORLD &key DIMS GLOBALS TURTLES-OWN-VARS PATCHES-OWN-VARS BREEDS => RESULT
DIMS: (:xmin XMIN :xmax XMAX :ymin YMIN :ymax YMAX)
GLOBALS: GLOBAL*
TURTLES-OWN-VARS: TURTLES-OWN-VAR*
PATCHES-OWN-VARS: PATCHES-OWN-VAR*
+ BREEDS: BREED*
GLOBAL: (GLOBAL-NAME GLOBAL-ACCESS-FUNC)
ARGUMENTS AND VALUES:
YMAX: An integer representing the maximum patch coord in Y
TURTLES-OWN-VAR: Symbol for the turtles own variable in the keyword package
PATCHES-OWN-VAR: Symbol for the patches own variable in the keyword package
+ BREED: A list of symbols representing the possible preeds
GLOBAL-NAME: Symbol for the global in the keyword package
GLOBAL-ACCESS-FUNC: Function to get the value of the global
(setf *patches-own-vars* patches-own-vars)
(setf *dimensions* dims)
(setf *globals* globals)
- (setf *breeds* (list (list :turtles "default")))
+ (setf *breeds*
+ (append
+ (list (list :turtles "default"))
+ (mapcar (lambda (breed) (list breed "default")) breeds)))
(clear-ticks)
(clear-patches)
(clear-turtles))
(defmethod dump-object ((o turtle)) (format nil "(turtle ~A)" (dump-object (turtle-who o))))
(defmethod dump-object ((o (eql :nobody))) (format nil "nobody"))
+(defmethod dump-object ((o (eql :turtles))) (format nil "{all-turtles}"))
+(defmethod dump-object ((o symbol))
+ (cond
+ ((find o *breeds* :key #'car) (format nil "{breed ~(~A~)}" o))
+ (t (error "Keyword unrecognized by dump object: ~A" o))))
(defun current-state ()
"CURRENT-STATE => WORLD-STATE
(mapcar
(lambda (turtle)
(format nil
- "\"~A\",\"~A\",\"~A\",\"~A\",\"~A\",\"~A\",\"~A\",\"~A\",\"{all-turtles}\",\"false\",\"~A\",~A~{,\"~A\"~}"
+ "\"~A\",\"~A\",\"~A\",\"~A\",\"~A\",\"~A\",\"~A\",\"~A\",\"~A\",\"false\",\"~A\",~A~{,\"~A\"~}"
(dump-object (turtle-who turtle))
(dump-object (turtle-color turtle))
(dump-object (turtle-heading turtle))
(dump-object (turtle-shape turtle))
(dump-object (turtle-label turtle))
(dump-object (turtle-label-color turtle))
+ (dump-object (turtle-breed turtle))
(dump-object (turtle-size turtle))
"\"1\",\"\"\"up\"\"\""
(mapcar #'dump-object (mapcar (lambda (var) (agent-value-inner turtle var)) *turtles-own-vars*))))
(defpackage #:clnl-code-parser
(:use :common-lisp)
- (:export #:parse #:globals #:procedures #:turtles-own-vars #:patches-own-vars)
+ (:export #:parse #:globals #:procedures #:turtles-own-vars #:patches-own-vars #:breeds)
(:documentation
"CLNL Code Parser
(defparameter *dynamic-prims* nil)
(defun prim-name (prim) (getf prim :name))
+(defun prim-precedence (prim) (getf prim :precedence))
(defun prim-args (prim) (getf prim :args))
(defun prim-structure-prim (prim) (getf prim :structure-prim))
(defun prim-is-infix (prim) (getf prim :infix))
"PARSE LEXED-AST &optional DYNAMIC-PRIMS => AST
DYNAMIC-PRIMS: DYNAMIC-PRIM*
- DYNAMIC-PRIM: (:name NAME :args ARGS :infix INFIX)
+ DYNAMIC-PRIM: (:name NAME :args ARGS :infix INFIX :precedence PRECEDENCE)
ARGS: ARG*
ARGUMENTS AND VALUES:
LEXED-AST: An ambigious ast
AST: An unambigious ast that can be transpiled
NAME: A symbol in the keyword package
- INFIX: Boolean denoting whether the prim is infix
+ INFIX: Boolean denoting whether the prim is infix, defaulting to NIL
+ PRECEDENCE: A number, usually 10 for reporters, and 0 for commands
ARG: A list of symbols denoting the type of argument
DESCRIPTION:
DYNAMIC-PRIMS that are passed in are used to avoid compilation errors on
things not statically defined by the NetLogo language, be they user defined
- procedures or generated primitives from breed declarations.
+ procedures or generated primitives from breed declarations. NAME and PRECEDENCE
+ are required for all dynamic prims.
+
+ PRECEDENCE is a number used to calculate the order of operations. Higher numbers
+ have more precedence than lower ones. Generally all commands should have the
+ lowest precedence, and all reporters should have 10 as the precedence.
The possible values for ARG are :agentset, :boolean, :number, :command-block,
or t for wildcard.
Examples are too numerous and varied, but by inserting an output between
the lexer and this code, a good idea of what goes on can be gotten."
+ (when (find nil dynamic-prims :key #'prim-name)
+ (error "All passed in prims must have a name: ~S" (find nil dynamic-prims :key #'prim-name)))
+ (when (find nil dynamic-prims :key #'prim-precedence)
+ (error "All passed in prims must have a precedence: ~S" (find nil dynamic-prims :key #'prim-precedence)))
(let
; could have defined this using the special variable, but didn't to make the
; function definition simpler, as well as the documentation.
(< 1 (length prev-item))
(keywordp (car x))
(find-prim (car x))
- (getf (find-prim (car x)) :precedence))
+ (prim-precedence (find-prim (car x))))
20)))
(cond
- ((<= (getf prim :precedence) (calculate-precedence prev-item))
+ ((<= (prim-precedence prim) (calculate-precedence prev-item))
(cons
(prim-name prim)
(cons
(defprim :ca () 0)
(defprim :clear-all () 0)
(defprim :crt (:number (:command-block :optional)) 0)
+(defprim :create-turtles (:number (:command-block :optional)) 0)
(defprim :color () 10)
(defprim :count (:agentset) 10)
(defprim :die () 0)
(defagentvalueprim :color)
(defsimpleprim '(:clear-all :ca) :command clnl-nvm:clear-all)
(defsimpleprim :count :reporter clnl-nvm:count)
-(defsimpleprim :crt :command clnl-nvm:create-turtles)
+(defprim '(:crt :create-turtles) :command (lambda (num &optional fn) `(clnl-nvm:create-turtles ,num nil ,fn)))
(defsimpleprim :die :command clnl-nvm:die)
(defsimpleprim :display :command clnl-nvm:display)
(defsimpleprim :fd :command clnl-nvm:forward)
end"
"setup go"
"2972B3EC1285BDA17656401001E1AE667FA7F5AF")
+
+(defmodelcommandtest "breeds 1"
+ "breed [wolves wolf]
+
+to setup
+ create-turtles 50
+ create-turtles 50 [ fd 1 ]
+ create-wolves 50
+ set-default-shape wolves \"sheep\"
+ create-wolves 50 [ fd 1 ]
+end
+
+to go
+ ask turtles [ fd 1 ]
+ ask wolves [ fd 1 ]
+ ask turtles [ if 1 < count turtles-here [ fd 1 ] ]
+ ask wolves [ if 1 < count turtles-here [ fd 1 ] ]
+ ask turtles [ if 1 < count wolves-here [ fd 1 ] ]
+ ask wolves [ if 1 < count wolves-here [ fd 1 ] ]
+end"
+ "setup go"
+ "2614B99F64ACFA2BD64D66B129C0A17F2150FADD")
projects / clnl / commitdiff