code.consxy.com Git - clnl/blob - src/main/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 ()
  18  "RUN => RESULT
  19
  20 ARGUMENTS AND VALUES:
  21
  22   RESULT: undefined, the system terminates at the end of the loop
  23
  24 DESCRIPTION:
  25
  26   RUN starts up the CLNL system."
  27
  28  (boot)
  29  (sb-thread:make-thread #'clnl-cli:run)
  30  (clnl-interface:run))
  31
  32 (defvar *callback* nil)
  33
  34 (defun boot (&optional file headless-mode)
  35  "BOOT &optional FILE HEADLESS-MODE => RESULT
  36
  37 ARGUMENTS AND VALUES:
  38
  39   FILE: nlogo file with which to initialize state
  40   HEADLESS-MODE: a boolean, defaults to nil
  41   RESULT: undefined
  42
  43 DESCRIPTION:
  44
  45   BOOT does exactly that, boots the clnl system in a clean state.  The seed
  46   is set so that multiple runs will evaluate to the same.
  47
  48   When FILE is not provided, a default model is used.
  49
  50   When HEADLESS-MODE is set to nil, the opengl interface is initialized.
  51   Otherwise, the model will run headlessly, with no view."
  52  (let
  53   ((netlogoed-lisp
  54     (model->single-form-lisp
  55      (if file (with-open-file (str file) (clnl-model:read-from-nlogo str)) (clnl-model:default-model))
  56      :initialize-interface (not headless-mode)
  57      :netlogo-callback (lambda (f) (setf *callback* f))))
  58    (*package* *model-package*))
  59   (eval netlogoed-lisp)))
  60
  61 (defun run-commands (cmds)
  62  "RUN-COMMANDS CMDS => RESULT
  63
  64 ARGUMENTS AND VALUES:
  65
  66   CMDS: A string that may have one more NetLogo commands
  67   RESULT: undefined
  68
  69 DESCRIPTION:
  70
  71   RUN-COMMANDS will take NetLogo commands, put them through the various
  72   stages need to turn them into Common Lisp code, and run it."
  73  (clnl-nvm:with-stop-handler
  74   (funcall *callback* cmds)))
  75
  76 (defun run-reporter (reporter)
  77  "RUN-REPORTER REPORTER => RESULT
  78
  79 ARGUMENTS AND VALUES:
  80
  81   REPORTER: A string that should have only one reporter
  82   RESULT: The value reported by the NVM
  83
  84 DESCRIPTION:
  85
  86   RUN-REPORTER will take a NetLogo REPORTER, put it through the various
  87   stages need to turn them into Common Lisp code, run it, and return the RESULT."
  88  (eval (clnl-transpiler:transpile (clnl-parser:parse (clnl-lexer:lex reporter)))))
  89
  90 ; Because prims are used both at generation time and later at runtime, certain things in
  91 ; them must be escaped a little bit more, such as wrapping the whole thing in a list
  92 ; primitive.  This way, the output of these things looks like halfway decent lisp,
  93 ; and everything works nicely.  We don't want any <FUNC #> showing up or anything
  94 (defun munge-prim (prim)
  95  (let
  96   ((copied (copy-list prim)))
  97   (when (getf copied :args) (setf (getf copied :args) `(quote ,(getf copied :args))))
  98   `(list ,@copied)))
  99
 100 (defun netlogo-callback-body (prims)
 101  `(eval
 102    (clnl-transpiler:transpile
 103     (clnl-parser:parse
 104      (clnl-lexer:lex ,(intern "NETLOGO-CODE" *model-package*))
 105      (list ,@(mapcar #'munge-prim prims)))
 106     (list ,@(mapcar #'munge-prim prims)))))
 107
 108 (defun create-world-call (model globals code-ast)
 109  `(clnl-nvm:create-world
 110    :dims ',(clnl-model:world-dimensions model)
 111    :globals (list
 112              ,@(mapcar
 113                 (lambda (pair)
 114                  `(list ,(car pair) (lambda () ,(intern (string-upcase (car pair)) *model-package*))))
 115                 globals))
 116    :turtles-own-vars ',(clnl-code-parser:turtles-own-vars code-ast)
 117    :patches-own-vars ',(clnl-code-parser:patches-own-vars code-ast)
 118    :breeds ',(clnl-code-parser:breeds code-ast)))
 119
 120 (defun create-proc-body (proc prims)
 121  `(,(intern (string-upcase (car proc)) *model-package*) ()
 122    (clnl-nvm:with-stop-handler
 123     ,@(cdr ; remove the progn, cuz it looks nicer
 124        (clnl-transpiler:transpile (cadr proc)
 125         (mapcar
 126          (lambda (prim)
 127           (if (getf prim :macro) ; The reason we do this is because with macros, we want to evaluate them in
 128                                  ; this scope while preserving them for the generational purposes below
 129            (append (list :macro (eval (getf prim :macro))) prim)
 130            prim)) prims))))))
 131
 132 (defun model->single-form-lisp (model &key (seed 15) initialize-interface netlogo-callback)
 133  (multiple-value-bind
 134   (code-ast prims)
 135   (clnl-code-parser:parse (clnl-lexer:lex (clnl-model:code model)) (clnl-model:widget-globals model))
 136   (let
 137    ((globals
 138      (append
 139       (clnl-code-parser:globals code-ast)
 140       (clnl-model:widget-globals model))))
 141    `(progn
 142      ,@(mapcar
 143         (lambda (pair) `(defparameter ,(intern (string-upcase (car pair)) *model-package*) ,(cadr pair)))
 144         globals)
 145      (labels
 146       ,(mapcar
 147         (lambda (proc) (create-proc-body proc prims))
 148         (clnl-code-parser:procedures code-ast))
 149       (clnl-random:set-seed ,seed)
 150       ,(create-world-call model globals code-ast)
 151       ,@(when netlogo-callback
 152          `((funcall ,netlogo-callback
 153             (lambda (,(intern "NETLOGO-CODE" *model-package*))
 154              ,(netlogo-callback-body prims)))))
 155       ,@(when initialize-interface `((clnl-interface:initialize :dims ',(clnl-model:world-dimensions model)))))))))
 156
 157 (setf (documentation 'model->single-form-lisp 'function)
 158  "MODEL->SINGLE-FORM-LISP MODEL &key SEED INITIALIZE-INTERFACE NETLOGO-CALLBACK => FORM
 159
 160 ARGUMENTS AND VALUES:
 161
 162   MODEL: A valid model
 163   SEED: An integer, defaults to 15
 164   INITIALIZE-INTERFACE: A boolean
 165   NETLOGO-CALLBACK: A function of one argument, or a symbol
 166   FORM: A common lisp form
 167
 168 DESCRIPTION:
 169
 170   MODEL->SINGLE-FORM-LISP takes a model and returns a lisp program as a single form,
 171   that when executed runs the model.  The SEED passed in is used to start the
 172   clnl-random RNG.
 173
 174   INITIALIZE-INTERFACE, when non nil, leads to initialization code for the
 175   opengl interface being included.
 176
 177   NETLOGO-CALLBACK is a function that when called with a single argument,
 178   a function that when called with netlogo code, will compile and run that
 179   code in the environment of the model.
 180
 181   Of note, all globals defined either in the model code or via the widgets
 182   are declared special in order to remain in the lexical environment for EVAL.")
 183
 184 (defun model->multi-form-lisp (model boot-fn &key (seed 15) initialize-interface netlogo-callback-fn)
 185  (multiple-value-bind
 186   (code-ast prims)
 187   (clnl-code-parser:parse (clnl-lexer:lex (clnl-model:code model)) (clnl-model:widget-globals model))
 188   (let
 189    ((globals
 190      (append
 191       (clnl-model:widget-globals model)
 192       (clnl-code-parser:globals code-ast))))
 193    `((in-package ,(intern (package-name *model-package*) :keyword))
 194      ,@(mapcar
 195         (lambda (pair)
 196          `(defvar ,(intern (string-upcase (car pair)) *model-package*) ,(cadr pair)))
 197         globals)
 198      ,@(mapcar
 199         (lambda (proc) `(defun ,@(create-proc-body proc prims)))
 200         (clnl-code-parser:procedures code-ast))
 201      (defun ,boot-fn ()
 202       (clnl-random:set-seed ,seed)
 203       ,(create-world-call model globals code-ast)
 204       ,@(when initialize-interface `((clnl-interface:initialize :dims ',(clnl-model:world-dimensions model)))))
 205      ,@(when netlogo-callback-fn
 206         `((defun ,netlogo-callback-fn (,(intern "NETLOGO-CODE" *model-package*))
 207            ,(netlogo-callback-body prims))))))))
 208
 209 (setf (documentation 'model->multi-form-lisp 'function)
 210  "MODEL->MULTI-FORM-LISP MODEL BOOT-FN &key SEED INITIALIZE-INTERFACE NETLOGO-CALLBACK-FN => FORMS
 211
 212 ARGUMENTS AND VALUES:
 213
 214   MODEL: A valid model
 215   BOOT-FN: A function name
 216   SEED: An integer, defaults to 15
 217   INITIALIZE-INTERFACE: A boolean
 218   NETLOGO-CALLBACK-FN: a symbol
 219   FORMS: A list of common lisp form
 220
 221 DESCRIPTION:
 222
 223   MODEL->MULTI-FORM-LISP takes a model and returns a multi form lisp program,
 224   that when executed, sets up the model.  Procedures map to defuns, globals
 225   to defvars, etc.  This can be output to load up quickly later.  A function
 226   named by BOOT-FN will be set for booting the program.
 227
 228   The SEED passed in is used to start the clnl-random RNG.
 229
 230   INITIALIZE-INTERFACE, when non nil, leads to initialization code for the
 231   opengl interface being included.
 232
 233   NETLOGO-CALLBACK-FN is a symbol that will be defined as a function
 234   to be called to execute code in the running netlogo instance.")