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 ; Because prims are used both at generation time and later at runtime, certain things in
  87 ; them must be escaped a little bit more, such as wrapping the whole thing in a list
  88 ; primitive.  This way, the output of these things looks like halfway decent lisp,
  89 ; and everything works nicely.  We don't want any <FUNC #> showing up or anything
  90 (defun munge-prim (prim)
  91  (let
  92   ((copied (copy-list prim)))
  93   (when (getf copied :args) (setf (getf copied :args) `(quote ,(getf copied :args))))
  94   `(list ,@copied)))
  95
  96 (defun netlogo-callback-body (prims)
  97  `(eval
  98    (clnl-transpiler:transpile
  99     (clnl-parser:parse
 100      (clnl-lexer:lex ,(intern "NETLOGO-CODE" *model-package*))
 101      (list ,@(mapcar #'munge-prim prims)))
 102     (list ,@(mapcar #'munge-prim prims)))))
 103
 104 (defun create-world-call (model globals code-ast)
 105  `(clnl-nvm:create-world
 106    :dims ',(clnl-model:world-dimensions model)
 107    :globals (list
 108              ,@(mapcar
 109                 (lambda (pair)
 110                  `(list ,(car pair) (lambda () ,(intern (string-upcase (car pair)) *model-package*))))
 111                 globals))
 112    :turtles-own-vars ',(clnl-code-parser:turtles-own-vars code-ast)
 113    :patches-own-vars ',(clnl-code-parser:patches-own-vars code-ast)
 114    :breeds ',(clnl-code-parser:breeds code-ast)))
 115
 116 (defun create-proc-body (proc prims)
 117  `(,(intern (string-upcase (car proc)) *model-package*) ()
 118    (clnl-nvm:with-stop-handler
 119     ,@(cdr ; remove the progn, cuz it looks nicer
 120        (clnl-transpiler:transpile (cadr proc)
 121         (mapcar
 122          (lambda (prim)
 123           (if (getf prim :macro) ; The reason we do this is because with macros, we want to evaluate them in
 124                                  ; this scope while preserving them for the generational purposes below
 125            (append (list :macro (eval (getf prim :macro))) prim)
 126            prim)) prims))))))
 127
 128 (defun model->single-form-lisp (model &key (seed 15) initialize-interface netlogo-callback)
 129  (multiple-value-bind
 130   (code-ast prims)
 131   (clnl-code-parser:parse (clnl-lexer:lex (clnl-model:code model)) (clnl-model:widget-globals model))
 132   (let
 133    ((globals
 134      (append
 135       (clnl-model:widget-globals model)
 136       (clnl-code-parser:globals code-ast))))
 137    `(prog ()
 138      ; First declare is in case we don't use it, it shows up in export correctly
 139      ,@(when (and (> (length globals) 0) netlogo-callback)
 140         `((declare (special ,@(mapcar (lambda (pair) (intern (string-upcase (car pair)) *model-package*)) globals)))))
 141      (let
 142       ,(mapcar (lambda (pair) (list (intern (string-upcase (car pair)) *model-package*) (cadr pair))) globals)
 143       ; We declare twice rather than once and doing a bunch of setfs
 144       ,@(when (and (> (length globals) 0) netlogo-callback)
 145          `((declare (special ,@(mapcar (lambda (pair) (intern (string-upcase (car pair)) *model-package*)) globals)))))
 146       (labels
 147        ,(mapcar
 148          (lambda (proc) (create-proc-body proc prims))
 149          (clnl-code-parser:procedures code-ast))
 150        (clnl-random:set-seed ,seed)
 151        ,(create-world-call model globals code-ast)
 152        ,@(when netlogo-callback
 153           `((funcall ,netlogo-callback
 154              (lambda (,(intern "NETLOGO-CODE" *model-package*))
 155               ,(netlogo-callback-body prims)))))
 156        ,@(when initialize-interface `((clnl-interface:initialize :dims ',(clnl-model:world-dimensions model))))))))))
 157
 158 (setf (documentation 'model->single-form-lisp 'function)
 159  "MODEL->SINGLE-FORM-LISP MODEL &key SEED INITIALIZE-INTERFACE NETLOGO-CALLBACK => FORM
 160
 161 ARGUMENTS AND VALUES:
 162
 163   MODEL: A valid model
 164   SEED: An integer, defaults to 15
 165   INITIALIZE-INTERFACE: A boolean
 166   NETLOGO-CALLBACK: A function of one argument, or a symbol
 167   FORM: A common lisp form
 168
 169 DESCRIPTION:
 170
 171   MODEL->SINGLE-FORM-LISP takes a model and returns a lisp program as a single form,
 172   that when executed runs the model.  The SEED passed in is used to start the
 173   clnl-random RNG.
 174
 175   INITIALIZE-INTERFACE, when non nil, leads to initialization code for the
 176   opengl interface being included.
 177
 178   NETLOGO-CALLBACK is a function that when called with a single argument,
 179   a function that when called with netlogo code, will compile and run that
 180   code in the environment of the model.
 181
 182   Of note, all globals defined either in the model code or via the widgets
 183   are declared special in order to remain in the lexical environment for EVAL.")
 184
 185 (defun model->multi-form-lisp (model boot-fn &key (seed 15) initialize-interface netlogo-callback-fn)
 186  (multiple-value-bind
 187   (code-ast prims)
 188   (clnl-code-parser:parse (clnl-lexer:lex (clnl-model:code model)) (clnl-model:widget-globals model))
 189   (let
 190    ((globals
 191      (append
 192       (clnl-model:widget-globals model)
 193       (clnl-code-parser:globals code-ast))))
 194    `((in-package ,(intern (package-name *model-package*) :keyword))
 195      ,@(mapcar
 196         (lambda (pair)
 197          `(defvar ,(intern (string-upcase (car pair)) *model-package*) ,(cadr pair)))
 198         globals)
 199      ,@(mapcar
 200         (lambda (proc) `(defun ,@(create-proc-body proc prims)))
 201         (clnl-code-parser:procedures code-ast))
 202      (defun ,boot-fn ()
 203       (clnl-random:set-seed ,seed)
 204       ,(create-world-call model globals code-ast)
 205       ,@(when initialize-interface `((clnl-interface:initialize :dims ',(clnl-model:world-dimensions model)))))
 206      ,@(when netlogo-callback-fn
 207         `((defun ,netlogo-callback-fn (,(intern "NETLOGO-CODE" *model-package*))
 208            ,(netlogo-callback-body prims))))))))
 209
 210 (setf (documentation 'model->multi-form-lisp 'function)
 211  "MODEL->MULTI-FORM-LISP MODEL BOOT-FN &key SEED INITIALIZE-INTERFACE NETLOGO-CALLBACK-FN => FORMS
 212
 213 ARGUMENTS AND VALUES:
 214
 215   MODEL: A valid model
 216   BOOT-FN: A function name
 217   SEED: An integer, defaults to 15
 218   INITIALIZE-INTERFACE: A boolean
 219   NETLOGO-CALLBACK-FN: a symbol
 220   FORMS: A list of common lisp form
 221
 222 DESCRIPTION:
 223
 224   MODEL->MULTI-FORM-LISP takes a model and returns a multi form lisp program,
 225   that when executed, sets up the model.  Procedures map to defuns, globals
 226   to defvars, etc.  This can be output to load up quickly later.  A function
 227   named by BOOT-FN will be set for booting the program.
 228
 229   The SEED passed in is used to start the clnl-random RNG.
 230
 231   INITIALIZE-INTERFACE, when non nil, leads to initialization code for the
 232   opengl interface being included.
 233
 234   NETLOGO-CALLBACK-FN is a symbol that will be defined as a function
 235   to be called to execute code in the running netlogo instance.")