From: Frank Duncan <frank@kank.net>
Date: Thu, 10 Aug 2017 10:07:09 +0000 (-0500)
Subject: UI/Model Parse - Switches
X-Git-Tag: 0.1.1~5
X-Git-Url: https://code.consxy.com/gitweb/gitweb.cgi?a=commitdiff_plain;h=5f87a9fd0bed8832115f11073e5ee9a968ee95c0;p=clnl

UI/Model Parse - Switches
---

diff --git a/resources/UI-test.nlogo b/resources/UI-test.nlogo
index 5b08fe0..b7eed22 100644
--- a/resources/UI-test.nlogo
+++ b/resources/UI-test.nlogo
@@ -41,7 +41,7 @@ BUTTON
 102
 61
 setup
-crt 10
+crt 10 [ if new-turtles-green [ set color green ] ]
 NIL
 1
 T
@@ -120,6 +120,17 @@ NIL
 NIL
 1
 
+SWITCH
+13
+127
+198
+160
+new-turtles-green
+new-turtles-green
+1
+1
+-1000
+
 @#$#@#$#@
 ## WHAT IS IT?
 
diff --git a/src/main/interface.lisp b/src/main/interface.lisp
index b9e8e68..6d2ae37 100644
--- a/src/main/interface.lisp
+++ b/src/main/interface.lisp
@@ -13,6 +13,8 @@
 (defvar *textbox* nil)
 (defvar *inputbox* nil)
 
+(defvar *current-globals* nil)
+
 (defvar *widgets* nil) ; this is going to be pairs to save the original definition
 
 ; This is the thread that does the work of querying the currently running system to update
@@ -28,6 +30,11 @@
  (when (getf button-def :forever)
   (clnl-gltk:toggle button (clnl-model:forever-button-on (getf button-def :display) idx))))
 
