UI/Model Parse - Switches

[clnl] / src / main / model.lisp

diff --git a/src/main/model.lisp b/src/main/model.lisp
index 3e7c9514705e2abd79832ea7f170c71017f7f9c3..c947987f2dadb12eafb42b1a45682ac21c6762cc 100644 (file)
--- a/src/main/model.lisp
+++ b/src/main/model.lisp
@@ -308,7 +308,12 @@ DESCRIPTION:
        (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))))
+        :do
+        (let
+         ((result (funcall *current-callback* (button-code button))))
+         (when (eql :stop result)
+          (setf *enabled-forever-buttons* (remove button *enabled-forever-buttons* :test #'equal)))
+         (sleep .001))))
       :name (format nil "Forever button: ~A" (button-display button))))
     (t (funcall *current-callback* (button-code button)))))))
 
@@ -420,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