X-Git-Url: https://code.consxy.com/gitweb/gitweb.cgi?p=clnl;a=blobdiff_plain;f=src%2Fmain%2Fmain.lisp;h=920e4e8445d69143a036710ead791d7e1233d335;hp=6f319c48fe5abd7cc944c08b48c69d123db6d987;hb=89cb3482de1fefc2d8e5f67e1e04a0790e8cd243;hpb=97c390f3cee5094fa6795acd4b25b7598d5dd1bd diff --git a/src/main/main.lisp b/src/main/main.lisp index 6f319c4..920e4e8 100644 --- a/src/main/main.lisp +++ b/src/main/main.lisp @@ -14,21 +14,22 @@ (defun p (result) result) -(defun run () - "RUN => 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) - (sb-thread:make-thread #'clnl-cli:run) + (boot file) (clnl-interface:run)) +(defvar *callback* nil) + (defun boot (&optional file headless-mode) "BOOT &optional FILE HEADLESS-MODE => RESULT @@ -51,10 +52,13 @@ DESCRIPTION: ((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))) + :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 @@ -67,7 +71,11 @@ 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 (clnl-parser:parse (clnl-lexer:lex cmds)))))) + + ; 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 @@ -83,6 +91,107 @@ DESCRIPTION: 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) @@ -90,47 +199,34 @@ DESCRIPTION: (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 - (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))) - (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))))) - (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)) - ,@(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)))))))))) + (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 @@ -174,35 +270,24 @@ DESCRIPTION: `(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)) - ,@(when initialize-interface `((clnl-interface:initialize :dims ',(clnl-model:world-dimensions model))))) + (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*)) - (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