Interface - add resize capabilities

[clnl] / src / main / main.lisp

diff --git a/src/main/main.lisp b/src/main/main.lisp
index 35a5961d399ec88c0753bccc207756201d0c2313..5bb93610de52d79184902ca9325800131c1ac319 100644 (file)
--- a/src/main/main.lisp
+++ b/src/main/main.lisp
@@ -24,11 +24,12 @@ ARGUMENTS AND VALUES:
 DESCRIPTION:
 
   RUN starts up the CLNL system."
-
  (boot)
  (sb-thread:make-thread #'clnl-cli:run)
  (clnl-interface:run))
 
+(defvar *callback* nil)
+
 (defun boot (&optional file headless-mode)
  "BOOT &optional FILE HEADLESS-MODE => RESULT
 
@@ -51,7 +52,8 @@ DESCRIPTION:
   ((netlogoed-lisp
     (model->single-form-lisp
      (if file (with-open-file (str file) (clnl-model:read-from-nlogo str)) (clnl-model:default-model))
-     :initialize-interface (not headless-mode)))
+     :initialize-interface (not headless-mode)
+     :netlogo-callback (lambda (f) (setf *callback* f))))
    (*package* *model-package*))
   (eval netlogoed-lisp)))
 
@@ -67,7 +69,8 @@ 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 (eval (clnl-transpiler:transpile (clnl-parser:parse (clnl-lexer:lex cmds))))))
+ (clnl-nvm:with-stop-handler
+  (funcall *callback* cmds)))
 
 (defun run-reporter (reporter)
  "RUN-REPORTER REPORTER => RESULT
@@ -115,14 +118,15 @@ DESCRIPTION:
 
 (defun create-proc-body (proc prims)
  `(,(intern (string-upcase (car proc)) *model-package*) ()
-   ,@(cdr ; remove the progn, cuz it looks nicer
-      (clnl-transpiler:transpile (cadr proc)
-       (mapcar
-        (lambda (prim)
-         (if (getf prim :macro) ; The reason we do this is because with macros, we want to evaluate them in
-                                ; this scope while preserving them for the generational purposes below
-          (append (list :macro (eval (getf prim :macro))) prim)
-          prim)) prims)))))
+   (clnl-nvm:with-stop-handler
+    ,@(cdr ; remove the progn, cuz it looks nicer
+       (clnl-transpiler:transpile (cadr proc)
+        (mapcar
+         (lambda (prim)
+          (if (getf prim :macro) ; The reason we do this is because with macros, we want to evaluate them in
+                                 ; this scope while preserving them for the generational purposes below
+           (append (list :macro (eval (getf prim :macro))) prim)
+           prim)) prims))))))
 
 (defun model->single-form-lisp (model &key (seed 15) initialize-interface netlogo-callback)
  (multiple-value-bind
@@ -131,28 +135,23 @@ DESCRIPTION:
   (let
    ((globals
      (append
-      (clnl-model:widget-globals model)
-      (clnl-code-parser:globals code-ast))))
-   `(prog ()
-     ; First declare is in case we don't use it, it shows up in export correctly
-     ,@(when (and (> (length globals) 0) netlogo-callback)
-        `((declare (special ,@(mapcar (lambda (pair) (intern (string-upcase (car pair)) *model-package*)) globals)))))
-     (let
-      ,(mapcar (lambda (pair) (list (intern (string-upcase (car pair)) *model-package*) (cadr pair))) globals)
-      ; We declare twice rather than once and doing a bunch of setfs
-      ,@(when (and (> (length globals) 0) netlogo-callback)
-         `((declare (special ,@(mapcar (lambda (pair) (intern (string-upcase (car pair)) *model-package*)) globals)))))
-      (labels
-       ,(mapcar
-         (lambda (proc) (create-proc-body proc prims))
-         (clnl-code-parser:procedures code-ast))
-       (clnl-random:set-seed ,seed)
-       ,(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))))))))))
+      (clnl-code-parser:globals code-ast)
+      (clnl-model:widget-globals model))))
+   `(progn
+     ,@(mapcar
+        (lambda (pair) `(defparameter ,(intern (string-upcase (car pair)) *model-package*) ,(cadr pair)))
+        globals)
+     (labels
+      ,(mapcar
+        (lambda (proc) (create-proc-body proc prims))
+        (clnl-code-parser:procedures code-ast))
+      (clnl-random:set-seed ,seed)
+      ,(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)))))))))
 
 (setf (documentation 'model->single-form-lisp 'function)
  "MODEL->SINGLE-FORM-LISP MODEL &key SEED INITIALIZE-INTERFACE NETLOGO-CALLBACK => FORM