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."
29 (sb-thread:make-thread #'clnl-cli:run)
32 (defun boot (&optional file headless-mode)
33 "BOOT &optional FILE HEADLESS-MODE => RESULT
37 FILE: nlogo file with which to initialize state
38 HEADLESS-MODE: a boolean, defaults to nil
43 BOOT does exactly that, boots the clnl system in a clean state. The seed
44 is set so that multiple runs will evaluate to the same.
46 When FILE is not provided, a default model is used.
48 When HEADLESS-MODE is set to nil, the opengl interface is initialized.
49 Otherwise, the model will run headlessly, with no view."
52 (model->single-form-lisp
53 (if file (with-open-file (str file) (clnl-model:read-from-nlogo str)) (clnl-model:default-model))
54 :initialize-interface (not headless-mode)))
55 (*package* *model-package*))
56 (eval netlogoed-lisp)))
58 (defun run-commands (cmds)
59 "RUN-COMMANDS CMDS => RESULT
63 CMDS: A string that may have one more NetLogo commands
68 RUN-COMMANDS will take NetLogo commands, put them through the various
69 stages need to turn them into Common Lisp code, and run it."
70 (clnl-nvm:with-stop-handler (eval (clnl-transpiler:transpile (clnl-parser:parse (clnl-lexer:lex cmds))))))
72 (defun run-reporter (reporter)
73 "RUN-REPORTER REPORTER => RESULT
77 REPORTER: A string that should have only one reporter
78 RESULT: The value reported by the NVM
82 RUN-REPORTER will take a NetLogo REPORTER, put it through the various
83 stages need to turn them into Common Lisp code, run it, and return the RESULT."
84 (eval (clnl-transpiler:transpile (clnl-parser:parse (clnl-lexer:lex reporter)))))
86 (defun model->single-form-lisp (model &key (seed 15) initialize-interface netlogo-callback)
89 (clnl-code-parser:parse (clnl-lexer:lex (clnl-model:code model)) (clnl-model:widget-globals model))
93 (clnl-model:widget-globals model)
94 (clnl-code-parser:globals code-ast))))
96 ; First declare is in case we don't use it, it shows up in export correctly
97 (declare (special ,@(mapcar (lambda (pair) (intern (string-upcase (car pair)) *model-package*)) globals)))
99 ,(mapcar (lambda (pair) (list (intern (string-upcase (car pair)) *model-package*) (cadr pair))) globals)
100 ; We declare twice rather than once and doing a bunch of setfs
101 (declare (special ,@(mapcar (lambda (pair) (intern (string-upcase (car pair)) *model-package*)) globals)))
105 `(,(intern (string-upcase (car proc)) *model-package*) ()
106 ,@(cdr ; remove the progn, cuz it looks nicer
107 (clnl-transpiler:transpile (cadr proc)
110 (if (getf prim :macro) ; The reason we do this is because with macros, we want to evaluate them in
111 ; this scope while preserving them for the generational purposes below
112 (append (list :macro (eval (getf prim :macro))) prim)
114 (clnl-code-parser:procedures code-ast))
115 (clnl-random:set-seed ,seed)
116 (clnl-nvm:create-world
117 :dims ',(clnl-model:world-dimensions model)
121 `(list ,(car pair) (lambda () ,(intern (string-upcase (car pair)) *model-package*))))
123 :turtles-own-vars ',(clnl-code-parser:turtles-own-vars code-ast))
124 ,@(when netlogo-callback
125 `((funcall ,netlogo-callback
126 (lambda (netlogo-code)
128 (clnl-transpiler:transpile
130 (clnl-lexer:lex netlogo-code)
131 (list ,@(mapcar (lambda (prim) `(list ,@prim)) prims)))
132 (list ,@(mapcar (lambda (prim) `(list ,@prim)) prims))))))))
133 ,@(when initialize-interface `((clnl-interface:initialize :dims ',(clnl-model:world-dimensions model))))))))))
135 (setf (documentation 'model->single-form-lisp 'function)
136 "MODEL->SINGLE-FORM-LISP MODEL &key SEED INITIALIZE-INTERFACE NETLOGO-CALLBACK => FORM
138 ARGUMENTS AND VALUES:
141 SEED: An integer, defaults to 15
142 INITIALIZE-INTERFACE: A boolean
143 NETLOGO-CALLBACK: A function of one argument, or a symbol
144 FORM: A common lisp form
148 MODEL->SINGLE-FORM-LISP takes a model and returns a lisp program as a single form,
149 that when executed runs the model. The SEED passed in is used to start the
152 INITIALIZE-INTERFACE, when non nil, leads to initialization code for the
153 opengl interface being included.
155 NETLOGO-CALLBACK is a function that when called with a single argument,
156 a function that when called with netlogo code, will compile and run that
157 code in the environment of the model.
159 Of note, all globals defined either in the model code or via the widgets
160 are declared special in order to remain in the lexical environment for EVAL.")
162 (defun model->multi-form-lisp (model boot-fn &key (seed 15) initialize-interface netlogo-callback-fn)
165 (clnl-code-parser:parse (clnl-lexer:lex (clnl-model:code model)) (clnl-model:widget-globals model))
169 (clnl-model:widget-globals model)
170 (clnl-code-parser:globals code-ast))))
171 `((in-package ,(intern (package-name *model-package*) :keyword))
174 `(defvar ,(intern (string-upcase (car pair)) *model-package*) ,(cadr pair)))
178 `(defun ,(intern (string-upcase (car proc)) *model-package*) ()
179 ,@(cdr ; remove the progn, cuz it looks nicer
180 (clnl-transpiler:transpile (cadr proc)
183 (if (getf prim :macro) ; The reason we do this is because with macros, we want to evaluate them in
184 ; this scope while preserving them for the generational purposes below
185 (append (list :macro (eval (getf prim :macro))) prim)
187 (clnl-code-parser:procedures code-ast))
189 (clnl-random:set-seed ,seed)
190 (clnl-nvm:create-world
191 :dims ',(clnl-model:world-dimensions model)
194 (lambda (pair) `(list ,(car pair) (lambda () ,(intern (string-upcase (car pair)) *model-package*))))
196 :turtles-own-vars ',(clnl-code-parser:turtles-own-vars code-ast))
197 ,@(when initialize-interface `((clnl-interface:initialize :dims ',(clnl-model:world-dimensions model)))))
198 ,@(when netlogo-callback-fn
199 `((defun ,netlogo-callback-fn (,(intern "NETLOGO-CODE" *model-package*))
201 (clnl-transpiler:transpile
203 (clnl-lexer:lex ,(intern "NETLOGO-CODE" *model-package*))
204 (list ,@(mapcar (lambda (prim) `(list ,@prim)) prims)))
205 (list ,@(mapcar (lambda (prim) `(list ,@prim)) prims)))))))))))
207 (setf (documentation 'model->multi-form-lisp 'function)
208 "MODEL->MULTI-FORM-LISP MODEL BOOT-FN &key SEED INITIALIZE-INTERFACE NETLOGO-CALLBACK-FN => FORMS
210 ARGUMENTS AND VALUES:
213 BOOT-FN: A function name
214 SEED: An integer, defaults to 15
215 INITIALIZE-INTERFACE: A boolean
216 NETLOGO-CALLBACK-FN: a symbol
217 FORMS: A list of common lisp form
221 MODEL->MULTI-FORM-LISP takes a model and returns a multi form lisp program,
222 that when executed, sets up the model. Procedures map to defuns, globals
223 to defvars, etc. This can be output to load up quickly later. A function
224 named by BOOT-FN will be set for booting the program.
226 The SEED passed in is used to start the clnl-random RNG.
228 INITIALIZE-INTERFACE, when non nil, leads to initialization code for the
229 opengl interface being included.
231 NETLOGO-CALLBACK-FN is a symbol that will be defined as a function
232 to be called to execute code in the running netlogo instance.")