X-Git-Url: https://code.consxy.com/gitweb/gitweb.cgi?p=clnl;a=blobdiff_plain;f=src%2Fmain%2Fmain.lisp;h=920e4e8445d69143a036710ead791d7e1233d335;hp=a226642c8e702b63cbabb49321e7108aed1cd6af;hb=89cb3482de1fefc2d8e5f67e1e04a0790e8cd243;hpb=6fc4a1700ede4beee1d2a547d75be6b40488a1f5

diff --git a/src/main/main.lisp b/src/main/main.lisp
index a226642..920e4e8 100644
--- a/src/main/main.lisp
+++ b/src/main/main.lisp
@@ -14,18 +14,18 @@
 
 (defun p (result) result)
 
-(defun run ()
- "RUN => RESULT
+(defun run (&optional file)
+ "RUN &optional FILE => RESULT
 
 ARGUMENTS AND VALUES:
 
+  FILE: nlogo file with which to initialize
   RESULT: undefined, the system terminates at the end of the loop
 
 DESCRIPTION:
 
   RUN starts up the CLNL system."
- (boot)
- (sb-thread:make-thread #'clnl-cli:run)
+ (boot file)
  (clnl-interface:run))
 
 (defvar *callback* nil)
@@ -57,6 +57,8 @@ DESCRIPTION:
    (*package* *model-package*))
   (eval netlogoed-lisp)))
 
+(defvar *commands-mutex* (sb-thread:make-mutex))
+
 (defun run-commands (cmds)
  "RUN-COMMANDS CMDS => RESULT
 
@@ -69,8 +71,11 @@ DESCRIPTION:
 
   RUN-COMMANDS will take NetLogo commands, put them through the various
   stages need to turn them into Common Lisp code, and run it."
- (clnl-nvm:with-stop-handler
-  (funcall *callback* cmds)))
+
+ ; This mutex is a necessary because we haven't yet moved to a job thread
+ (sb-thread:with-mutex (*commands-mutex*)
+  (clnl-nvm:with-stop-handler
+   (funcall *callback* cmds))))
 
 (defun run-reporter (reporter)
  "RUN-REPORTER REPORTER => RESULT
@@ -129,6 +134,64 @@ DESCRIPTION:
            prim)) prims)))
     :undefined)))
 
+(defun nlogo->lisp (str pkg-symb boot-fn &key (seed 15) initialize-interface netlogo-callback-fn)
+ (let*
+  ((model (clnl-model:read-from-nlogo str))
+   (shadow-symbs
+    (remove nil
+     (mapcar
+      (lambda (proc-symb)
+       (multiple-value-bind (found external) (find-symbol (symbol-name proc-symb) :cl)
+        (when (and found (eql :external external)) proc-symb)))
+      (mapcar #'car
+       (clnl-code-parser:procedures
+        (clnl-code-parser:parse
+         (clnl-lexer:lex (clnl-model:code model))
+         (clnl-model:widget-globals model))))))))
+  (eval
+   `(progn
+     (defpackage ,pkg-symb (:use :common-lisp) (:shadow ,@shadow-symbs))
+     (,(intern "IN-PACKAGE" :cl) ,pkg-symb) ; intern because of style check
+     (cons
+      `(defpackage ,,pkg-symb (:use :common-lisp) (:shadow ,,@shadow-symbs))
+      (let
+       ((clnl:*model-package* (find-package ,pkg-symb)))
+       (clnl:model->multi-form-lisp
+        ,model
+        (intern (symbol-name ',boot-fn) ,pkg-symb)
+        :seed ,seed
+        :initialize-interface ,initialize-interface
+        :netlogo-callback-fn ,netlogo-callback-fn)))))))
+
+(setf (documentation 'nlogo->lisp 'function)
+ "NLOGO->LISP STR PKG-SYMB BOOT-FN &key SEED INITIALIZE-INTERFACE NETLOGO-CALLBACK-FN => FORMS
+
+ARGUMENTS AND VALUES:
+
+  STR: A stream holding an nlogo file
+  PKG-SYMB: A symbol for the generated package
+  BOOT-FN: A function name
+  SEED: An integer, defaults to 15
+  INITIALIZE-INTERFACE: A boolean
+  NETLOGO-CALLBACK-FN: a symbol
+  FORMS: A list of common lisp form
+
+DESCRIPTION:
+
+  NLOGO->LISP takes a stream STR and returns a multi form lisp program,
+  that when executed, sets up the model.  See MODEL->MULTI-FORM-LISP for
+  more information.
+
+  NLOGO->LISP does extra work of setting up the package to be named by
+  PKG-SYMB in order to correctly shadow common lisp functions.
+
+  It will also change the current package to the one created for the model
+  named by PKG-SYMB.
+
+EXAMPLES:
+
+  (with-open-file (str \"Wolf Sheep Predation.nlogo\") (nlogo->lisp str :wolfsheep 'boot)) => (forms)")
+
 (defun model->single-form-lisp (model &key (seed 15) initialize-interface netlogo-callback)
  (multiple-value-bind
   (code-ast prims)
@@ -147,12 +210,23 @@ DESCRIPTION:
         (lambda (proc) (create-proc-body proc prims))
         (clnl-code-parser:procedures code-ast))
       (clnl-random:set-seed ,seed)
+      (clnl-model:set-current-interface ',(clnl-model:interface model))
+      ,@(when netlogo-callback
+         `((clnl-model:set-callback
+            (lambda (,(intern "NETLOGO-CODE" *model-package*)) ,(netlogo-callback-body prims)))))
       ,(create-world-call model globals code-ast)
       ,@(when netlogo-callback
          `((funcall ,netlogo-callback
             (lambda (,(intern "NETLOGO-CODE" *model-package*))
              ,(netlogo-callback-body prims)))))
-      ,@(when initialize-interface `((clnl-interface:initialize :dims ',(clnl-model:world-dimensions model)))))))))
+      ,@(when initialize-interface
+         `((clnl-interface:initialize
+            :dims ',(clnl-model:world-dimensions model)
+            :view ',(clnl-model:view model)
+            :buttons ',(clnl-model:buttons model)
+            :textboxes ',(clnl-model:textboxes model)
+            :sliders ',(clnl-model:sliders model)
+            :switches ',(clnl-model:switches model)))))))))
 
 (setf (documentation 'model->single-form-lisp 'function)
  "MODEL->SINGLE-FORM-LISP MODEL &key SEED INITIALIZE-INTERFACE NETLOGO-CALLBACK => FORM
@@ -200,8 +274,17 @@ DESCRIPTION:
         (clnl-code-parser:procedures code-ast))
      (defun ,boot-fn ()
       (clnl-random:set-seed ,seed)
+      (clnl-model:set-current-interface ',(clnl-model:interface model))
+      (clnl-model:set-callback (symbol-function ',netlogo-callback-fn))
       ,(create-world-call model globals code-ast)
-      ,@(when initialize-interface `((clnl-interface:initialize :dims ',(clnl-model:world-dimensions model)))))
+      ,@(when initialize-interface
+         `((clnl-interface:initialize
+            :dims ',(clnl-model:world-dimensions model)
+            :view ',(clnl-model:view model)
+            :buttons ',(clnl-model:buttons model)
+            :textboxes ',(clnl-model:textboxes model)
+            :sliders ',(clnl-model:sliders model)
+            :switches ',(clnl-model:switches model)))))
      ,@(when netlogo-callback-fn
         `((defun ,netlogo-callback-fn (,(intern "NETLOGO-CODE" *model-package*))
            ,(netlogo-callback-body prims))))))))