7-GUIS port task 4

racket/syndicate-gui-toolbox/examples/7-GUIS/task-4.rkt

@@ -0,0 +1,62 @@
+#lang syndicate
+
+(require "../../widgets.rkt")
+(require/activate syndicate/drivers/timestate)
+
+;; notes on MF impl:
+;;  - reset button doesn't do anything if duration is at 0
+;;  - duration is meant to update as slider is moved, not just when released
+
+;; a timer that permits the continuous setting of a new interval, plusanything if duration is at 0
+;;  - duration is meant to update as slider is moved, not just when released
+;; a gauge and a text field that display the fraction of the elapsed time
+;; a reset button that sends the elapsed time back to 0
+
+(define INTERVAL 100)
+
+(define (next-time) (+ (current-milliseconds) INTERVAL))
+
+(spawn
+
+(define frame   (spawn-frame #:label "timer"))
+(define elapsed (spawn-gauge #:label "elapsed" #:parent frame #:enabled #f #:range 100))
+(define text    (spawn-text-field #:parent frame #:init-value "0" #:label ""))
+(define slider  (spawn-slider #:label "duration" #:parent frame #:min-value 0 #:max-value 100))
+(define button  (spawn-button #:label "reset" #:parent frame))
+
+(spawn
+ (field [*elapsed 0]  ;; INTERVAL/1000 ms accumulated elapsed time
+        [*duration 0] ;; INTERVAL/1000 ms set duration interval
+        [t (next-time)])
+
+ (define (timer-cb)
+   (unless (>= (*elapsed) (*duration))
+     (*elapsed (+ (*elapsed) 1))
+     (t (next-time))
+     (elapsed-cb)))
+
+ (define (elapsed-cb)
+   (send! (set-text-field text (format "elapsed ~a" (*elapsed))))
+   (unless (zero? (*duration))
+     (define r (quotient (* 100 (*elapsed)) (*duration)))
+     (send! (set-gauge-value elapsed r))))
+
+ (define (reset-cb)
+   (*elapsed 0)
+   (timer-cb))
+
+ (define (duration-cb new-duration)
+   (unless (= new-duration (*duration))
+     (*duration new-duration)
+     (timer-cb)))
+
+ (on (asserted (later-than (t)))
+     (timer-cb))
+ (on (message (button-press button))
+     (reset-cb))
+ (on (message (slider-update slider $val))
+     (duration-cb val))
+ (on-start (elapsed-cb)
+           (send! (show-frame frame #t))))
+
+)

racket/syndicate-gui-toolbox/widgets.rkt

@@ -5,6 +5,8 @@
          spawn-text-field
          spawn-button
          spawn-choice
+         spawn-gauge
+         spawn-slider
          (struct-out frame@)
          (struct-out show-frame)
          (struct-out horizontal-pane@)
@@ -17,7 +19,11 @@
          (struct-out choice@)
          (struct-out choice-selection)
          (struct-out set-selection)
-         (struct-out enable))
+         (struct-out enable)
+         (struct-out gauge@)
+         (struct-out set-gauge-value)
+         (struct-out slider@)
+         (struct-out slider-update))
 
 (require (only-in racket/class
                   new
@@ -46,6 +52,12 @@
 (message-struct choice-selection (id val))
 (message-struct set-selection (id idx))
 
+(assertion-struct gauge@ (id))
+(message-struct set-gauge-value (id value))
+
+(assertion-struct slider@ (id value))
+(message-struct slider-update (id value))
+
 (define (enable/disable-handler self my-id)
   (on (message (enable my-id $val))
       (send self enable val)))
@@ -157,3 +169,51 @@
        (selection (send ch get-string-selection))))
 
   id)
+
+;; ID String Bool Nat -> ID
+(define (spawn-gauge #:parent parent
+                     #:label label
+                     #:enabled [enabled? #t]
+                     #:range [range 100])
+  (define parent-component (seal-contents parent))
+  (define g (new gauge%
+                 [parent parent-component]
+                 [label label]
+                 [enabled enabled?]
+                 [range range]))
+  (define id (seal g))
+
+  (spawn
+   (assert (gauge@ id))
+   (on (message (set-gauge-value id $v))
+       (send g set-value v)))
+
+  id)
+
+;; ID String Nat Nat -> ID
+(define (spawn-slider #:parent parent
+                      #:label label
+                      #:min-value [min-value 0]
+                      #:max-value [max-value 100])
+  (define (inject-slider-event! self evt)
+    (send-ground-message (slider-update id (get))))
+
+  (define parent-component (seal-contents parent))
+  (define s (new slider%
+                 [parent parent-component]
+                 [label label]
+                 [min-value min-value]
+                 [max-value max-value]
+                 [callback inject-slider-event!]))
+  (define id (seal s))
+
+  (define (get) (send s get-value))
+
+  (spawn
+   (field [current (get)])
+   (assert (slider@ id (current)))
+   (on (message (inbound (slider-update id $val)))
+       (current val)
+       (send! (slider-update id val))))
+
+  id)