X-Git-Url: https://code.consxy.com/gitweb/gitweb.cgi?a=blobdiff_plain;f=src%2Fmain%2Fmodel.lisp;h=33f90aa588327b040c5b87a02b1f85efb21223b5;hb=18f00de;hp=3812ac24cedd5bb9da35ab3d5d9eb4aae118a09f;hpb=213ed30b45140af3f34b7e003aa60394178d524c;p=clnl

diff --git a/src/main/model.lisp b/src/main/model.lisp
index 3812ac2..33f90aa 100644
--- a/src/main/model.lisp
+++ b/src/main/model.lisp
@@ -54,7 +54,15 @@ DESCRIPTION:
           (read-sections (append section (list line))))))))
      (read-sections))))
   (make-model
-   :code (nth 0 sections)
+   :code (clnl-code-parser:parse
+          (clnl-lexer:lex (format nil "~{~A~^~%~}" (nth 0 sections)))
+          (remove nil
+           (mapcar
+            (lambda (widget)
+             (typecase widget
+              (slider (intern (string-upcase (slider-varname widget)) (find-package :keyword)))
+              (switch (intern (string-upcase (switch-varname widget)) (find-package :keyword)))))
+            (parse-interface (nth 1 sections)))))
    :interface (parse-interface (nth 1 sections))
    :info (nth 2 sections)
    :turtle-shapes (nth 3 sections)
@@ -78,7 +86,8 @@ DESCRIPTION:
     (defstruct ,type
      ,@(remove nil
         (mapcar
-         (lambda (def) (when (find (car def) (list :int :double :boolean :choice :string)) (second def)))
+         (lambda (def)
+          (when (find (car def) (list :int :double :inverted-boolean :boolean :choice :string :option)) (second def)))
          definitions)))
     (push
      (list
@@ -94,6 +103,7 @@ DESCRIPTION:
                (:int `(parse-integer ,line :junk-allowed t))
                (:double `(ignore-errors (coerce (read-from-string ,line) 'double-float)))
                (:boolean `(or (string= "1" ,line) (string= "0" ,line)))
+               (:inverted-boolean `(or (string= "0" ,line) (string= "1" ,line)))
                (:choice `(find ,line ',(mapcar #'car (third def)) :test #'string=)))))
             definitions
             (loop for i to (length definitions) collect i)))))
@@ -109,7 +119,9 @@ DESCRIPTION:
                  (:int `(parse-integer ,line))
                  (:double `(coerce (read-from-string ,line) 'double-float))
                  (:boolean `(string= "1" ,line))
+                 (:inverted-boolean `(string= "0" ,line))
                  (:choice `(cadr (find ,line ',(third def) :key #'car :test #'string=)))
+                 (:option `(when (string/= ,line ,(third def)) ,line))
                  (:string line))))
               (when val-getter (list (intern (symbol-name (cadr def)) :keyword) val-getter))))
             definitions
@@ -144,6 +156,34 @@ DESCRIPTION:
  (:string tick-counter-label)
  (:double frame-rate 30))
 
+(defwidget-definition slider
+ (:specified "SLIDER")
+ (:int left)
+ (:int top)
+ (:int right)
+ (:int bottom)
+ (:string display)
+ (:string varname)
+ (:string min)
+ (:string max)
+ (:double default)
+ (:string step)
+ (:reserved)
+ (:option units "NIL")
+ (:choice direction (("HORIZONTAL" :horizontal) ("VERTICAL" :vertical))))
+
+(defwidget-definition switch
+ (:specified "SWITCH")
+ (:int left)
+ (:int top)
+ (:int right)
+ (:int bottom)
+ (:string display)
+ (:string varname)
+ (:inverted-boolean on)
+ (:reserved)
+ (:reserved))
+
 (defun parse-interface (interface-as-strings)
  (let
   ((widgets-as-strings
@@ -189,3 +229,34 @@ DESCRIPTION:
    :xmax (view-max-pxcor view)
    :ymin (view-min-pycor view)
    :ymax (view-max-pycor view))))
+
+; For now, we keep the code hidden in this package
+(defun globals (model)
+ "GLOBALS MODEL => GLOBALS
+
+  GLOBALS: GLOBAL*
+
+ARGUMENTS AND VALUES:
+
+  MODEL: A valid model
+  GLOBAL: A symbol interned in clnl:*model-package*
+
+DESCRIPTION:
+
+  Returns the globals that get declared in the model, from widgets or
+  from code.  They are interned in the package set for clnl, so
+  that they can later be used by functions in that package."
+ (mapcar
+  (lambda (pair)
+   (list
+    (intern (string-upcase (car pair)) clnl:*model-package*)
+    (cadr pair)))
+  (append
+   (clnl-code-parser:globals (model-code model))
+   (remove nil
+    (mapcar
+     (lambda (widget)
+      (typecase widget
+       (slider (list (slider-varname widget) (slider-default widget)))
+       (switch (list (switch-varname widget) (switch-on widget)))))
+     (model-interface model))))))