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    `(let
  96      ,(mapcar (lambda (pair) (list (intern (string-upcase (car pair)) *model-package*) (cadr pair))) globals)
  97      (declare (special ,@(mapcar (lambda (pair) (intern (string-upcase (car pair)) *model-package*)) globals)))
  98      (clnl-random:set-seed ,seed)
  99      (clnl-nvm:create-world
 100       :dims ',(clnl-model:world-dimensions model)
 101       :globals (list
 102                 ,@(mapcar
 103                    (lambda (pair) `(list ,(car pair) (lambda () ,(intern (string-upcase (car pair)) *model-package*))))
 104                    globals)))
 105      ,@(when netlogo-callback
 106         `((funcall ,netlogo-callback
 107            (lambda (netlogo-code)
 108             (eval
 109              (clnl-transpiler:transpile
 110               (clnl-parser:parse
 111                (clnl-lexer:lex netlogo-code)
 112                (list ,@(mapcar (lambda (prim) `(list ,@prim)) prims)))
 113               (list ,@(mapcar (lambda (prim) `(list ,@prim)) prims))))))))
 114      ,@(when initialize-interface `((clnl-interface:initialize :dims ',(clnl-model:world-dimensions model))))))))
 115
 116 (setf (documentation 'model->single-form-lisp 'function)
 117  "MODEL->SINGLE-FORM-LISP MODEL &key SEED INITIALIZE-INTERFACE NETLOGO-CALLBACK => FORM
 118
 119 ARGUMENTS AND VALUES:
 120
 121   MODEL: A valid model
 122   SEED: An integer, defaults to 15
 123   INITIALIZE-INTERFACE: A boolean
 124   NETLOGO-CALLBACK: A function of one argument, or a symbol
 125   FORM: A common lisp form
 126
 127 DESCRIPTION:
 128
 129   MODEL->SINGLE-FORM-LISP takes a model and returns a lisp program as a single form,
 130   that when executed runs the model.  The SEED passed in is used to start the
 131   clnl-random RNG.
 132
 133   INITIALIZE-INTERFACE, when non nil, leads to initialization code for the
 134   opengl interface being included.
 135
 136   NETLOGO-CALLBACK is a function that when called with a single argument,
 137   a function that when called with netlogo code, will compile and run that
 138   code in the environment of the model.
 139
 140   Of note, all globals defined either in the model code or via the widgets
 141   are declared special in order to remain in the lexical environment for EVAL.")
 142
 143 (defun model->multi-form-lisp (model boot-fn &key (seed 15) initialize-interface netlogo-callback-fn)
 144  (multiple-value-bind
 145   (code-ast prims)
 146   (clnl-code-parser:parse (clnl-lexer:lex (clnl-model:code model)) (clnl-model:widget-globals model))
 147   (let
 148    ((globals
 149      (append
 150       (clnl-model:widget-globals model)
 151       (clnl-code-parser:globals code-ast))))
 152    `((in-package ,(intern (package-name *model-package*) :keyword))
 153      ,@(mapcar
 154         (lambda (pair)
 155          `(defvar ,(intern (string-upcase (car pair)) *model-package*) ,(cadr pair)))
 156         globals)
 157      (defun ,boot-fn ()
 158       (clnl-random:set-seed ,seed)
 159       (clnl-nvm:create-world
 160        :dims ',(clnl-model:world-dimensions model)
 161        :globals (list
 162                  ,@(mapcar
 163                     (lambda (pair) `(list ,(car pair) (lambda () ,(intern (string-upcase (car pair)) *model-package*))))
 164                     globals)))
 165       ,@(when initialize-interface `((clnl-interface:initialize :dims ',(clnl-model:world-dimensions model)))))
 166      ,@(when netlogo-callback-fn
 167         `((defun ,netlogo-callback-fn (,(intern "NETLOGO-CODE" *model-package*))
 168            (eval
 169             (clnl-transpiler:transpile
 170              (clnl-parser:parse
 171               (clnl-lexer:lex ,(intern "NETLOGO-CODE" *model-package*))
 172               (list ,@(mapcar (lambda (prim) `(list ,@prim)) prims)))
 173              (list ,@(mapcar (lambda (prim) `(list ,@prim)) prims)))))))))))
 174
 175 (setf (documentation 'model->multi-form-lisp 'function)
 176  "MODEL->MULTI-FORM-LISP MODEL BOOT-FN &key SEED INITIALIZE-INTERFACE NETLOGO-CALLBACK-FN => FORMS
 177
 178 ARGUMENTS AND VALUES:
 179
 180   MODEL: A valid model
 181   BOOT-FN: A function name
 182   SEED: An integer, defaults to 15
 183   INITIALIZE-INTERFACE: A boolean
 184   NETLOGO-CALLBACK-FN: a symbol
 185   FORMS: A list of common lisp form
 186
 187 DESCRIPTION:
 188
 189   MODEL->MULTI-FORM-LISP takes a model and returns a multi form lisp program,
 190   that when executed, sets up the model.  Procedures map to defuns, globals
 191   to defvars, etc.  This can be output to load up quickly later.  A function
 192   named by BOOT-FN will be set for booting the program.
 193
 194   The SEED passed in is used to start the clnl-random RNG.
 195
 196   INITIALIZE-INTERFACE, when non nil, leads to initialization code for the
 197   opengl interface being included.
 198
 199   NETLOGO-CALLBACK-FN is a symbol that will be defined as a function
 200   to be called to execute code in the running netlogo instance.")