From: Frank Duncan <frank@kank.net>
Date: Thu, 20 Jul 2017 11:51:56 +0000 (-0500)
Subject: UI - Forever Buttons
X-Git-Tag: 0.1.1~7
X-Git-Url: https://code.consxy.com/gitweb/gitweb.cgi?p=clnl;a=commitdiff_plain;h=bd5ae8451480d80028599e004960f683bab0ad2f

UI - Forever Buttons
---

diff --git a/src/main/interface.lisp b/src/main/interface.lisp
index 413a408..b9e8e68 100644
--- a/src/main/interface.lisp
+++ b/src/main/interface.lisp
@@ -15,6 +15,29 @@
 
 (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
+; the interface state.  We keep it seperate from the main system display thread for two reasons:
+; 1) It should run even if there's no active display
+; 2) We want it to run slower than the current display thread
+(defvar *interface-thread* nil)
+
+(defgeneric update-widget (type def widget extra-info))
+(defmethod update-widget (type def widget extra-info))
+
+(defmethod update-widget ((type (eql :button)) button-def button idx)
+ (when (getf button-def :forever)
+  (clnl-gltk:toggle button (clnl-model:forever-button-on (getf button-def :display) idx))))
+
+(defun update-interface ()
+ (mapcar
+  (lambda (widget) (apply #'update-widget widget))
+  *widgets*))
+
+(defun boot-interface-thread ()
+ (when (not *interface-thread*)
+  (setf *interface-thread*
+   (sb-thread:make-thread (lambda () (loop (update-interface) (sleep .1))) :name "Interface Thread"))))
+
 ; For now, shapes can live in here
 ; header is
 ; * name <like default>
@@ -272,7 +295,7 @@
 (defun render-widgets ()
  (clnl-gltk:render *textbox*)
  (clnl-gltk:render *inputbox*)
- (mapcar #'clnl-gltk:render (mapcar #'cadr *widgets*)))
+ (mapcar #'clnl-gltk:render (mapcar #'third *widgets*)))
 
 (defun render ()
  (gl:clear :color-buffer-bit :depth-buffer-bit)
@@ -295,6 +318,7 @@
     (gl:ortho 0 *window-width* 0 *window-height* 0 5000)
     (render-widgets)
 
+    (gl:color 1 1 1)
     (gl:begin :lines)
     (gl:vertex view-x1 view-y1)
     (gl:vertex view-x1 (+ view-y2 1))
@@ -332,10 +356,10 @@
    (clnl-gltk:resize *textbox* box-width 12)
    (clnl-gltk:resize *inputbox* box-width 1))
   (mapcar
-   (lambda (pair)
-    (clnl-gltk:reposition (cadr pair)
-     (getf (car pair) :left)
-     (- *window-height* (getf (car pair) :height) (getf (car pair) :top))))
+   (lambda (widget)
+    (clnl-gltk:reposition (third widget)
+     (getf (second widget) :left)
+     (- *window-height* (getf (second widget) :height) (getf (second widget) :top))))
    *widgets*)))
 
 (defun execute (str)
@@ -361,12 +385,12 @@
   (lambda (w)
    (when (eql state :down) (clnl-gltk:mousedown w x (- *window-height* y)))
    (when (eql state :up) (clnl-gltk:mouseup w x (- *window-height* y))))
-  (mapcar #'cadr *widgets*)))
+  (mapcar #'third *widgets*)))
 
 (defun motion (x y)
  (mapcar
   (lambda (w) (clnl-gltk:mousemove w x (- *window-height* y)))
-  (mapcar #'cadr *widgets*)))
+  (mapcar #'third *widgets*)))
 
 (cffi:defcallback display :void () (display))
 (cffi:defcallback idle :void () (idle))
@@ -422,13 +446,40 @@ You can enter in various netlogo commands below, or use :q to quit the program.
 See http://github.com/frankduncan/clnl for more information about CLNL and to
 keep apprised of any updates that may happen.")
 
+(defun button-defs->buttons (button-defs)
+ (let
+  ((known-button-names nil))
+  (mapcar
+   (lambda (button-def)
+    (let*
+     ((idx (length (remove (getf button-def :display) known-button-names :test-not #'equal)))
+      (toggle-button nil)
+      (button
+       (clnl-gltk:button
+        (getf button-def :left)
+        (- *window-height* (getf button-def :height) (getf button-def :top))
+        (getf button-def :width)
+        (getf button-def :height)
+        (getf button-def :display)
+        (lambda ()
+         (when toggle-button (funcall toggle-button))
+         (execute
+          (format nil ":button \"~A\"~A"
+           (getf button-def :display)
+           (if (zerop idx) "" (format nil " ~A" idx)))))
+        :forever (getf button-def :forever))))
+     (push (getf button-def :display) known-button-names)
+     (when (getf button-def :forever) (setf toggle-button (lambda () (clnl-gltk:toggle button))))
+     (list :button button-def button idx)))
+   button-defs)))
+
 (defun initialize (&key dims view buttons)
  "INITIALIZE &key DIMS VIEW BUTTONS => RESULT
 
   DIMS: (:xmin XMIN :xmax XMAX :ymin YMIN :ymax YMAX :patch-size PATCH-SIZE)
   VIEW: (:left LEFT :top TOP)
   BUTTONS: BUTTON-DEF*
-  BUTTON-DEF: (:left LEFT :top TOP :height HEIGHT :width WIDTH :display DISPLAY)
+  BUTTON-DEF: (:left LEFT :top TOP :height HEIGHT :width WIDTH :forever FOREVER :display DISPLAY)
 
 ARGUMENTS AND VALUES:
 
@@ -442,6 +493,7 @@ ARGUMENTS AND VALUES:
   TOP: An integer representing the top position
   HEIGHT: An integer representing height
   WIDTH: An integer representing width
+  FOREVER: A boolean representing the forever status
   DISPLAY: A string representing display name
 
 DESCRIPTION:
@@ -450,29 +502,10 @@ DESCRIPTION:
   the interface lives.  From here, one can go into headless or running
   mode, but for certain things this interface will still need to act,
   and also allows for bringing up and taking down of visual elements."
+ (boot-interface-thread)
  (setf *dimensions* (append dims view))
- (let
-  ((known-button-names nil))
-  (setf *widgets*
-   (mapcar
-    (lambda (button-def)
-     (let
-      ((idx (length (remove (getf button-def :display) known-button-names :test-not #'equal))))
-      (push (getf button-def :display) known-button-names)
-      (list
-       button-def
-       (clnl-gltk:button
-        (getf button-def :left)
-        (- *window-height* (getf button-def :height) (getf button-def :top))
-        (getf button-def :width)
-        (getf button-def :height)
-        (getf button-def :display)
-        (lambda ()
-         (execute
-          (format nil ":button \"~A\"~A"
-           (getf button-def :display)
-           (if (zerop idx) "" (format nil " ~A" idx)))))))))
-    buttons))))
+ (setf *widgets*
+  (button-defs->buttons buttons)))
 
 (defun run ()
  "RUN => RESULT
diff --git a/src/main/main.lisp b/src/main/main.lisp
index 2f32d3b..d1ffdad 100644
--- a/src/main/main.lisp
+++ b/src/main/main.lisp
@@ -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
diff --git a/src/main/model.lisp b/src/main/model.lisp
index 7ff6efb..3e7c951 100644
--- a/src/main/model.lisp
+++ b/src/main/model.lisp
@@ -5,6 +5,10 @@
 (defvar *current-interface* nil)
 (defvar *current-callback* nil)
 
+; At this time, this is the only stateful part of the model.  If more get added,
+; a more general concept can be introduced.
+(defvar *enabled-forever-buttons* nil)
+
 (defstruct model
  code
  interface
@@ -161,7 +165,7 @@ DESCRIPTION:
                  (:double `(coerce (read-from-string ,line) 'double-float))
                  (:boolean `(string= "1" ,line))
                  (:inverted-boolean `(string= "0" ,line))
-                 (:tnil-boolean `(string= "NIL" ,line))
+                 (:tnil-boolean `(string/= "NIL" ,line))
                  (:choice `(cadr (find ,line ',(third def) :key #'car :test #'string=)))
                  (:option `(when (string/= ,line ,(third def)) ,line))
                  (:code `(unescape-code ,line))
@@ -263,6 +267,13 @@ DESCRIPTION:
       (when parser (funcall (cadr parser) widget-as-strings))))
     widgets-as-strings))))
 
+(defun find-button (name idx)
+ (nth
+  idx
+  (remove-if-not
+   (lambda (widget) (and (button-p widget) (string= (button-display-name widget) name)))
+   *current-interface*)))
+
 ; With authoring, idx here needs to be looked at again.
 (defun execute-button (name &optional (idx 0))
  "EXECUTE-BUTTON NAME &optional IDX => RESULT
@@ -285,16 +296,42 @@ DESCRIPTION:
   loaded, and cannot be guaranteed to be stable from run to run."
  (when *current-callback*
   (let
-   ((button
-     (nth
-      (round idx)
-      (remove-if-not
-       (lambda (widget) (and (button-p widget) (string= (button-display-name widget) name)))
-       *current-interface*))))
-   (if
-    button
-    (funcall *current-callback* (button-code button))
-    (error "Couldn't find button with name ~A (idx: ~A)" name idx)))))
+   ((button (find-button name (round idx))))
+   (cond
+    ((not button) (error "Couldn't find button with name ~A (idx: ~A)" name idx))
+    ((and (button-forever button) (find button *enabled-forever-buttons* :test #'equal))
+     (setf *enabled-forever-buttons* (remove button *enabled-forever-buttons* :test #'equal)))
+    ((button-forever button)
+     (setf *enabled-forever-buttons* (cons button *enabled-forever-buttons*))
+     (sb-thread:make-thread
+      (lambda ()
+       (loop
+        :while (find button *enabled-forever-buttons* :test #'equal)
+        ; The sleep is necessary so that it gives other threads time
+        :do (progn (clnl:run-commands (button-code button)) (sleep .001))))
+      :name (format nil "Forever button: ~A" (button-display button))))
+    (t (funcall *current-callback* (button-code button)))))))
+
+(defun forever-button-on (name &optional (idx 0))
+ "FOREVER-BUTTON-ON NAME &optional IDX => ON
+
+ARGUMENTS AND VALUES:
+
+  NAME: the name of the button
+  IDX: the instance of the button, defaults to 0
+  ON: a boolean
+
+DESCRIPTION:
+
+  Returns whether the button identified by NAME and IDX is currently on.
+
+  NAME refers to the display name for the button, which is usually
+  set by the model, but sometimes defaults to the code inside.
+
+  Because NAME is not guaranteed to be unique, IDX is available
+  as a specifier.  The index is in the order that the buttons are
+  loaded, and cannot be guaranteed to be stable from run to run."
+ (and (find (find-button name (round idx)) *enabled-forever-buttons* :test #'equal) t))
 
 ;; INFORMATION ABOUT MODEL
 
@@ -353,7 +390,7 @@ DESCRIPTION:
  "BUTTONS MODEL => BUTTON-DEFS
 
   BUTTON-DEFS: BUTTON-DEF*
-  BUTTON-DEF: (:left LEFT :top TOP :height HEIGHT :width WIDTH :display DISPLAY)
+  BUTTON-DEF: (:left LEFT :top TOP :height HEIGHT :width WIDTH :forever FOREVER :display DISPLAY)
 
 ARGUMENTS AND VALUES:
 
@@ -362,6 +399,7 @@ ARGUMENTS AND VALUES:
   TOP: An integer representing the top position
   HEIGHT: An integer representing height
   WIDTH: An integer representing width
+  FOREVER: A boolean representing whether this button is a forever button
   DISPLAY: A string representing display name
 
 DESCRIPTION:
@@ -378,11 +416,12 @@ DESCRIPTION:
        :top (button-top widget)
        :width (- (button-right widget) (button-left widget))
        :height (- (button-bottom widget) (button-top widget))
+       :forever (button-forever widget)
        :display (button-display-name widget)))))
    (model-interface model))))
 
 (defun view (model)
- "BUTTONS MODEL => VIEW-DEF
+ "VIEW MODEL => VIEW-DEF
 
   VIEW-DEF: (:left LEFT :top TOP)
 
diff --git a/src/main/package.lisp b/src/main/package.lisp
index 970535e..9f35592 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 #:view #:interface #:set-current-interface #:set-callback)
+  #:buttons #:forever-button-on #:view #:interface #:set-current-interface #:set-callback)
  (:documentation
   "CLNL Model