From 762ab38881c8870c9a61ca6857a28159f9fef9fc Mon Sep 17 00:00:00 2001 From: Frank Duncan Date: Sun, 8 May 2016 10:11:28 -0500 Subject: [PATCH] Add export to common lisp form, forms --- bin/runcmd.scala | 50 +++++++++++-- src/main/code-parse.lisp | 30 +++++--- src/main/main.lisp | 147 +++++++++++++++++++++++++++++++++----- src/main/model.lisp | 60 ++++++++-------- src/main/nvm/base.lisp | 3 +- src/main/nvm/nvm.lisp | 19 +++-- src/main/package.lisp | 8 ++- src/main/transpile.lisp | 112 ++++++++++++++++++++--------- src/test/clnl-test.asd | 1 + src/test/main.lisp | 81 ++++++++++++++++++--- src/test/modeltests.lisp | 13 ++++ src/test/simpletests.lisp | 4 +- 12 files changed, 412 insertions(+), 116 deletions(-) create mode 100644 src/test/modeltests.lisp diff --git a/bin/runcmd.scala b/bin/runcmd.scala index e2d16d7..f466887 100755 --- a/bin/runcmd.scala +++ b/bin/runcmd.scala @@ -23,21 +23,63 @@ import org.nlogo.util.Utils.url2String 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) diff --git a/src/main/code-parse.lisp b/src/main/code-parse.lisp index 7d9c42c..e9b4d77 100644 --- a/src/main/code-parse.lisp +++ b/src/main/code-parse.lisp @@ -7,7 +7,10 @@ ; 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)))) @@ -17,17 +20,21 @@ (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 @@ -38,23 +45,26 @@ DESCRIPTION: 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)) @@ -113,11 +123,11 @@ DESCRIPTION: 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))))) diff --git a/src/main/main.lisp b/src/main/main.lisp index 3acd6e3..f20062b 100644 --- a/src/main/main.lisp +++ b/src/main/main.lisp @@ -8,7 +8,7 @@ (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))) @@ -29,12 +29,13 @@ DESCRIPTION: (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: @@ -42,11 +43,15 @@ 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))) @@ -62,7 +67,7 @@ DESCRIPTION: 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 @@ -76,14 +81,120 @@ DESCRIPTION: 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.") diff --git a/src/main/model.lisp b/src/main/model.lisp index 7a18fb0..022a658 100644 --- a/src/main/model.lisp +++ b/src/main/model.lisp @@ -27,6 +27,7 @@ DESCRIPTION: Returns the default startup model." (make-model + :code "" :interface (list (make-view :min-pxcor -5 :max-pxcor 5 :min-pycor -5 :max-pycor 5)))) @@ -54,15 +55,7 @@ DESCRIPTION: (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) @@ -230,33 +223,40 @@ DESCRIPTION: :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)) diff --git a/src/main/nvm/base.lisp b/src/main/nvm/base.lisp index fc2db58..af87bc2 100644 --- a/src/main/nvm/base.lisp +++ b/src/main/nvm/base.lisp @@ -7,6 +7,7 @@ (defvar *myself* nil) (defvar *self* nil) (defvar *dimensions* nil) +(defvar *globals* nil) (defvar *topology* :torus) (defvar *ticks* nil) (defvar *breeds* nil) @@ -26,7 +27,7 @@ DESCRIPTION: 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) diff --git a/src/main/nvm/nvm.lisp b/src/main/nvm/nvm.lisp index a272a34..766df53 100644 --- a/src/main/nvm/nvm.lisp +++ b/src/main/nvm/nvm.lisp @@ -647,10 +647,12 @@ DESCRIPTION: (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: @@ -659,6 +661,8 @@ 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: @@ -667,6 +671,7 @@ 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) @@ -794,11 +799,13 @@ DESCRIPTION: (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)) "" diff --git a/src/main/package.lisp b/src/main/package.lisp index 89a0ab3..f3aef8a 100644 --- a/src/main/package.lisp +++ b/src/main/package.lisp @@ -1,5 +1,7 @@ (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 @@ -43,7 +45,7 @@ to match how java.util.Random works. Turtles, all the way down.")) (defpackage #:clnl-transpiler (:use :common-lisp) - (:export #:transpile-commands #:transpile-reporter) + (:export #:transpile #:reporter-p #:command-list-p) (:documentation "CLNL Transpiler @@ -129,7 +131,7 @@ is where all the features that the traditional NetLogo UI lives.")) (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 diff --git a/src/main/transpile.lisp b/src/main/transpile.lisp index b0fcb47..327bdbd 100644 --- a/src/main/transpile.lisp +++ b/src/main/transpile.lisp @@ -1,40 +1,103 @@ (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))) @@ -67,27 +130,10 @@ DESCRIPTION: (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) @@ -100,7 +146,7 @@ DESCRIPTION: ((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) @@ -124,9 +170,6 @@ DESCRIPTION: (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)))) @@ -159,6 +202,7 @@ DESCRIPTION: (defagentvalueprim :label) (defagentvalueprim :label-color) +(defsimpleprim :let :command nil) (defsimpleprim :lt :command clnl-nvm:turn-left) (defsimpleprim :not :reporter cl:not) (defkeywordprim :nobody) diff --git a/src/test/clnl-test.asd b/src/test/clnl-test.asd index 8e0a9dd..774f153 100644 --- a/src/test/clnl-test.asd +++ b/src/test/clnl-test.asd @@ -6,5 +6,6 @@ :components ((:file "package") (:file "main") (:file "simpletests") + (:file "modeltests") (:file "viewtests")) :depends-on (#-travis :ironclad :clnl)) diff --git a/src/test/main.lisp b/src/test/main.lisp index 99dfe18..e02a5d4 100644 --- a/src/test/main.lisp +++ b/src/test/main.lisp @@ -53,11 +53,11 @@ `(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) @@ -69,37 +69,102 @@ `(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 diff --git a/src/test/modeltests.lisp b/src/test/modeltests.lisp new file mode 100644 index 0000000..0ec8d01 --- /dev/null +++ b/src/test/modeltests.lisp @@ -0,0 +1,13 @@ +(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") diff --git a/src/test/simpletests.lisp b/src/test/simpletests.lisp index 378385a..4963164 100644 --- a/src/test/simpletests.lisp +++ b/src/test/simpletests.lisp @@ -160,10 +160,10 @@ "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") -- 2.25.1