+(defmethod update-widget ((type (eql :switch)) switch-def switch nothing)
+ (let
+  ((global (find (getf switch-def :var) *current-globals* :key (lambda (def) (getf def :name)))))
+  (clnl-gltk:toggle switch (getf global :value))))
+
 (defun update-interface ()
  (mapcar
   (lambda (widget) (apply #'update-widget widget))
@@ -256,7 +263,8 @@
   (gl:matrix-mode :modelview)
   (gl:with-pushed-matrix
    (gl:load-identity)
-   (destructuring-bind (turtles patches) (clnl-nvm:current-state)
+   (destructuring-bind (turtles patches globals) (clnl-nvm:current-state)
+    (setf *current-globals* globals)
     (mapcar
      (lambda (patch)
       (let
@@ -473,13 +481,30 @@ keep apprised of any updates that may happen.")
      (list :button button-def button idx)))
    button-defs)))
 
-(defun initialize (&key dims view buttons)
- "INITIALIZE &key DIMS VIEW BUTTONS => RESULT
+(defun switch-defs->switches (switch-defs)
+ (mapcar
+  (lambda (switch-def)
+   (let*
+    ((switch
+      (clnl-gltk:switch
+       (getf switch-def :left)
+       (- *window-height* clnl-gltk:*switch-height* (getf switch-def :top))
+       (getf switch-def :width)
+       (getf switch-def :display)
+       (lambda (state) (execute (format nil "set ~A ~A" (getf switch-def :display) (if state "true" "false"))))
+       (getf switch-def :initial-value))))
+    (list :switch (append switch-def (list :height clnl-gltk:*switch-height*)) switch nil)))
+  switch-defs))
+
+(defun initialize (&key dims view buttons switches)
+ "INITIALIZE &key DIMS VIEW BUTTONS SWITCHES => RESULT
 
   DIMS: (:xmin XMIN :xmax XMAX :ymin YMIN :ymax YMAX :patch-size PATCH-SIZE)
   VIEW: (:left LEFT :top TOP)
   BUTTONS: BUTTON-DEF*
+  SWITCHES: SWITCH-DEF*
   BUTTON-DEF: (:left LEFT :top TOP :height HEIGHT :width WIDTH :forever FOREVER :display DISPLAY)
+  SWITCH-DEF: (:left LEFT :top TOP :width WIDTH :var VAR :display DISPLAY :initial-value INITIAL-VALUE)
 
 ARGUMENTS AND VALUES:
 
@@ -489,12 +514,14 @@ ARGUMENTS AND VALUES:
   YMIN: An integer representing the minimum patch coord in Y
   YMAX: An integer representing the maximum patch coord in Y
   PATCH-SIZE: A double representing the size of the patches in pixels
+  HEIGHT: An integer representing height
+  FOREVER: A boolean representing the forever status
   LEFT: An integer representing the left position
   TOP: An integer representing the top position
-  HEIGHT: An integer representing height
   WIDTH: An integer representing width
-  FOREVER: A boolean representing the forever status
+  VAR: A string representing the variable name
   DISPLAY: A string representing display name
+  INITIAL-VALUE: The initial value
 
 DESCRIPTION:
 
@@ -505,7 +532,9 @@ DESCRIPTION:
  (boot-interface-thread)
  (setf *dimensions* (append dims view))
  (setf *widgets*
-  (button-defs->buttons buttons)))
+  (append
+   (button-defs->buttons buttons)
+   (switch-defs->switches switches))))
 
 (defun run ()
  "RUN => RESULT
diff --git a/src/main/main.lisp b/src/main/main.lisp
index d1ffdad..4b845cf 100644
--- a/src/main/main.lisp
+++ b/src/main/main.lisp
@@ -223,7 +223,8 @@ EXAMPLES:
          `((clnl-interface:initialize
             :dims ',(clnl-model:world-dimensions model)
             :view ',(clnl-model:view model)
-            :buttons ',(clnl-model:buttons model)))))))))
+            :buttons ',(clnl-model:buttons 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
@@ -278,7 +279,8 @@ DESCRIPTION:
          `((clnl-interface:initialize
             :dims ',(clnl-model:world-dimensions model)
             :view ',(clnl-model:view model)
-            :buttons ',(clnl-model:buttons model)))))
+            :buttons ',(clnl-model:buttons model)
+            :switches ',(clnl-model:switches model)))))
      ,@(when netlogo-callback-fn
         `((defun ,netlogo-callback-fn (,(intern "NETLOGO-CODE" *model-package*))
            ,(netlogo-callback-body prims))))))))
diff --git a/src/main/model.lisp b/src/main/model.lisp
index 0ab8c10..c947987 100644
--- a/src/main/model.lisp
+++ b/src/main/model.lisp
@@ -425,6 +425,40 @@ DESCRIPTION:
        :display (button-display-name widget)))))
    (model-interface model))))
 
+(defun switches (model)
+ "SWITCHES MODEL => SWITCH-DEFS
+
+  SWITCH-DEFS: SWITCH-DEF*
+  SWITCH-DEF: (:left LEFT :top TOP :width WIDTH :var VAR :display DISPLAY :initial-value INITIAL-VALUE)
+
+ARGUMENTS AND VALUES:
+
+  MODEL: A valid model
+  LEFT: An integer representing the left position
+  TOP: An integer representing the top position
+  WIDTH: An integer representing width
+  VAR: A symbole representing variable
+  DISPLAY: A string representing variable name
+  INITIAL-VALUE: The initial value
+
+DESCRIPTION:
+
+  Returns switch definitions that get declared in the switches of the
+  MODEL.  This is used to initialize the interface."
+ (remove nil
+  (mapcar
+   (lambda (widget)
+    (typecase widget
+     (switch
+      (list
+       :left (switch-left widget)
+       :top (switch-top widget)
+       :width (- (switch-right widget) (switch-left widget))
+       :var (intern (string-upcase (switch-varname widget)) :keyword)
+       :display (switch-varname widget)
+       :initial-value (switch-on widget) ))))
+   (model-interface model))))
+
 (defun view (model)
  "VIEW MODEL => VIEW-DEF
 
diff --git a/src/main/nvm/nvm.lisp b/src/main/nvm/nvm.lisp
index e3f582d..96d5789 100644
--- a/src/main/nvm/nvm.lisp
+++ b/src/main/nvm/nvm.lisp
@@ -153,7 +153,13 @@ DESCRIPTION:
      :color (patch-color patch)
      :xcor (patch-xcor patch)
      :ycor (patch-ycor patch)))
-   *patches*)))
+   *patches*)
+  (mapcar
+   (lambda (global)
+    (list
+     :name (car global)
+     :value (funcall (cadr global))))
+   *globals*)))
 
 ; These match netlogo's dump
 (defgeneric dump-object (o))
diff --git a/src/main/package.lisp b/src/main/package.lisp
index 9f35592..c21d38e 100644
--- a/src/main/package.lisp
+++ b/src/main/package.lisp
@@ -87,7 +87,7 @@ components."))
  (:use :common-lisp)
  (:export
   #:execute-button #:default-model #:read-from-nlogo #:world-dimensions #:widget-globals #:code
-  #:buttons #:forever-button-on #:view #:interface #:set-current-interface #:set-callback)
+  #:buttons #:forever-button-on #:switches #:view #:interface #:set-current-interface #:set-callback)
  (:documentation
   "CLNL Model
 
diff --git a/src/main/parse.lisp b/src/main/parse.lisp
index 4a0ddeb..4f331ca 100644
--- a/src/main/parse.lisp
+++ b/src/main/parse.lisp
@@ -379,6 +379,10 @@ DESCRIPTION:
 (defprim :green () 10)
 (defprim :white () 10)
 
+; booleans
+(defprim :true () 10)
+(defprim :false () 10)
+
 (defstructureprim :globals)
 (defstructureprim :breed)
 (defstructureprim :turtles-own)
diff --git a/src/main/transpile.lisp b/src/main/transpile.lisp
index 4ab7559..b0f90fe 100644
--- a/src/main/transpile.lisp
+++ b/src/main/transpile.lisp
@@ -291,3 +291,7 @@ DESCRIPTION:
 (defcolorprim :brown)
 (defcolorprim :green)
 (defcolorprim :white)
+
+; Boleans
+(defprim :true :reporter (lambda () t))
+(defprim :false :reporter (lambda () nil))
diff --git a/src/test/modeltests.lisp b/src/test/modeltests.lisp
index d80f871..9f1c4b0 100644
--- a/src/test/modeltests.lisp
+++ b/src/test/modeltests.lisp
@@ -125,23 +125,24 @@ end"
 
 (defmodelfiletest "UI 0" "resources/UI-test.nlogo"
  "go"
- "793CA6F4AB144780D5139BC01B47BBFCE898576F")
+ "A0B7B1A12349BA4587A09099B119D96924C924A2")
 
 (defmodelfiletest "UI 1" "resources/UI-test.nlogo"
- (":button \"setup\"" "crt 10")
- "1825131B956968564A55F703E1031EB4A72DE35F")
+ (":button \"setup\"" "crt 10 [ if new-turtles-green [ set color green ] ]")
+ "970F510CDECEA8433FDEA3D2F6E90AA70335B06A")
 
 (defmodelfiletest "UI 2" "resources/UI-test.nlogo"
- (":button \"setup\" :button \"go\"" "crt 10 go")
- "686956AD49E1924F6429502FDF1B9C92DAE5E5F8")
+ (":button \"setup\" :button \"go\"" "crt 10 [ if new-turtles-green [ set color green ] ] go")
+ "0270BE659387CBB71AB73D23100F41238430D10F")
 
 (defmodelfiletest "UI 3" "resources/UI-test.nlogo"
- (":button \"setup\" :button \"go\" 1" "crt 10 go ask turtles [ rt 90 ] go")
- "4E0128F172B4D0085186E49FDBD7014F6E365ED7")
+ (":button \"setup\" :button \"go\" 1"
+  "crt 10 [ if new-turtles-green [ set color green ] ] go ask turtles [ rt 90 ] go")
+ "35CB38ED652CAEA88FC84D952386A10620BB9CE5")
 
 (defmodelfiletest "UI 4" "resources/UI-test.nlogo"
  (":button \"stopping\"" "repeat 80 [ create-and-move ]")
- "749DC971517EDE9020BF125D0F362A978980272F"
+ "C4A9DD22E8FC16BA503C9F8EDD92962E8D707165"
  t)
 
 (defmodelfiletest "Wolf Sheep 1" "resources/models/Wolf Sheep Predation.nlogo"