7-GUIS port task 2
This commit is contained in:
parent
ce0dba8f36
commit
161abab986
|
@ -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))))))
|
|
@ -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)
|
||||
|
||||
|
|
Loading…
Reference in New Issue