7-GUIS port task 2

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))))))

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)