diff --git a/racket/syndicate-gui-toolbox/examples/7-GUIS/task-4.rkt b/racket/syndicate-gui-toolbox/examples/7-GUIS/task-4.rkt new file mode 100644 index 0000000..f097ff8 --- /dev/null +++ b/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)))) + +) diff --git a/racket/syndicate-gui-toolbox/widgets.rkt b/racket/syndicate-gui-toolbox/widgets.rkt index 1db03e8..4bd94bf 100644 --- a/racket/syndicate-gui-toolbox/widgets.rkt +++ b/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)