X-Git-Url: https://code.consxy.com/gitweb/gitweb.cgi?p=clnl;a=blobdiff_plain;f=src%2Fmain%2Fmain.lisp;h=920e4e8445d69143a036710ead791d7e1233d335;hp=e774de3889987027e296be3441a616a6f5e4a01e;hb=89cb3482de1fefc2d8e5f67e1e04a0790e8cd243;hpb=f22f4e32c969e564c1ab388c2f5a9574b8631ce9 diff --git a/src/main/main.lisp b/src/main/main.lisp index e774de3..920e4e8 100644 --- a/src/main/main.lisp +++ b/src/main/main.lisp @@ -1,4 +1,317 @@ -(in-package #:cl-nl) +(in-package #:clnl) -(defun run () - (format t "AH HA~%")) +(defun e (ast) ast) + +(defun r (str) + (let* + ((lexed-ast (let ((ast (clnl-lexer:lex str))) + (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 parsed-ast))) + (format t "Via transpiling, AST for~%~S~% became~%~S~%" parsed-ast ast) ast))) + (eval transpiled-ast))) + +(defun p (result) result) + +(defun run (&optional file) + "RUN &optional FILE => RESULT + +ARGUMENTS AND VALUES: + + FILE: nlogo file with which to initialize + RESULT: undefined, the system terminates at the end of the loop + +DESCRIPTION: + + RUN starts up the CLNL system." + (boot file) + (clnl-interface:run)) + +(defvar *callback* nil) + +(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 HEADLESS-MODE is set to nil, the opengl interface is initialized. + Otherwise, the model will run headlessly, with no view." + (let + ((netlogoed-lisp + (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) + :netlogo-callback (lambda (f) (setf *callback* f)))) + (*package* *model-package*)) + (eval netlogoed-lisp))) + +(defvar *commands-mutex* (sb-thread:make-mutex)) + +(defun run-commands (cmds) + "RUN-COMMANDS CMDS => RESULT + +ARGUMENTS AND VALUES: + + CMDS: A string that may have one more NetLogo commands + RESULT: undefined + +DESCRIPTION: + + RUN-COMMANDS will take NetLogo commands, put them through the various + stages need to turn them into Common Lisp code, and run it." + + ; This mutex is a necessary because we haven't yet moved to a job thread + (sb-thread:with-mutex (*commands-mutex*) + (clnl-nvm:with-stop-handler + (funcall *callback* cmds)))) + +(defun run-reporter (reporter) + "RUN-REPORTER REPORTER => RESULT + +ARGUMENTS AND VALUES: + + REPORTER: A string that should have only one reporter + RESULT: The value reported by the NVM + +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 (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 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*) () + (clnl-nvm:with-stop-handler + ,@(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))) + :undefined))) + +(defun nlogo->lisp (str pkg-symb boot-fn &key (seed 15) initialize-interface netlogo-callback-fn) + (let* + ((model (clnl-model:read-from-nlogo str)) + (shadow-symbs + (remove nil + (mapcar + (lambda (proc-symb) + (multiple-value-bind (found external) (find-symbol (symbol-name proc-symb) :cl) + (when (and found (eql :external external)) proc-symb))) + (mapcar #'car + (clnl-code-parser:procedures + (clnl-code-parser:parse + (clnl-lexer:lex (clnl-model:code model)) + (clnl-model:widget-globals model)))))))) + (eval + `(progn + (defpackage ,pkg-symb (:use :common-lisp) (:shadow ,@shadow-symbs)) + (,(intern "IN-PACKAGE" :cl) ,pkg-symb) ; intern because of style check + (cons + `(defpackage ,,pkg-symb (:use :common-lisp) (:shadow ,,@shadow-symbs)) + (let + ((clnl:*model-package* (find-package ,pkg-symb))) + (clnl:model->multi-form-lisp + ,model + (intern (symbol-name ',boot-fn) ,pkg-symb) + :seed ,seed + :initialize-interface ,initialize-interface + :netlogo-callback-fn ,netlogo-callback-fn))))))) + +(setf (documentation 'nlogo->lisp 'function) + "NLOGO->LISP STR PKG-SYMB BOOT-FN &key SEED INITIALIZE-INTERFACE NETLOGO-CALLBACK-FN => FORMS + +ARGUMENTS AND VALUES: + + STR: A stream holding an nlogo file + PKG-SYMB: A symbol for the generated package + 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: + + NLOGO->LISP takes a stream STR and returns a multi form lisp program, + that when executed, sets up the model. See MODEL->MULTI-FORM-LISP for + more information. + + NLOGO->LISP does extra work of setting up the package to be named by + PKG-SYMB in order to correctly shadow common lisp functions. + + It will also change the current package to the one created for the model + named by PKG-SYMB. + +EXAMPLES: + + (with-open-file (str \"Wolf Sheep Predation.nlogo\") (nlogo->lisp str :wolfsheep 'boot)) => (forms)") + +(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-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) + (clnl-model:set-current-interface ',(clnl-model:interface model)) + ,@(when netlogo-callback + `((clnl-model:set-callback + (lambda (,(intern "NETLOGO-CODE" *model-package*)) ,(netlogo-callback-body prims))))) + ,(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) + :view ',(clnl-model:view model) + :buttons ',(clnl-model:buttons model) + :textboxes ',(clnl-model:textboxes model) + :sliders ',(clnl-model:sliders model) + :switches ',(clnl-model:switches 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) + ,@(mapcar + (lambda (proc) `(defun ,@(create-proc-body proc prims))) + (clnl-code-parser:procedures code-ast)) + (defun ,boot-fn () + (clnl-random:set-seed ,seed) + (clnl-model:set-current-interface ',(clnl-model:interface model)) + (clnl-model:set-callback (symbol-function ',netlogo-callback-fn)) + ,(create-world-call model globals code-ast) + ,@(when initialize-interface + `((clnl-interface:initialize + :dims ',(clnl-model:world-dimensions model) + :view ',(clnl-model:view model) + :buttons ',(clnl-model:buttons model) + :textboxes ',(clnl-model:textboxes model) + :sliders ',(clnl-model:sliders model) + :switches ',(clnl-model:switches model))))) + ,@(when netlogo-callback-fn + `((defun ,netlogo-callback-fn (,(intern "NETLOGO-CODE" *model-package*)) + ,(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 + +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.")