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