7-GUIS port task 2
This commit is contained in:
parent
997a3099fd
commit
3c65281a2e
|
@ -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 text-field@)
|
||||||
(struct-out set-text-field)
|
(struct-out set-text-field)
|
||||||
(struct-out button@)
|
(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
|
(require (only-in racket/class
|
||||||
new
|
new
|
||||||
send))
|
send
|
||||||
|
make-object))
|
||||||
(require racket/gui/base)
|
(require racket/gui/base)
|
||||||
|
|
||||||
;; an ID is a (Sealof Any)
|
;; an ID is a (Sealof Any)
|
||||||
|
@ -24,8 +27,10 @@
|
||||||
|
|
||||||
(assertion-struct horizontal-pane@ (id))
|
(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 (id value))
|
||||||
|
(message-struct set-text-field-background (id color))
|
||||||
|
(message-struct text-field-update (id value))
|
||||||
|
|
||||||
(assertion-struct button@ (id))
|
(assertion-struct button@ (id))
|
||||||
(message-struct button-press (id))
|
(message-struct button-press (id))
|
||||||
|
@ -57,21 +62,34 @@
|
||||||
(define (spawn-text-field #:parent parent
|
(define (spawn-text-field #:parent parent
|
||||||
#:label label
|
#:label label
|
||||||
#:init-value init
|
#:init-value init
|
||||||
#:enabled enabled?
|
#:enabled [enabled? #t]
|
||||||
#:min-width min-width)
|
#:min-width min-width)
|
||||||
(define parent-component (seal-contents parent))
|
(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%
|
(define tf (new text-field%
|
||||||
[parent parent-component]
|
[parent parent-component]
|
||||||
[label label]
|
[label label]
|
||||||
[init-value init]
|
[init-value init]
|
||||||
[enabled enabled?]
|
[enabled enabled?]
|
||||||
[min-width min-width]))
|
[min-width min-width]
|
||||||
|
[callback inject-text-field-update!]))
|
||||||
(define id (seal tf))
|
(define id (seal tf))
|
||||||
|
|
||||||
(spawn
|
(spawn
|
||||||
(assert (text-field@ id))
|
(field [val (send tf get-value)])
|
||||||
|
(assert (text-field@ id (val)))
|
||||||
(on (message (set-text-field id $value))
|
(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)
|
id)
|
||||||
|
|
||||||
|
|
Loading…
Reference in New Issue