From: Frank Duncan <frank@kank.net>
Date: Wed, 29 Aug 2018 16:42:58 +0000 (-0500)
Subject: UI/Model Parse - Sliders - WIP
X-Git-Tag: 0.1.1~3
X-Git-Url: https://code.consxy.com/gitweb/gitweb.cgi?p=clnl;a=commitdiff_plain;h=89cb3482de1fefc2d8e5f67e1e04a0790e8cd243

UI/Model Parse - Sliders - WIP
---

diff --git a/resources/UI-test.nlogo b/resources/UI-test.nlogo
index 1ff8bf1..9427f3e 100644
--- a/resources/UI-test.nlogo
+++ b/resources/UI-test.nlogo
@@ -104,10 +104,10 @@ NIL
 1
 
 BUTTON
-66
-276
-161
-309
+111
+443
+206
+476
 stopping
 create-and-move
 T
@@ -132,10 +132,10 @@ new-turtles-green
 -1000
 
 TEXTBOX
-45
-335
-147
-367
+9
+442
+111
+474
 Textbox 1
 12
 0.0
@@ -161,6 +161,66 @@ this\nis a test and it goes like\nthis
 0.0
 1
 
+SLIDER
+15
+233
+187
+266
+basic-slider
+basic-slider
+0
+100
+50
+5
+1
+NIL
+HORIZONTAL
+
+SLIDER
+294
+501
+564
+534
+code-slider
+code-slider
+0
+count turtles
+65
+1
+1
+NIL
+HORIZONTAL
+
+SLIDER
+16
+275
+115
+308
+inverted-inc-slider
+inverted-inc-slider
+10
+30
+21
+-1
+1
+NIL
+HORIZONTAL
+
+SLIDER
+12
+322
+204
+355
+reversed-min-max-slider
+reversed-min-max-slider
+100
+0
+20
+5
+1
+NIL
+HORIZONTAL
+
 @#$#@#$#@
 ## WHAT IS IT?
 
diff --git a/src/main/interface.lisp b/src/main/interface.lisp
index 6b2d85e..e5bcc38 100644
--- a/src/main/interface.lisp
+++ b/src/main/interface.lisp
@@ -496,6 +496,24 @@ keep apprised of any updates that may happen.")
     (list :switch (append switch-def (list :height clnl-gltk:*switch-height*)) switch nil)))
   switch-defs))
 
+(defun slider-defs->sliders (slider-defs)
+ (mapcar
+  (lambda (slider-def)
+   (let*
+    ((slider
+      (clnl-gltk:slider
+       (getf slider-def :left)
+       (- *window-height* clnl-gltk:*slider-height* (getf slider-def :top))
+       (getf slider-def :width)
+       (getf slider-def :display)
+       (lambda (state) (execute (format nil "set ~A ~A" (getf slider-def :display) state)))
+       (read-from-string (getf slider-def :min))
+       (read-from-string (getf slider-def :max))
+       (read-from-string (getf slider-def :step))
+       (getf slider-def :initial-value))))
+    (list :slider (append slider-def (list :height clnl-gltk:*slider-height*)) slider nil)))
+  slider-defs))
+
 (defun textbox-defs->textboxes (textbox-defs)
  (mapcar
   (lambda (textbox-def)
@@ -524,7 +542,7 @@ keep apprised of any updates that may happen.")
      textbox nil)))
   textbox-defs))
 
-(defun initialize (&key dims view buttons switches textboxes)
+(defun initialize (&key dims view buttons switches sliders textboxes)
  "INITIALIZE &key DIMS VIEW BUTTONS SWITCHES => RESULT
 
   DIMS: (:xmin XMIN :xmax XMAX :ymin YMIN :ymax YMAX :patch-size PATCH-SIZE)
@@ -563,7 +581,8 @@ DESCRIPTION:
   (append
    (button-defs->buttons buttons)
    (textbox-defs->textboxes textboxes)
-   (switch-defs->switches switches))))
+   (switch-defs->switches switches)
+   (slider-defs->sliders sliders))))
 
 (defun run ()
  "RUN => RESULT
diff --git a/src/main/main.lisp b/src/main/main.lisp
index 3e1d981..920e4e8 100644
--- a/src/main/main.lisp
+++ b/src/main/main.lisp
@@ -225,6 +225,7 @@ EXAMPLES:
             :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)
@@ -282,6 +283,7 @@ DESCRIPTION:
             :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*))
diff --git a/src/main/model.lisp b/src/main/model.lisp
index 8adc472..3942110 100644
--- a/src/main/model.lisp
+++ b/src/main/model.lisp
@@ -502,6 +502,24 @@ DESCRIPTION:
        :initial-value (switch-on widget) ))))
    (model-interface model))))
 
+(defun sliders (model)
+ (remove nil
+  (mapcar
+   (lambda (widget)
+    (typecase widget
+     (slider
+      (list
+       :left (slider-left widget)
+       :top (slider-top widget)
+       :width (- (slider-right widget) (slider-left widget))
+       :var (intern (string-upcase (slider-varname widget)) :keyword)
+       :display (slider-varname widget)
+       :min (slider-min widget)
+       :max (slider-max widget)
+       :step (slider-step widget)
+       :initial-value (slider-default widget)))))
+   (model-interface model))))
+
 (defun view (model)
  "VIEW MODEL => VIEW-DEF
 
diff --git a/src/main/package.lisp b/src/main/package.lisp
index 032dfa5..6f5f22f 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 #:textboxes #:forever-button-on #:switches #:view #:interface #:set-current-interface #:set-callback)
+  #:buttons #:textboxes #:forever-button-on #:switches #:sliders #:view #:interface #:set-current-interface #:set-callback)
  (:documentation
   "CLNL Model