(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
((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
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
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*) ()
+ (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)
(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
`(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
projects / clnl / blobdiff