import collection.JavaConversions._
+val input = io.Source.stdin.getLines.mkString("\n").split("\\@\\#\\$\\#\\@\\#\\$\\#\\@")
+
System.out.println("----")
val workspace = HeadlessWorkspace.newInstance
workspace.silent = true
-workspace.openFromSource(url2String("file:resources/empty.nlogo"))
-val input = io.Source.stdin.getLines.mkString("\n").split("\\@\\#\\$\\#\\@\\#\\$\\#\\@")
-val commands = input(0)
+if (input.length > 2 && input(2).length > 0) {
+ val modelSetup = input(2)
+ workspace.openFromSource(modelSetup +
+"""
+@#$#@#$#@
+GRAPHICS-WINDOW
+210
+10
+649
+470
+-1
+-1
+13.0
+1
+10
+1
+1
+1
+0
+1
+1
+1
+-1
+1
+-1
+1
+0
+0
+1
+ticks
+30.0
+
+@#$#@#$#@
+@#$#@#$#@
+@#$#@#$#@
+NetLogo 5.2.0""")
+} else {
+ workspace.openFromSource(url2String("file:resources/empty.nlogo"))
+}
workspace.mainRNG.setSeed(15)
+
+val commands = input(0)
if(commands.length > 0) {
workspace.runCompiledCommands(new api.SimpleJobOwner("test", workspace.world.mainRNG, classOf[api.Observer]), workspace.compileCommands(commands))
}
if(input.length > 1) {
val reporter = input(1)
- System.out.println(org.nlogo.api.Dump.logoObject(workspace.runCompiledReporter(new api.SimpleJobOwner("test", workspace.world.mainRNG, classOf[api.Observer]), workspace.compileReporter(reporter))))
+ if(reporter.length > 0) {
+ System.out.println(org.nlogo.api.Dump.logoObject(workspace.runCompiledReporter(new api.SimpleJobOwner("test", workspace.world.mainRNG, classOf[api.Observer]), workspace.compileReporter(reporter))))
+ }
}
workspace.world.exportWorld(new java.io.PrintWriter(System.out, true), true)
; other things
(defvar *dynamic-prims* nil)
-(defun global->prim (global) (list :name global))
+
+(defun global->prim (global)
+ (list :name global :type :reporter :macro `(lambda () ',(intern (symbol-name global) clnl:*model-package*))))
+
(defun breed->prims (breed-list)
(let
((plural-name (symbol-name (car breed-list))))
(list :name (intern (format nil "CREATE-~A" plural-name) :keyword) :args '(:number :command-block)))))
(defun parse (lexed-ast &optional external-globals)
- "PARSE LEXED-AST &optional EXTERNAL-GLOBALS => AST
+ "PARSE LEXED-AST &optional EXTERNAL-GLOBALS => AST, PRIMS
ARGUMENTS AND VALUES:
LEXED-AST: An ambigious ast
EXTERNAL-GLOBALS: A list of symbols in keyword package
AST: An unambigious ast that represents the code block of a model
+ PRIMS: Primitives that can be sent to the parser and transpiler
DESCRIPTION:
PARSE takes a ambigious LEXED-AST and converts it to an unambigious one.
+ It also returns the primitives that are defined in the code file, including
+ ones generated from the EXTERNAL-GLOBALS, that can then be passed to both
+ the parser and the transpiler.
EXTERNAL-GLOBALS is a list of symbols representing global variables that
are not defined within the code. Normally these come from widgets defined
Rather, the ast that's returned can be queried with other functions included
in the CLNL-CODE-PARSER package to tease out necessary information. Some of
those things will involve code blocks that can then be transpiled."
- (let
+ (let*
((*dynamic-prims*
(append
(mapcar #'global->prim external-globals)
- (procedures->prims lexed-ast))))
- (parse-internal lexed-ast)))
+ (procedures->prims lexed-ast)))
+ (parsed (parse-internal lexed-ast)))
+ (values
+ (butlast parsed)
+ (last parsed))))
(defun procedures->prims (lexed-ast)
(cond
((not lexed-ast) nil)
; We'll need argument handling here sometime :)
- ((eql :to (car lexed-ast)) (cons (list :name (cadr lexed-ast)) (procedures-to-prims (cdr lexed-ast))))
- (t (procedures-to-prims (cdr lexed-ast)))))
+ ((eql :to (car lexed-ast)) (cons (list :name (cadr lexed-ast)) (procedures->prims (cdr lexed-ast))))
+ (t (procedures->prims (cdr lexed-ast)))))
(defun parse-internal (lexed-ast)
(cond
- ((not lexed-ast) nil)
+ ((not lexed-ast) *dynamic-prims*)
((eql :to (car lexed-ast)) (parse-procedure lexed-ast))
((find (car lexed-ast) '(:globals :turtles-own :patches-own))
(parse-with-unevaluated-list lexed-ast))
ARGUMENTS AND VALUES:
MODEL: An ast as created by clnl-code-parse:parse
- GLOBAL: A symbol interned in clnl:*model-package*
+ GLOBAL: A symbol interned in :keyword
DESCRIPTION:
Returns the globals that get declared in the code."
(mapcar
- (lambda (global) (list (intern (symbol-name global) clnl:*model-package*) 0d0))
+ (lambda (global) (list (intern (symbol-name global) :keyword) 0d0))
(cdr (second (find :globals code-parsed-ast :key #'car)))))
(format t "Via lexing, AST for~%~S~% became~%~S~%~%" str ast) ast))
(parsed-ast (let ((ast (clnl-parser:parse lexed-ast)))
(format t "Via parsing, AST for~%~S~% became~%~S~%~%" lexed-ast ast) ast))
- (transpiled-ast (let ((ast (clnl-transpiler:transpile-commands parsed-ast)))
+ (transpiled-ast (let ((ast (clnl-transpiler:transpile parsed-ast)))
(format t "Via transpiling, AST for~%~S~% became~%~S~%" parsed-ast ast) ast)))
(eval transpiled-ast)))
(sb-thread:make-thread #'clnl-cli:run)
(clnl-interface:run))
-(defun boot (&optional file)
- "BOOT &optional FILE => RESULT
+(defun boot (&optional file headless-mode)
+ "BOOT &optional FILE HEADLESS-MODE => RESULT
ARGUMENTS AND VALUES:
FILE: nlogo file with which to initialize state
+ HEADLESS-MODE: a boolean, defaults to nil
RESULT: undefined
DESCRIPTION:
BOOT does exactly that, boots the clnl system in a clean state. The seed
is set so that multiple runs will evaluate to the same.
- When FILE is not provided, a default model is used."
+ When FILE is not provided, a default model is used.
+
+ When HEADLESS-MODE is set to nil, the opengl interface is initialized.
+ Otherwise, the model will run headlessly, with no view."
(let
((netlogoed-lisp
- (model->lisp
- (if file (with-open-file (str file) (clnl-model:read-from-nlogo str)) (clnl-model:default-model))))
+ (model->single-form-lisp
+ (if file (with-open-file (str file) (clnl-model:read-from-nlogo str)) (clnl-model:default-model))
+ :initialize-interface (not headless-mode)))
(*package* *model-package*))
(eval netlogoed-lisp)))
RUN-COMMANDS will take NetLogo commands, put them through the various
stages need to turn them into Common Lisp code, and run it."
- (clnl-nvm:with-stop-handler (eval (clnl-transpiler:transpile-commands (clnl-parser:parse (clnl-lexer:lex cmds))))))
+ (clnl-nvm:with-stop-handler (eval (clnl-transpiler:transpile (clnl-parser:parse (clnl-lexer:lex cmds))))))
(defun run-reporter (reporter)
"RUN-REPORTER REPORTER => RESULT
RUN-REPORTER will take a NetLogo REPORTER, put it through the various
stages need to turn them into Common Lisp code, run it, and return the RESULT."
- (eval (clnl-transpiler:transpile-reporter (car (clnl-parser:parse (clnl-lexer:lex reporter))))))
-
-; Everything gets tied together here
-; The intention of this method is to generate the common lisp equivalent of a model file,
-; such that if you decided to no longer use nlogo, you could use the engine without it.
-(defun model->lisp (model)
- `(let
- ,(clnl-model:globals model)
- (clnl-random:set-seed 15) ; should the seed always be 15?
- (clnl-nvm:create-world :dims ',(clnl-model:world-dimensions model))
- (clnl-interface:initialize :dims ',(clnl-model:world-dimensions model))))
+ (eval (clnl-transpiler:transpile (clnl-parser:parse (clnl-lexer:lex reporter)))))
+
+(defun model->single-form-lisp (model &key (seed 15) initialize-interface netlogo-callback)
+ (multiple-value-bind
+ (code-ast prims)
+ (clnl-code-parser:parse (clnl-lexer:lex (clnl-model:code model)) (clnl-model:widget-globals model))
+ (let
+ ((globals
+ (append
+ (clnl-model:widget-globals model)
+ (clnl-code-parser:globals code-ast))))
+ `(let
+ ,(mapcar (lambda (pair) (list (intern (string-upcase (car pair)) *model-package*) (cadr pair))) globals)
+ (declare (special ,@(mapcar (lambda (pair) (intern (string-upcase (car pair)) *model-package*)) globals)))
+ (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)))
+ ,@(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))))))))
+ ,@(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
+
+ARGUMENTS AND VALUES:
+
+ MODEL: A valid model
+ SEED: An integer, defaults to 15
+ INITIALIZE-INTERFACE: A boolean
+ NETLOGO-CALLBACK: A function of one argument, or a symbol
+ FORM: A common lisp form
+
+DESCRIPTION:
+
+ MODEL->SINGLE-FORM-LISP takes a model and returns a lisp program as a single form,
+ that when executed runs the model. The SEED passed in is used to start the
+ clnl-random RNG.
+
+ INITIALIZE-INTERFACE, when non nil, leads to initialization code for the
+ opengl interface being included.
+
+ NETLOGO-CALLBACK is a function that when called with a single argument,
+ a function that when called with netlogo code, will compile and run that
+ code in the environment of the model.
+
+ Of note, all globals defined either in the model code or via the widgets
+ are declared special in order to remain in the lexical environment for EVAL.")
+
+(defun model->multi-form-lisp (model boot-fn &key (seed 15) initialize-interface netlogo-callback-fn)
+ (multiple-value-bind
+ (code-ast prims)
+ (clnl-code-parser:parse (clnl-lexer:lex (clnl-model:code model)) (clnl-model:widget-globals model))
+ (let
+ ((globals
+ (append
+ (clnl-model:widget-globals model)
+ (clnl-code-parser:globals code-ast))))
+ `((in-package ,(intern (package-name *model-package*) :keyword))
+ ,@(mapcar
+ (lambda (pair)
+ `(defvar ,(intern (string-upcase (car pair)) *model-package*) ,(cadr pair)))
+ globals)
+ (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)))
+ ,@(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)))))))))))
+
+(setf (documentation 'model->multi-form-lisp 'function)
+ "MODEL->MULTI-FORM-LISP MODEL BOOT-FN &key SEED INITIALIZE-INTERFACE NETLOGO-CALLBACK-FN => FORMS
+
+ARGUMENTS AND VALUES:
+
+ MODEL: A valid model
+ BOOT-FN: A function name
+ SEED: An integer, defaults to 15
+ INITIALIZE-INTERFACE: A boolean
+ NETLOGO-CALLBACK-FN: a symbol
+ FORMS: A list of common lisp form
+
+DESCRIPTION:
+
+ MODEL->MULTI-FORM-LISP takes a model and returns a multi form lisp program,
+ that when executed, sets up the model. Procedures map to defuns, globals
+ to defvars, etc. This can be output to load up quickly later. A function
+ named by BOOT-FN will be set for booting the program.
+
+ The SEED passed in is used to start the clnl-random RNG.
+
+ INITIALIZE-INTERFACE, when non nil, leads to initialization code for the
+ opengl interface being included.
+
+ NETLOGO-CALLBACK-FN is a symbol that will be defined as a function
+ to be called to execute code in the running netlogo instance.")
Returns the default startup model."
(make-model
+ :code ""
:interface (list
(make-view :min-pxcor -5 :max-pxcor 5 :min-pycor -5 :max-pycor 5))))
(read-sections (append section (list line))))))))
(read-sections))))
(make-model
- :code (clnl-code-parser:parse
- (clnl-lexer:lex (format nil "~{~A~^~%~}" (nth 0 sections)))
- (remove nil
- (mapcar
- (lambda (widget)
- (typecase widget
- (slider (intern (string-upcase (slider-varname widget)) :keyword))
- (switch (intern (string-upcase (switch-varname widget)) :keyword))))
- (parse-interface (nth 1 sections)))))
+ :code (format nil "~{~A~^~%~}" (nth 0 sections))
:interface (parse-interface (nth 1 sections))
:info (nth 2 sections)
:turtle-shapes (nth 3 sections)
:ymin (view-min-pycor view)
:ymax (view-max-pycor view))))
-; For now, we keep the code hidden in this package
-(defun globals (model)
- "GLOBALS MODEL => GLOBALS
+(defun widget-globals (model)
+ "WIDGET-GLOBALS MODEL => GLOBALS
GLOBALS: GLOBAL*
+ GLOBAL: (NAME DEFAULT)
+
+ARGUMENTS AND VALUES:
+
+ MODEL: A valid model
+ NAME: A symbol interned in the keyworkd package
+ DEFAULT: The widget default value
+
+DESCRIPTION:
+
+ Returns the globals that get declared in the model from widgets.
+ They are interned in the keyword package package set for clnl, so
+ that they can later be used for multiple purposes."
+ (remove nil
+ (mapcar
+ (lambda (widget)
+ (typecase widget
+ (slider (list (intern (string-upcase (slider-varname widget)) :keyword) (slider-default widget)))
+ (switch (list (intern (string-upcase (switch-varname widget)) :keyword) (switch-on widget)))))
+ (model-interface model))))
+
+(defun code (model)
+ "CODE MODEL => CODE
ARGUMENTS AND VALUES:
MODEL: A valid model
- GLOBAL: A symbol interned in clnl:*model-package*
+ CODE: The string representing the netlogo code in this model
DESCRIPTION:
- Returns the globals that get declared in the model, from widgets or
- from code. They are interned in the package set for clnl, so
- that they can later be used by functions in that package."
- (mapcar
- (lambda (pair)
- (list
- (intern (string-upcase (car pair)) clnl:*model-package*)
- (cadr pair)))
- (append
- (clnl-code-parser:globals (model-code model))
- (remove nil
- (mapcar
- (lambda (widget)
- (typecase widget
- (slider (list (slider-varname widget) (slider-default widget)))
- (switch (list (switch-varname widget) (switch-on widget)))))
- (model-interface model))))))
+ Returns the code from the model."
+ (model-code model))
(defvar *myself* nil)
(defvar *self* nil)
(defvar *dimensions* nil)
+(defvar *globals* nil)
(defvar *topology* :torus)
(defvar *ticks* nil)
(defvar *breeds* nil)
WITH-STOP-HANDLER is a convenience macro to handle when
programs issue a stop condition. When one does, a simple
:stop is returned."
- `(handler-case (progn ,@forms) (stop (s) :stop)))
+ `(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)
(defstruct patch color xcor ycor)
(defun clear-ticks ()
(setf *ticks* nil))
-(defun create-world (&key dims)
- "CREATE-WORLD &key DIMS => RESULT
+(defun create-world (&key dims globals)
+ "CREATE-WORLD &key DIMS GLOBALS => RESULT
DIMS: (:xmin XMIN :xmax XMAX :ymin YMIN :ymax YMAX)
+ GLOBALS: GLOBAL*
+ GLOBAL: (NAME ACCESS-FUNC)
ARGUMENTS AND VALUES:
XMAX: An integer representing the maximum patch coord in X
YMIN: An integer representing the minimum patch coord in Y
YMAX: An integer representing the maximum patch coord in Y
+ NAME: Symbol for the global in the keyword package
+ ACCESS-FUNC: Function to get the value of the global
DESCRIPTION:
This should be called before using the engine in any real capacity. If
called when an engine is already running, it may do somethign weird."
(setf *dimensions* dims)
+ (setf *globals* globals)
(setf *breeds* (list (list :turtles "default")))
(clear-ticks)
(clear-patches)
(format nil "~S" (clnl-random:export))
""
(format nil "~S" "GLOBALS")
- (format nil "~A~A"
+ (format nil "~A~A~{\"~A\"~^,~}"
"\"min-pxcor\",\"max-pxcor\",\"min-pycor\",\"max-pycor\",\"perspective\",\"subject\","
- "\"nextIndex\",\"directed-links\",\"ticks\",")
- (format nil "\"~A\",\"~A\",\"~A\",\"~A\",\"0\",\"nobody\",\"~A\",\"\"\"NEITHER\"\"\",\"-1\""
- (min-pxcor) (max-pxcor) (min-pycor) (max-pycor) *current-id*)
+ "\"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))
""
(defpackage #:clnl (:use :common-lisp)
- (:export #:run #:boot #:run-commands #:run-reporter #:*model-package*)
+ (:export
+ #:run #:boot #:run-commands #:run-reporter #:*model-package*
+ #:model->multi-form-lisp #:model->single-form-lisp)
(:documentation
"Main CLNL package
(defpackage #:clnl-transpiler
(:use :common-lisp)
- (:export #:transpile-commands #:transpile-reporter)
+ (:export #:transpile #:reporter-p #:command-list-p)
(:documentation
"CLNL Transpiler
(defpackage #:clnl-model
(:use :common-lisp)
- (:export #:default-model #:read-from-nlogo #:world-dimensions #:globals)
+ (:export #:default-model #:read-from-nlogo #:world-dimensions #:widget-globals #:code)
(:documentation
"CLNL Model
(in-package #:clnl-transpiler)
(defparameter *prims* nil)
-(defparameter *prim-aliases* nil)
(defvar *local-variables* nil)
+(defvar *dynamic-prims* nil)
(defun prim-name (prim) (getf prim :name))
(defun prim-type (prim) (getf prim :type))
(defun prim-func (prim) (getf prim :func))
-(defun is-reporter (prim) (eql :reporter (getf prim :type)))
-(defun is-command (prim) (eql :command (getf prim :type)))
+(defun prim-reporter-p (prim) (eql :reporter (getf prim :type)))
+(defun prim-command-p (prim) (eql :command (getf prim :type)))
(defun find-prim (symb)
(when symb
(find-if
(lambda (prim-name) (or (eql symb prim-name) (and (listp prim-name) (find symb prim-name))))
- *prims* :key #'prim-name)))
+ (append *prims* *dynamic-prims*)
+ :key #'prim-name)))
-; Let this grow, slowly but surely, eventually taking on calling context, etc.
-; For now, it's just a
-(defun transpile-commands (parsed-ast)
- "TRANSPILE-COMMANDS PARSED-AST => AST
+(defun transpile (parsed-ast &optional dynamic-prims)
+ "TRANSPILE PARSED-AST &optional DYNAMIC-PRIMS => AST
+
+ DYNAMIC-PRIMS: DYNAMIC-PRIM*
+ DYNAMIC-PRIM: (:name NAME :type TYPE :macro MACRO :func FUNC)
+ TYPE: :reporter | :command
ARGUMENTS AND VALUES:
PARSED-AST: An ast as returned by the parser
AST: An common lisp AST that can be actually run in a common lisp instance
+ NAME: A symbol in the keyword package
+ MACRO: A macro that will be called with the arguments ast
+ FUNC: A function that will be called with the transpiled arguments
DESCRIPTION:
- TRANSPILE-COMMANDS takes a unambigious PARSED-AST and converts it to
- Common Lisp code.
+ TRANSPILE takes a unambigious PARSED-AST and converts it to
+ Common Lisp code. The PARSED-AST must be either a list of commands,
+ or a single reporter.
+
+ When a set of DYNAMIC-PRIMS is included, external language constructs
+ can be also transpiled. The provided functions will be inserted into
+ the returned AST with a call to FUNCALL. If :macro is included, instead
+ of having a call to FUNCALL provided, the macro will be run at netlogo
+ transpile time, with the arguments it should have specified to the
+ parser. The result of that function call will then be dropped into
+ the ast.
Calling eval on that code should work correctly as long as you have a
- running engine. This is the entry point for commands, so it does
- extra checking to ensure that commands are actually in the PARSED-AST."
+ running engine."
+
+ (let
+ ((*dynamic-prims*
+ (mapcar
+ (lambda (prim)
+ (if (getf prim :macro)
+ (append (list :func (getf prim :macro)) prim)
+ (append (list :func (lambda (&rest args) `(funcall ,(getf prim :func) ,@args))) prim)))
+ dynamic-prims)))
+ (cond
+ ((command-list-p parsed-ast) (transpile-commands parsed-ast))
+ ((and (listp parsed-ast) (= 1 (length parsed-ast)) (reporter-p (car parsed-ast)))
+ (transpile-reporter (car parsed-ast)))
+ (t (error "Is neither a list of commands nor a reporter: ~S" parsed-ast)))))
+
+(defun command-list-p (parsed-ast)
+ "COMMAND-LIST-P PARSED-AST => RESULT
+
+ARGUMENTS AND VALUES:
+
+ PARSED-AST: An ast as returned by the parser
+ RESULT: A boolean
+
+DESCRIPTION:
+
+ COMMAND-LIST-P returns whether the parsed-ast is a valid list
+ of commands."
+ (and
+ (every #'listp parsed-ast)
+ (every #'prim-command-p (mapcar #'find-prim (mapcar #'car parsed-ast)))))
+
+(defun reporter-p (parsed-ast)
+ "REPORTER-P PARSED-AST => RESULT
+
+ARGUMENTS AND VALUES:
+
+ PARSED-AST: An ast as returned by the parser
+ RESULT: A boolean
+
+DESCRIPTION:
+
+ REPORTER-P returns whether the parsed-ast is a valid reporter."
+ (and
+ (symbolp (car parsed-ast))
+ (prim-reporter-p (find-prim (car parsed-ast)))))
+
+; Let this grow, slowly but surely, eventually taking on calling context, etc.
+; For now, it's just a
+(defun transpile-commands (parsed-ast)
`(progn
,@(transpile-commands-inner parsed-ast)))
(cond
((not (listp command)) (error "Expected a statement of some sort"))
((not (find-prim (car command))) (error "Couldn't find the command for ~S" (car command)))
- ((not (is-command (find-prim (car command)))) (error "Expected command, got ~S" (car command)))
+ ((not (prim-command-p (find-prim (car command)))) (error "Expected command, got ~S" (car command)))
(t (apply (prim-func (find-prim (car command))) (mapcar #'transpile-reporter (cdr command))))))
(defun transpile-reporter (reporter)
- "TRANSPILE-REPORTER REPORTER => AST
-
-ARGUMENTS AND VALUES:
-
- REPORTER: An ast returned from the parser.
- AST: An common lisp AST that can be actually run in a common lisp instance
-
-DESCRIPTION:
-
- TRANSPILE-REPORTER takes a unambigious PARSED-AST and converts it to
- Common Lisp code.
-
- Calling eval on that code should work correctly as long as you have a
- running engine. This is the entry point for reporters, so it does
- extra checking to ensure that the reporter is actually in the REPORTER.
-
- The Common lisp code that is returned, when run, will return some value."
(cond
((numberp reporter) reporter) ; The parser converts to double for us
((stringp reporter) reporter)
((and (symbolp (car reporter)) (find (car reporter) *local-variables*))
(intern (symbol-name (car reporter)) clnl:*model-package*))
((not (find-prim (car reporter))) (error "Couldn't find the reporter for ~S" (car reporter)))
- ((not (is-reporter (find-prim (car reporter)))) (error "Expected reporter, got ~S" (car reporter)))
+ ((not (prim-reporter-p (find-prim (car reporter)))) (error "Expected reporter, got ~S" (car reporter)))
(t (apply (prim-func (find-prim (car reporter))) (mapcar #'transpile-reporter (cdr reporter))))))
(defun transpile-command-block (block)
(defmacro defkeywordprim (name)
`(defprim ,name :reporter (lambda () ',name)))
-(defmacro defprim-alias (name real-symb)
- `(push (list :name ,name :real-symb ,real-symb) *prim-aliases*))
-
(defmacro defagentvalueprim (name)
`(defprim ,name :reporter (lambda () `(clnl-nvm:agent-value ,,name))))
(defagentvalueprim :label)
(defagentvalueprim :label-color)
+(defsimpleprim :let :command nil)
(defsimpleprim :lt :command clnl-nvm:turn-left)
(defsimpleprim :not :reporter cl:not)
(defkeywordprim :nobody)
:components ((:file "package")
(:file "main")
(:file "simpletests")
+ (:file "modeltests")
(:file "viewtests"))
:depends-on (#-travis :ironclad :clnl))
`(defsimpletest
(format nil "Simple Command - ~A" ,name)
(lambda ()
- (clnl:boot "resources/empty.nlogo")
+ (clnl:boot "resources/empty.nlogo" t)
(clnl:run-commands ,commands)
(checksum= ,checksum (checksum-world)))
(lambda ()
- (clnl:boot "resources/empty.nlogo")
+ (clnl:boot "resources/empty.nlogo" t)
(clnl:run-commands ,commands)
(format nil "~A~A"
(clnl-nvm:export-world)
`(defsimpletest
(format nil "Simple Reporter - ~A" ,name)
(lambda ()
- (clnl:boot "resources/empty.nlogo")
+ (clnl:boot "resources/empty.nlogo" t)
(and
(string= (funcall (intern "DUMP-OBJECT" :clnl-nvm) (clnl:run-reporter ,reporter)) ,value)
(checksum= ,checksum (checksum-world))))
(lambda ()
- (clnl:boot "resources/empty.nlogo")
+ (clnl:boot "resources/empty.nlogo" t)
(format nil "~A~%~A~A"
(funcall (intern "DUMP-OBJECT" :clnl-nvm) (clnl:run-reporter ,reporter))
(clnl-nvm:export-world)
(checksum-world)))
"bin/runcmd.scala"
- (format nil "~%@#$#@#$#@~A~%" ,reporter)))
+ (format nil "@#$#@#$#@~A" ,reporter)))
(defmacro defreportertestwithsetup (name setup reporter value checksum)
`(defsimpletest
(format nil "Reporter With Setup - ~A" ,name)
(lambda ()
- (clnl:boot "resources/empty.nlogo")
+ (clnl:boot "resources/empty.nlogo" t)
(clnl:run-commands ,setup)
(and
(string= (funcall (intern "DUMP-OBJECT" :clnl-nvm) (clnl:run-reporter ,reporter)) ,value)
(checksum= ,checksum (checksum-world))))
(lambda ()
- (clnl:boot "resources/empty.nlogo")
+ (clnl:boot "resources/empty.nlogo" t)
(clnl:run-commands ,setup)
(format nil "~A~%~A~A"
(funcall (intern "DUMP-OBJECT" :clnl-nvm) (clnl:run-reporter ,reporter))
(clnl-nvm:export-world)
(checksum-world)))
"bin/runcmd.scala"
- (format nil "~A~%@#$#@#$#@~A" ,setup ,reporter)))
+ (format nil "~A@#$#@#$#@~A" ,setup ,reporter)))
+
+(defun model-code->nlogo (code)
+ (format nil
+ "~A
+@#$#@#$#@
+GRAPHICS-WINDOW~%210~%10~%649~%470~%-1~%-1~%13.0~%1~%10~%1~%1~%1~%0~%1~%1~%1~%-1~%1~%-1~%1~%0~%0~%1~%ticks~%30.0~%
+@#$#@#$#@
+"
+ code))
+
+(defmacro defmodeltest (name model commands reporter value checksum)
+ `(defsimpletest
+ ,name
+ (lambda ()
+ (let
+ ((model (with-input-from-string (str ,(model-code->nlogo model)) (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))
+ (and
+ (or (not ,reporter) (string= (funcall (intern "DUMP-OBJECT" :clnl-nvm) (funcall callback ,reporter)) ,value))
+ (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))
+ (and
+ (or
+ (not ,reporter)
+ (string=
+ (funcall (intern "DUMP-OBJECT" :clnl-nvm) (funcall (intern "NETLOGO-CALLBACK" pkg) ,reporter))
+ ,value))
+ (checksum= ,checksum (checksum-world)))))))
+ (lambda ()
+ (let
+ ((callback nil))
+ (declaim (sb-ext:muffle-conditions cl:warning))
+ (eval
+ (clnl:model->single-form-lisp
+ (with-input-from-string (str ,(model-code->nlogo model)) (clnl-model:read-from-nlogo str))
+ :netlogo-callback (lambda (f) (setf callback f))))
+ (when ,commands (funcall callback ,commands))
+ (format nil "~A~A~A"
+ (if ,reporter (format nil "~A~%" (funcall (intern "DUMP-OBJECT" :clnl-nvm) (funcall callback ,reporter))) "")
+ (clnl-nvm:export-world)
+ (checksum-world))))
+ "bin/runcmd.scala"
+ (format nil "~A@#$#@#$#@~A@#$#@#$#@~A" ,commands (or ,reporter "") ,model)))
+
+(defmacro defmodelcommandtest (name model commands checksum)
+ `(defmodeltest (format nil "Model Command - ~A" ,name) ,model ,commands nil nil ,checksum))
+
+(defmacro defmodelreportertest (name model commands reporter value checksum)
+ `(defmodeltest (format nil "Model Reporter - ~A" ,name) ,model ,commands ,reporter ,value ,checksum))
(defmacro defviewtest (name commands checksum)
`(defsimpletest
--- /dev/null
+(in-package #:clnl-test)
+
+(defmodelcommandtest "globals 1"
+ "globals [a]"
+ "set a 5 crt a"
+ "4D66EDE80A8F4CA820D80853E763446502EA4E4E")
+
+(defmodelreportertest "globals 2"
+ "globals [a]"
+ "set a 5"
+ "a"
+ "5"
+ "F8507A0D88D681CCBF01898FEA263791F9DDCE63")
"4ABB6822402929878AB9E5A1084B9E4AE1F01D5B")
(defsimplecommandtest "ticks 1" "reset-ticks tick"
- "E1DE30F072D785E0D0B59F28B0F7853E3D3E0D8B")
+ "22A78AC53B666DE94611D566D814AD3EA7CC26AB")
(defreportertestwithsetup "ticks 2" "reset-ticks tick tick" "ticks" "2"
- "E1DE30F072D785E0D0B59F28B0F7853E3D3E0D8B")
+ "296AE6F478D03264745B0331EC5CEF578C37CAB9")
(defreportertestwithsetup "of / who 1" "crt 10" "[ who ] of turtles" "[5 9 4 3 7 0 1 2 6 8]"
"3F39BD2D8D5A1B2333E6C0DB665DBE3DCD5A75CE")
projects / clnl / commitdiff