7-GUIS port task 4
This commit is contained in:
parent
064a2e1462
commit
de1fab2cb5
|
@ -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))))
|
||||||
|
|
||||||
|
)
|
|
@ -5,6 +5,8 @@
|
||||||
spawn-text-field
|
spawn-text-field
|
||||||
spawn-button
|
spawn-button
|
||||||
spawn-choice
|
spawn-choice
|
||||||
|
spawn-gauge
|
||||||
|
spawn-slider
|
||||||
(struct-out frame@)
|
(struct-out frame@)
|
||||||
(struct-out show-frame)
|
(struct-out show-frame)
|
||||||
(struct-out horizontal-pane@)
|
(struct-out horizontal-pane@)
|
||||||
|
@ -17,7 +19,11 @@
|
||||||
(struct-out choice@)
|
(struct-out choice@)
|
||||||
(struct-out choice-selection)
|
(struct-out choice-selection)
|
||||||
(struct-out set-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
|
(require (only-in racket/class
|
||||||
new
|
new
|
||||||
|
@ -46,6 +52,12 @@
|
||||||
(message-struct choice-selection (id val))
|
(message-struct choice-selection (id val))
|
||||||
(message-struct set-selection (id idx))
|
(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)
|
(define (enable/disable-handler self my-id)
|
||||||
(on (message (enable my-id $val))
|
(on (message (enable my-id $val))
|
||||||
(send self enable val)))
|
(send self enable val)))
|
||||||
|
@ -157,3 +169,51 @@
|
||||||
(selection (send ch get-string-selection))))
|
(selection (send ch get-string-selection))))
|
||||||
|
|
||||||
id)
|
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)
|
||||||
|
|
Loading…
Reference in New Issue