UI - Forever Buttons

diff --git a/src/main/interface.lisp b/src/main/interface.lisp
index 413a4089763eb9b3ab64784cc76eb1d8082b8709..b9e8e689f5ca756c8d430a1bda96e7c3669042f3 100644 (file)
--- 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 2f32d3b8b408c74ef7a41fff3cc3eee1f3dfb2f2..d1ffdadf350196663fc6c5d71aeafda2fdd91c91 100644 (file)
--- 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 7ff6efb5b20152573d6bac0ffe6cfcd13999ff69..3e7c9514705e2abd79832ea7f170c71017f7f9c3 100644 (file)
--- 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 970535e0085f0e250c92182370ac8dc1d85dac0a..9f35592c23105e8ed37afde540df0079f0270cdb 100644 (file)
--- 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