7 ((lexed-ast (let ((ast (clnl-lexer:lex str)))
8 (format t "Via lexing, AST for~%~S~% became~%~S~%~%" str ast) ast))
9 (parsed-ast (let ((ast (clnl-parser:parse lexed-ast)))
10 (format t "Via parsing, AST for~%~S~% became~%~S~%~%" lexed-ast ast) ast))
11 (transpiled-ast (let ((ast (clnl-transpiler:transpile parsed-ast)))
12 (format t "Via transpiling, AST for~%~S~% became~%~S~%" parsed-ast ast) ast)))
13 (eval transpiled-ast)))
15 (defun p (result) result)
22 RESULT: undefined, the system terminates at the end of the loop
26 RUN starts up the CLNL system."
28 (sb-thread:make-thread #'clnl-cli:run)
31 (defvar *callback* nil)
33 (defun boot (&optional file headless-mode)
34 "BOOT &optional FILE HEADLESS-MODE => RESULT
38 FILE: nlogo file with which to initialize state
39 HEADLESS-MODE: a boolean, defaults to nil
44 BOOT does exactly that, boots the clnl system in a clean state. The seed
45 is set so that multiple runs will evaluate to the same.
47 When FILE is not provided, a default model is used.
49 When HEADLESS-MODE is set to nil, the opengl interface is initialized.
50 Otherwise, the model will run headlessly, with no view."
53 (model->single-form-lisp
54 (if file (with-open-file (str file) (clnl-model:read-from-nlogo str)) (clnl-model:default-model))
55 :initialize-interface (not headless-mode)
56 :netlogo-callback (lambda (f) (setf *callback* f))))
57 (*package* *model-package*))
58 (eval netlogoed-lisp)))
60 (defun run-commands (cmds)
61 "RUN-COMMANDS CMDS => RESULT
65 CMDS: A string that may have one more NetLogo commands
70 RUN-COMMANDS will take NetLogo commands, put them through the various
71 stages need to turn them into Common Lisp code, and run it."
72 (clnl-nvm:with-stop-handler
73 (funcall *callback* cmds)))
75 (defun run-reporter (reporter)
76 "RUN-REPORTER REPORTER => RESULT
80 REPORTER: A string that should have only one reporter
81 RESULT: The value reported by the NVM
85 RUN-REPORTER will take a NetLogo REPORTER, put it through the various
86 stages need to turn them into Common Lisp code, run it, and return the RESULT."
87 (eval (clnl-transpiler:transpile (clnl-parser:parse (clnl-lexer:lex reporter)))))
89 ; Because prims are used both at generation time and later at runtime, certain things in
90 ; them must be escaped a little bit more, such as wrapping the whole thing in a list
91 ; primitive. This way, the output of these things looks like halfway decent lisp,
92 ; and everything works nicely. We don't want any <FUNC #> showing up or anything
93 (defun munge-prim (prim)
95 ((copied (copy-list prim)))
96 (when (getf copied :args) (setf (getf copied :args) `(quote ,(getf copied :args))))
99 (defun netlogo-callback-body (prims)
101 (clnl-transpiler:transpile
103 (clnl-lexer:lex ,(intern "NETLOGO-CODE" *model-package*))
104 (list ,@(mapcar #'munge-prim prims)))
105 (list ,@(mapcar #'munge-prim prims)))))
107 (defun create-world-call (model globals code-ast)
108 `(clnl-nvm:create-world
109 :dims ',(clnl-model:world-dimensions model)
113 `(list ,(car pair) (lambda () ,(intern (string-upcase (car pair)) *model-package*))))
115 :turtles-own-vars ',(clnl-code-parser:turtles-own-vars code-ast)
116 :patches-own-vars ',(clnl-code-parser:patches-own-vars code-ast)
117 :breeds ',(clnl-code-parser:breeds code-ast)))
119 (defun create-proc-body (proc prims)
120 `(,(intern (string-upcase (car proc)) *model-package*) ()
121 (clnl-nvm:with-stop-handler
122 ,@(cdr ; remove the progn, cuz it looks nicer
123 (clnl-transpiler:transpile (cadr proc)
126 (if (getf prim :macro) ; The reason we do this is because with macros, we want to evaluate them in
127 ; this scope while preserving them for the generational purposes below
128 (append (list :macro (eval (getf prim :macro))) prim)
131 (defun model->single-form-lisp (model &key (seed 15) initialize-interface netlogo-callback)
134 (clnl-code-parser:parse (clnl-lexer:lex (clnl-model:code model)) (clnl-model:widget-globals model))
138 (clnl-code-parser:globals code-ast)
139 (clnl-model:widget-globals model))))
142 (lambda (pair) `(defparameter ,(intern (string-upcase (car pair)) *model-package*) ,(cadr pair)))
146 (lambda (proc) (create-proc-body proc prims))
147 (clnl-code-parser:procedures code-ast))
148 (clnl-random:set-seed ,seed)
149 ,(create-world-call model globals code-ast)
150 ,@(when netlogo-callback
151 `((funcall ,netlogo-callback
152 (lambda (,(intern "NETLOGO-CODE" *model-package*))
153 ,(netlogo-callback-body prims)))))
154 ,@(when initialize-interface `((clnl-interface:initialize :dims ',(clnl-model:world-dimensions model)))))))))
156 (setf (documentation 'model->single-form-lisp 'function)
157 "MODEL->SINGLE-FORM-LISP MODEL &key SEED INITIALIZE-INTERFACE NETLOGO-CALLBACK => FORM
159 ARGUMENTS AND VALUES:
162 SEED: An integer, defaults to 15
163 INITIALIZE-INTERFACE: A boolean
164 NETLOGO-CALLBACK: A function of one argument, or a symbol
165 FORM: A common lisp form
169 MODEL->SINGLE-FORM-LISP takes a model and returns a lisp program as a single form,
170 that when executed runs the model. The SEED passed in is used to start the
173 INITIALIZE-INTERFACE, when non nil, leads to initialization code for the
174 opengl interface being included.
176 NETLOGO-CALLBACK is a function that when called with a single argument,
177 a function that when called with netlogo code, will compile and run that
178 code in the environment of the model.
180 Of note, all globals defined either in the model code or via the widgets
181 are declared special in order to remain in the lexical environment for EVAL.")
183 (defun model->multi-form-lisp (model boot-fn &key (seed 15) initialize-interface netlogo-callback-fn)
186 (clnl-code-parser:parse (clnl-lexer:lex (clnl-model:code model)) (clnl-model:widget-globals model))
190 (clnl-model:widget-globals model)
191 (clnl-code-parser:globals code-ast))))
192 `((in-package ,(intern (package-name *model-package*) :keyword))
195 `(defvar ,(intern (string-upcase (car pair)) *model-package*) ,(cadr pair)))
198 (lambda (proc) `(defun ,@(create-proc-body proc prims)))
199 (clnl-code-parser:procedures code-ast))
201 (clnl-random:set-seed ,seed)
202 ,(create-world-call model globals code-ast)
203 ,@(when initialize-interface `((clnl-interface:initialize :dims ',(clnl-model:world-dimensions model)))))
204 ,@(when netlogo-callback-fn
205 `((defun ,netlogo-callback-fn (,(intern "NETLOGO-CODE" *model-package*))
206 ,(netlogo-callback-body prims))))))))
208 (setf (documentation 'model->multi-form-lisp 'function)
209 "MODEL->MULTI-FORM-LISP MODEL BOOT-FN &key SEED INITIALIZE-INTERFACE NETLOGO-CALLBACK-FN => FORMS
211 ARGUMENTS AND VALUES:
214 BOOT-FN: A function name
215 SEED: An integer, defaults to 15
216 INITIALIZE-INTERFACE: A boolean
217 NETLOGO-CALLBACK-FN: a symbol
218 FORMS: A list of common lisp form
222 MODEL->MULTI-FORM-LISP takes a model and returns a multi form lisp program,
223 that when executed, sets up the model. Procedures map to defuns, globals
224 to defvars, etc. This can be output to load up quickly later. A function
225 named by BOOT-FN will be set for booting the program.
227 The SEED passed in is used to start the clnl-random RNG.
229 INITIALIZE-INTERFACE, when non nil, leads to initialization code for the
230 opengl interface being included.
232 NETLOGO-CALLBACK-FN is a symbol that will be defined as a function
233 to be called to execute code in the running netlogo instance.")