diff --git a/racket/syndicate-gui-toolbox/examples/7-GUIS/task-2.rkt b/racket/syndicate-gui-toolbox/examples/7-GUIS/task-2.rkt new file mode 100644 index 0000000..68dd5da --- /dev/null +++ b/racket/syndicate-gui-toolbox/examples/7-GUIS/task-2.rkt @@ -0,0 +1,61 @@ +#lang syndicate + +(require "../../widgets.rkt") +(require (only-in racket/format ~a ~r)) + +;; a bi-directional temperature converter (Fahrenheit vs Celsius) + +(define ((callback setter) field val) + (define-values (field:num last) (string->number* val)) + (cond + [(and field:num (rational? field:num)) + (define inexact-n (* #i1.0 field:num)) + (setter inexact-n) + (render field inexact-n last)] + [else (send! (set-text-field-background field "red"))])) + +(define (string->number* str) + (define n (string->number str)) + (values n (and n (string-ref str (- (string-length str) 1))))) + +(define (flow *from --> *to to-field) + (λ (x) + (*from x) + (*to (--> x)) + (render to-field (*to) ""))) + +(define (render to-field *to last) + (send! (set-text-field-background to-field "white")) + (send! (set-text-field to-field (~a (~r *to #:precision 4) (if (eq? #\. last) "." ""))))) + +(spawn + (on-start +(define frame (spawn-frame #:label "temperature converter")) +(define pane (spawn-horizontal-pane #:parent frame)) + +(define (make-field v0 lbl) + (spawn-text-field #:parent pane + #:min-width 199 + #:label lbl + #:init-value v0)) + +(define C0 0) +(define F0 32) + +(define C-field (make-field (~a C0) "celsius:")) +(define F-field (make-field (~a F0) " = fahrenheit:")) + +(spawn + + (field [*C C0] + [*F F0]) + + (define celsius->fahrenheit (callback (flow *C (λ (c) (+ (* c 9/5) 32)) *F F-field))) + (define fahrenheit->celsius (callback (flow *F (λ (f) (* (- f 32) 5/9)) *C C-field))) + + (on (message (text-field-update C-field $val)) + (celsius->fahrenheit C-field val)) + (on (message (text-field-update F-field $val)) + (fahrenheit->celsius F-field val)) + (on-start + (send! (show-frame frame #t)))))) diff --git a/racket/syndicate-gui-toolbox/widgets.rkt b/racket/syndicate-gui-toolbox/widgets.rkt index febab02..bf25266 100644 --- a/racket/syndicate-gui-toolbox/widgets.rkt +++ b/racket/syndicate-gui-toolbox/widgets.rkt @@ -10,11 +10,14 @@ (struct-out text-field@) (struct-out set-text-field) (struct-out button@) - (struct-out button-press)) + (struct-out button-press) + (struct-out set-text-field-background) + (struct-out text-field-update)) (require (only-in racket/class new - send)) + send + make-object)) (require racket/gui/base) ;; an ID is a (Sealof Any) @@ -24,8 +27,10 @@ (assertion-struct horizontal-pane@ (id)) -(assertion-struct text-field@ (id)) +(assertion-struct text-field@ (id value)) (message-struct set-text-field (id value)) +(message-struct set-text-field-background (id color)) +(message-struct text-field-update (id value)) (assertion-struct button@ (id)) (message-struct button-press (id)) @@ -57,21 +62,34 @@ (define (spawn-text-field #:parent parent #:label label #:init-value init - #:enabled enabled? + #:enabled [enabled? #t] #:min-width min-width) (define parent-component (seal-contents parent)) + + (define (inject-text-field-update! _ evt) + (send-ground-message (text-field-update id (send tf get-value)))) + (define tf (new text-field% [parent parent-component] [label label] [init-value init] [enabled enabled?] - [min-width min-width])) + [min-width min-width] + [callback inject-text-field-update!])) (define id (seal tf)) (spawn - (assert (text-field@ id)) + (field [val (send tf get-value)]) + (assert (text-field@ id (val))) (on (message (set-text-field id $value)) - (send tf set-value value))) + (send tf set-value value) + (val value)) + (on (message (set-text-field-background id $color)) + (define c (make-object color% color)) + (send tf set-field-background c)) + (on (message (inbound (text-field-update id $value))) + (val (send tf get-value)) + (send! (text-field-update id (val))))) id)