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

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