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