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 (defun boot (&optional file headless-mode)
  33  "BOOT &optional FILE HEADLESS-MODE => RESULT
  34
  35 ARGUMENTS AND VALUES:
  36
  37   FILE: nlogo file with which to initialize state
  38   HEADLESS-MODE: a boolean, defaults to nil
  39   RESULT: undefined
  40
  41 DESCRIPTION:
  42
  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.
  45
  46   When FILE is not provided, a default model is used.
  47
  48   When HEADLESS-MODE is set to nil, the opengl interface is initialized.
  49   Otherwise, the model will run headlessly, with no view."
  50  (let
  51   ((netlogoed-lisp
  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)))
  57
  58 (defun run-commands (cmds)
  59  "RUN-COMMANDS CMDS => RESULT
  60
  61 ARGUMENTS AND VALUES:
  62
  63   CMDS: A string that may have one more NetLogo commands
  64   RESULT: undefined
  65
  66 DESCRIPTION:
  67
  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))))))
  71
  72 (defun run-reporter (reporter)
  73  "RUN-REPORTER REPORTER => RESULT
  74
  75 ARGUMENTS AND VALUES:
  76
  77   REPORTER: A string that should have only one reporter
  78   RESULT: The value reported by the NVM
  79
  80 DESCRIPTION:
  81
  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)))))
  85
  86 (defun model->single-form-lisp (model &key (seed 15) initialize-interface netlogo-callback)
  87  (multiple-value-bind
  88   (code-ast prims)
  89   (clnl-code-parser:parse (clnl-lexer:lex (clnl-model:code model)) (clnl-model:widget-globals model))
  90   (let
  91    ((globals
  92      (append
  93       (clnl-model:widget-globals model)
  94       (clnl-code-parser:globals code-ast))))
  95    `(prog ()
  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)))
  98      (let
  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)))
 102       (labels
 103        ,(mapcar
 104          (lambda (proc)
 105           `(,(intern (string-upcase (car proc)) *model-package*) ()
 106             ,@(cdr ; remove the progn, cuz it looks nicer
 107                (clnl-transpiler:transpile (cadr proc)
 108                 (mapcar
 109                  (lambda (prim)
 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)
 113                    prim)) prims)))))
 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)
 118         :globals (list
 119                   ,@(mapcar
 120                      (lambda (pair)
 121                       `(list ,(car pair) (lambda () ,(intern (string-upcase (car pair)) *model-package*))))
 122                      globals))
 123         :turtles-own-vars ',(clnl-code-parser:turtles-own-vars code-ast))
 124        ,@(when netlogo-callback
 125           `((funcall ,netlogo-callback
 126              (lambda (netlogo-code)
 127               (eval
 128                (clnl-transpiler:transpile
 129                 (clnl-parser:parse
 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))))))))))
 134
 135 (setf (documentation 'model->single-form-lisp 'function)
 136  "MODEL->SINGLE-FORM-LISP MODEL &key SEED INITIALIZE-INTERFACE NETLOGO-CALLBACK => FORM
 137
 138 ARGUMENTS AND VALUES:
 139
 140   MODEL: A valid model
 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
 145
 146 DESCRIPTION:
 147
 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
 150   clnl-random RNG.
 151
 152   INITIALIZE-INTERFACE, when non nil, leads to initialization code for the
 153   opengl interface being included.
 154
 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.
 158
 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.")
 161
 162 (defun model->multi-form-lisp (model boot-fn &key (seed 15) initialize-interface netlogo-callback-fn)
 163  (multiple-value-bind
 164   (code-ast prims)
 165   (clnl-code-parser:parse (clnl-lexer:lex (clnl-model:code model)) (clnl-model:widget-globals model))
 166   (let
 167    ((globals
 168      (append
 169       (clnl-model:widget-globals model)
 170       (clnl-code-parser:globals code-ast))))
 171    `((in-package ,(intern (package-name *model-package*) :keyword))
 172      ,@(mapcar
 173         (lambda (pair)
 174          `(defvar ,(intern (string-upcase (car pair)) *model-package*) ,(cadr pair)))
 175         globals)
 176      ,@(mapcar
 177         (lambda (proc)
 178          `(defun ,(intern (string-upcase (car proc)) *model-package*) ()
 179            ,@(cdr ; remove the progn, cuz it looks nicer
 180               (clnl-transpiler:transpile (cadr proc)
 181                (mapcar
 182                 (lambda (prim)
 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)
 186                   prim)) prims)))))
 187         (clnl-code-parser:procedures code-ast))
 188      (defun ,boot-fn ()
 189       (clnl-random:set-seed ,seed)
 190       (clnl-nvm:create-world
 191        :dims ',(clnl-model:world-dimensions model)
 192        :globals (list
 193                  ,@(mapcar
 194                     (lambda (pair) `(list ,(car pair) (lambda () ,(intern (string-upcase (car pair)) *model-package*))))
 195                     globals))
 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*))
 200            (eval
 201             (clnl-transpiler:transpile
 202              (clnl-parser:parse
 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)))))))))))
 206
 207 (setf (documentation 'model->multi-form-lisp 'function)
 208  "MODEL->MULTI-FORM-LISP MODEL BOOT-FN &key SEED INITIALIZE-INTERFACE NETLOGO-CALLBACK-FN => FORMS
 209
 210 ARGUMENTS AND VALUES:
 211
 212   MODEL: A valid model
 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
 218
 219 DESCRIPTION:
 220
 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.
 225
 226   The SEED passed in is used to start the clnl-random RNG.
 227
 228   INITIALIZE-INTERFACE, when non nil, leads to initialization code for the
 229   opengl interface being included.
 230
 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.")