7-GUIS port task 4
This commit is contained in:
parent
89e42ae987
commit
e554c797fb
|
@ -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-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)
|
||||
|
|
Loading…
Reference in New Issue