code.consxy.com Git - clnl/blob - src/main/clnl/main.lisp

   1 (in-package #:clnl)
   2
   3 (defun e (ast) ast)
   4
   5 (defun r (str)
   6  (let*
   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)))
  14
  15 (defun p (result) result)
  16
  17 (defun run (&optional file)
  18  "RUN &optional FILE => RESULT
  19
  20 ARGUMENTS AND VALUES:
  21
  22   FILE: nlogo file with which to initialize
  23   RESULT: undefined, the system terminates at the end of the loop
  24
  25 DESCRIPTION:
  26
  27   RUN starts up the CLNL system."
  28  (boot file)
  29  (clnl-interface:run))
  30
  31 (defvar *callback* nil)
  32
  33 (defun boot (&optional file headless-mode)
  34  "BOOT &optional FILE HEADLESS-MODE => RESULT
  35
  36 ARGUMENTS AND VALUES:
  37
  38   FILE: nlogo file with which to initialize state
  39   HEADLESS-MODE: a boolean, defaults to nil
  40   RESULT: undefined
  41
  42 DESCRIPTION:
  43
  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.
  46
  47   When FILE is not provided, a default model is used.
  48
  49   When HEADLESS-MODE is set to nil, the opengl interface is initialized.
  50   Otherwise, the model will run headlessly, with no view."
  51  (let
  52   ((netlogoed-lisp
  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)))
  59
  60 (defvar *commands-mutex* (sb-thread:make-mutex))
  61
  62 (defun run-commands (cmds)
  63  "RUN-COMMANDS CMDS => RESULT
  64
  65 ARGUMENTS AND VALUES:
  66
  67   CMDS: A string that may have one more NetLogo commands
  68   RESULT: undefined
  69
  70 DESCRIPTION:
  71
  72   RUN-COMMANDS will take NetLogo commands, put them through the various
  73   stages need to turn them into Common Lisp code, and run it."
  74
  75  ; This mutex is a necessary because we haven't yet moved to a job thread
  76  (sb-thread:with-mutex (*commands-mutex*)
  77   (clnl-nvm:with-stop-handler
  78    (funcall *callback* cmds))))
  79
  80 (defun run-reporter (reporter)
  81  "RUN-REPORTER REPORTER => RESULT
  82
  83 ARGUMENTS AND VALUES:
  84
  85   REPORTER: A string that should have only one reporter
  86   RESULT: The value reported by the NVM
  87
  88 DESCRIPTION:
  89
  90   RUN-REPORTER will take a NetLogo REPORTER, put it through the various
  91   stages need to turn them into Common Lisp code, run it, and return the RESULT."
  92  (eval (clnl-transpiler:transpile (clnl-parser:parse (clnl-lexer:lex reporter)))))
  93
  94 ; Because prims are used both at generation time and later at runtime, certain things in
  95 ; them must be escaped a little bit more, such as wrapping the whole thing in a list
  96 ; primitive.  This way, the output of these things looks like halfway decent lisp,
  97 ; and everything works nicely.  We don't want any <FUNC #> showing up or anything
  98 (defun munge-prim (prim)
  99  (let
 100   ((copied (copy-list prim)))
 101   (when (getf copied :args) (setf (getf copied :args) `(quote ,(getf copied :args))))
 102   `(list ,@copied)))
 103
 104 (defun netlogo-callback-body (prims)
 105  `(eval
 106    (clnl-transpiler:transpile
 107     (clnl-parser:parse
 108      (clnl-lexer:lex ,(intern "NETLOGO-CODE" *model-package*))
 109      (list ,@(mapcar #'munge-prim prims)))
 110     (list ,@(mapcar #'munge-prim prims)))))
 111
 112 (defun create-world-call (model globals code-ast)
 113  `(clnl-nvm:create-world
 114    :dims ',(clnl-model:world-dimensions model)
 115    :globals (list
 116              ,@(mapcar
 117                 (lambda (pair)
 118                  `(list ,(car pair) (lambda () ,(intern (string-upcase (car pair)) *model-package*))))
 119                 globals))
 120    :turtles-own-vars ',(clnl-code-parser:turtles-own-vars code-ast)
 121    :patches-own-vars ',(clnl-code-parser:patches-own-vars code-ast)
 122    :breeds ',(clnl-code-parser:breeds code-ast)))
 123
 124 (defun create-proc-body (proc prims)
 125  `(,(intern (string-upcase (car proc)) *model-package*) ()
 126    (clnl-nvm:with-stop-handler
 127     ,@(cdr ; remove the progn, cuz it looks nicer
 128        (clnl-transpiler:transpile (cadr proc)
 129         (mapcar
 130          (lambda (prim)
 131           (if (getf prim :macro) ; The reason we do this is because with macros, we want to evaluate them in
 132                                  ; this scope while preserving them for the generational purposes below
 133            (append (list :macro (eval (getf prim :macro))) prim)
 134            prim)) prims)))
 135     :undefined)))
 136
 137 (defun nlogo->lisp (str pkg-symb boot-fn &key (seed 15) initialize-interface netlogo-callback-fn)
 138  (let*
 139   ((model (clnl-model:read-from-nlogo str))
 140    (shadow-symbs
 141     (remove nil
 142      (mapcar
 143       (lambda (proc-symb)
 144        (multiple-value-bind (found external) (find-symbol (symbol-name proc-symb) :cl)
 145         (when (and found (eql :external external)) proc-symb)))
 146       (mapcar #'car
 147        (clnl-code-parser:procedures
 148         (clnl-code-parser:parse
 149          (clnl-lexer:lex (clnl-model:code model))
 150          (clnl-model:widget-globals model))))))))
 151   (eval
 152    `(progn
 153      (defpackage ,pkg-symb (:use :common-lisp) (:shadow ,@shadow-symbs))
 154      (,(intern "IN-PACKAGE" :cl) ,pkg-symb) ; intern because of style check
 155      (cons
 156       `(defpackage ,,pkg-symb (:use :common-lisp) (:shadow ,,@shadow-symbs))
 157       (let
 158        ((clnl:*model-package* (find-package ,pkg-symb)))
 159        (clnl:model->multi-form-lisp
 160         ,model
 161         (intern (symbol-name ',boot-fn) ,pkg-symb)
 162         :seed ,seed
 163         :initialize-interface ,initialize-interface
 164         :netlogo-callback-fn ,netlogo-callback-fn)))))))
 165
 166 (setf (documentation 'nlogo->lisp 'function)
 167  "NLOGO->LISP STR PKG-SYMB BOOT-FN &key SEED INITIALIZE-INTERFACE NETLOGO-CALLBACK-FN => FORMS
 168
 169 ARGUMENTS AND VALUES:
 170
 171   STR: A stream holding an nlogo file
 172   PKG-SYMB: A symbol for the generated package
 173   BOOT-FN: A function name
 174   SEED: An integer, defaults to 15
 175   INITIALIZE-INTERFACE: A boolean
 176   NETLOGO-CALLBACK-FN: a symbol
 177   FORMS: A list of common lisp form
 178
 179 DESCRIPTION:
 180
 181   NLOGO->LISP takes a stream STR and returns a multi form lisp program,
 182   that when executed, sets up the model.  See MODEL->MULTI-FORM-LISP for
 183   more information.
 184
 185   NLOGO->LISP does extra work of setting up the package to be named by
 186   PKG-SYMB in order to correctly shadow common lisp functions.
 187
 188   It will also change the current package to the one created for the model
 189   named by PKG-SYMB.
 190
 191 EXAMPLES:
 192
 193   (with-open-file (str \"Wolf Sheep Predation.nlogo\") (nlogo->lisp str :wolfsheep 'boot)) => (forms)")
 194
 195 (defun model->single-form-lisp (model &key (seed 15) initialize-interface netlogo-callback)
 196  (multiple-value-bind
 197   (code-ast prims)
 198   (clnl-code-parser:parse (clnl-lexer:lex (clnl-model:code model)) (clnl-model:widget-globals model))
 199   (let
 200    ((globals
 201      (append
 202       (clnl-code-parser:globals code-ast)
 203       (clnl-model:widget-globals model))))
 204    `(progn
 205      ,@(mapcar
 206         (lambda (pair) `(defparameter ,(intern (string-upcase (car pair)) *model-package*) ,(cadr pair)))
 207         globals)
 208      (labels
 209       ,(mapcar
 210         (lambda (proc) (create-proc-body proc prims))
 211         (clnl-code-parser:procedures code-ast))
 212       (clnl-random:set-seed ,seed)
 213       (clnl-model:set-current-interface ',(clnl-model:interface model))
 214       ,@(when netlogo-callback
 215          `((clnl-model:set-callback
 216             (lambda (,(intern "NETLOGO-CODE" *model-package*)) ,(netlogo-callback-body prims)))))
 217       ,(create-world-call model globals code-ast)
 218       ,@(when netlogo-callback
 219          `((funcall ,netlogo-callback
 220             (lambda (,(intern "NETLOGO-CODE" *model-package*))
 221              ,(netlogo-callback-body prims)))))
 222       ,@(when initialize-interface
 223          `((clnl-interface:initialize
 224             :dims ',(clnl-model:world-dimensions model)
 225             :view ',(clnl-model:view model)
 226             :buttons ',(clnl-model:buttons model)
 227             :textboxes ',(clnl-model:textboxes model)
 228             :sliders ',(clnl-model:sliders model)
 229             :switches ',(clnl-model:switches model)))))))))
 230
 231 (setf (documentation 'model->single-form-lisp 'function)
 232  "MODEL->SINGLE-FORM-LISP MODEL &key SEED INITIALIZE-INTERFACE NETLOGO-CALLBACK => FORM
 233
 234 ARGUMENTS AND VALUES:
 235
 236   MODEL: A valid model
 237   SEED: An integer, defaults to 15
 238   INITIALIZE-INTERFACE: A boolean
 239   NETLOGO-CALLBACK: A function of one argument, or a symbol
 240   FORM: A common lisp form
 241
 242 DESCRIPTION:
 243
 244   MODEL->SINGLE-FORM-LISP takes a model and returns a lisp program as a single form,
 245   that when executed runs the model.  The SEED passed in is used to start the
 246   clnl-random RNG.
 247
 248   INITIALIZE-INTERFACE, when non nil, leads to initialization code for the
 249   opengl interface being included.
 250
 251   NETLOGO-CALLBACK is a function that when called with a single argument,
 252   a function that when called with netlogo code, will compile and run that
 253   code in the environment of the model.
 254
 255   Of note, all globals defined either in the model code or via the widgets
 256   are declared special in order to remain in the lexical environment for EVAL.")
 257
 258 (defun model->multi-form-lisp (model boot-fn &key (seed 15) initialize-interface netlogo-callback-fn)
 259  (multiple-value-bind
 260   (code-ast prims)
 261   (clnl-code-parser:parse (clnl-lexer:lex (clnl-model:code model)) (clnl-model:widget-globals model))
 262   (let
 263    ((globals
 264      (append
 265       (clnl-model:widget-globals model)
 266       (clnl-code-parser:globals code-ast))))
 267    `((in-package ,(intern (package-name *model-package*) :keyword))
 268      ,@(mapcar
 269         (lambda (pair)
 270          `(defvar ,(intern (string-upcase (car pair)) *model-package*) ,(cadr pair)))
 271         globals)
 272      ,@(mapcar
 273         (lambda (proc) `(defun ,@(create-proc-body proc prims)))
 274         (clnl-code-parser:procedures code-ast))
 275      (defun ,boot-fn ()
 276       (clnl-random:set-seed ,seed)
 277       (clnl-model:set-current-interface ',(clnl-model:interface model))
 278       (clnl-model:set-callback (symbol-function ',netlogo-callback-fn))
 279       ,(create-world-call model globals code-ast)
 280       ,@(when initialize-interface
 281          `((clnl-interface:initialize
 282             :dims ',(clnl-model:world-dimensions model)
 283             :view ',(clnl-model:view model)
 284             :buttons ',(clnl-model:buttons model)
 285             :textboxes ',(clnl-model:textboxes model)
 286             :sliders ',(clnl-model:sliders model)
 287             :switches ',(clnl-model:switches model)))))
 288      ,@(when netlogo-callback-fn
 289         `((defun ,netlogo-callback-fn (,(intern "NETLOGO-CODE" *model-package*))
 290            ,(netlogo-callback-body prims))))))))
 291
 292 (setf (documentation 'model->multi-form-lisp 'function)
 293  "MODEL->MULTI-FORM-LISP MODEL BOOT-FN &key SEED INITIALIZE-INTERFACE NETLOGO-CALLBACK-FN => FORMS
 294
 295 ARGUMENTS AND VALUES:
 296
 297   MODEL: A valid model
 298   BOOT-FN: A function name
 299   SEED: An integer, defaults to 15
 300   INITIALIZE-INTERFACE: A boolean
 301   NETLOGO-CALLBACK-FN: a symbol
 302   FORMS: A list of common lisp form
 303
 304 DESCRIPTION:
 305
 306   MODEL->MULTI-FORM-LISP takes a model and returns a multi form lisp program,
 307   that when executed, sets up the model.  Procedures map to defuns, globals
 308   to defvars, etc.  This can be output to load up quickly later.  A function
 309   named by BOOT-FN will be set for booting the program.
 310
 311   The SEED passed in is used to start the clnl-random RNG.
 312
 313   INITIALIZE-INTERFACE, when non nil, leads to initialization code for the
 314   opengl interface being included.
 315
 316   NETLOGO-CALLBACK-FN is a symbol that will be defined as a function
 317   to be called to execute code in the running netlogo instance.")