7-GUIS port task 3
This commit is contained in:
parent
3c65281a2e
commit
064a2e1462
|
@ -0,0 +1,69 @@
|
||||||
|
#lang syndicate
|
||||||
|
|
||||||
|
(require "../../widgets.rkt")
|
||||||
|
|
||||||
|
;; a flight booker that allows a choice between one-way and return bookings
|
||||||
|
;; and, depending on the choice, a start date or a start date and an end date.
|
||||||
|
|
||||||
|
;; ---------------------------------------------------------------------------------------------------
|
||||||
|
(require gregor)
|
||||||
|
|
||||||
|
;; gregor should not raise an exception when parsing fails, but return #f
|
||||||
|
(define (to-date d) (with-handlers ([exn? (λ (_) #f)]) (parse-date d "d.M.y")))
|
||||||
|
|
||||||
|
;; ---------------------------------------------------------------------------------------------------
|
||||||
|
(define DATE0 "27.03.2014")
|
||||||
|
(define ONE "one-way flight")
|
||||||
|
(define RETURN "return flight")
|
||||||
|
(define CHOICES `(,ONE ,RETURN))
|
||||||
|
(define RED "red")
|
||||||
|
(define WHITE "white")
|
||||||
|
|
||||||
|
(spawn
|
||||||
|
(define (make-field enabled)
|
||||||
|
(spawn-text-field #:parent frame
|
||||||
|
#:label ""
|
||||||
|
#:init-value DATE0
|
||||||
|
#:enabled enabled))
|
||||||
|
|
||||||
|
(define frame (spawn-frame #:label "flight booker"))
|
||||||
|
(define choice (spawn-choice #:label "" #:parent frame #:choices CHOICES))
|
||||||
|
(define start-d (make-field #t))
|
||||||
|
(define return-d (make-field #f))
|
||||||
|
(define book (spawn-button #:label "Book" #:parent frame))
|
||||||
|
|
||||||
|
(spawn
|
||||||
|
(field [*kind-flight (list-ref CHOICES 0)] ;; one of the CHOICES
|
||||||
|
[*start-date (to-date DATE0)] ;; date
|
||||||
|
[*return-date (to-date DATE0)]) ;; date
|
||||||
|
|
||||||
|
(define (field-cb self val date-setter!)
|
||||||
|
(define date (to-date val))
|
||||||
|
(cond
|
||||||
|
[date (send! (set-text-field-background self WHITE)) (date-setter! date) (enable-book)]
|
||||||
|
[else (send! (set-text-field-background self RED)) (enable-book #f #f)]))
|
||||||
|
|
||||||
|
(define (enable-book [start-date (*start-date)] [return-date (*return-date)])
|
||||||
|
(send! (enable book #f))
|
||||||
|
(when (and start-date (date<=? (today) start-date)
|
||||||
|
(or (and (string=? ONE (*kind-flight)))
|
||||||
|
(and return-date (date<=? start-date return-date))))
|
||||||
|
(send! (enable book #t))))
|
||||||
|
|
||||||
|
(define (enable-return-book selection)
|
||||||
|
(*kind-flight selection)
|
||||||
|
(send! (enable return-d (string=? RETURN (*kind-flight))))
|
||||||
|
(enable-book))
|
||||||
|
|
||||||
|
(on (message (text-field-update start-d $val))
|
||||||
|
(field-cb start-d val *start-date))
|
||||||
|
(on (message (text-field-update return-d $val))
|
||||||
|
(field-cb return-d val *return-date))
|
||||||
|
(on (message (choice-selection choice $sel))
|
||||||
|
(enable-return-book sel))
|
||||||
|
(on (message (button-press book))
|
||||||
|
(displayln "confirmed"))
|
||||||
|
|
||||||
|
(on-start (send! (show-frame frame #t))
|
||||||
|
(enable-return-book (*kind-flight))))
|
||||||
|
)
|
|
@ -4,6 +4,7 @@
|
||||||
spawn-horizontal-pane
|
spawn-horizontal-pane
|
||||||
spawn-text-field
|
spawn-text-field
|
||||||
spawn-button
|
spawn-button
|
||||||
|
spawn-choice
|
||||||
(struct-out frame@)
|
(struct-out frame@)
|
||||||
(struct-out show-frame)
|
(struct-out show-frame)
|
||||||
(struct-out horizontal-pane@)
|
(struct-out horizontal-pane@)
|
||||||
|
@ -12,7 +13,11 @@
|
||||||
(struct-out button@)
|
(struct-out button@)
|
||||||
(struct-out button-press)
|
(struct-out button-press)
|
||||||
(struct-out set-text-field-background)
|
(struct-out set-text-field-background)
|
||||||
(struct-out text-field-update))
|
(struct-out text-field-update)
|
||||||
|
(struct-out choice@)
|
||||||
|
(struct-out choice-selection)
|
||||||
|
(struct-out set-selection)
|
||||||
|
(struct-out enable))
|
||||||
|
|
||||||
(require (only-in racket/class
|
(require (only-in racket/class
|
||||||
new
|
new
|
||||||
|
@ -22,6 +27,8 @@
|
||||||
|
|
||||||
;; an ID is a (Sealof Any)
|
;; an ID is a (Sealof Any)
|
||||||
|
|
||||||
|
(message-struct enable (id val))
|
||||||
|
|
||||||
(assertion-struct frame@ (id))
|
(assertion-struct frame@ (id))
|
||||||
(message-struct show-frame (id value))
|
(message-struct show-frame (id value))
|
||||||
|
|
||||||
|
@ -35,6 +42,14 @@
|
||||||
(assertion-struct button@ (id))
|
(assertion-struct button@ (id))
|
||||||
(message-struct button-press (id))
|
(message-struct button-press (id))
|
||||||
|
|
||||||
|
(assertion-struct choice@ (id selection))
|
||||||
|
(message-struct choice-selection (id val))
|
||||||
|
(message-struct set-selection (id idx))
|
||||||
|
|
||||||
|
(define (enable/disable-handler self my-id)
|
||||||
|
(on (message (enable my-id $val))
|
||||||
|
(send self enable val)))
|
||||||
|
|
||||||
;; String -> ID
|
;; String -> ID
|
||||||
(define (spawn-frame #:label label)
|
(define (spawn-frame #:label label)
|
||||||
(define frame
|
(define frame
|
||||||
|
@ -63,7 +78,7 @@
|
||||||
#:label label
|
#:label label
|
||||||
#:init-value init
|
#:init-value init
|
||||||
#:enabled [enabled? #t]
|
#:enabled [enabled? #t]
|
||||||
#:min-width min-width)
|
#:min-width [min-width 1])
|
||||||
(define parent-component (seal-contents parent))
|
(define parent-component (seal-contents parent))
|
||||||
|
|
||||||
(define (inject-text-field-update! _ evt)
|
(define (inject-text-field-update! _ evt)
|
||||||
|
@ -81,6 +96,7 @@
|
||||||
(spawn
|
(spawn
|
||||||
(field [val (send tf get-value)])
|
(field [val (send tf get-value)])
|
||||||
(assert (text-field@ id (val)))
|
(assert (text-field@ id (val)))
|
||||||
|
(enable/disable-handler tf id)
|
||||||
(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))
|
(val value))
|
||||||
|
@ -107,8 +123,37 @@
|
||||||
|
|
||||||
(spawn
|
(spawn
|
||||||
(assert (button@ id))
|
(assert (button@ id))
|
||||||
|
(enable/disable-handler but id)
|
||||||
;; NOTE - this assumes we are one level away from ground
|
;; NOTE - this assumes we are one level away from ground
|
||||||
(on (message (inbound (button-press id)))
|
(on (message (inbound (button-press id)))
|
||||||
(send! (button-press id))))
|
(send! (button-press id))))
|
||||||
|
|
||||||
id)
|
id)
|
||||||
|
|
||||||
|
;; ID String (Listof String) -> ID
|
||||||
|
(define (spawn-choice #:parent parent
|
||||||
|
#:label label
|
||||||
|
#:choices choices)
|
||||||
|
(define (inject-selection! c e)
|
||||||
|
(send-ground-message (choice-selection id (send ch get-string-selection))))
|
||||||
|
(define parent-component (seal-contents parent))
|
||||||
|
(define ch (new choice%
|
||||||
|
[parent parent-component]
|
||||||
|
[label label]
|
||||||
|
[choices choices]
|
||||||
|
[callback inject-selection!]))
|
||||||
|
(define id (seal ch))
|
||||||
|
|
||||||
|
(spawn
|
||||||
|
(field [selection (send ch get-string-selection)])
|
||||||
|
(assert (choice@ id (selection)))
|
||||||
|
|
||||||
|
(enable/disable-handler ch id)
|
||||||
|
(on (message (inbound (choice-selection id $val)))
|
||||||
|
(selection val)
|
||||||
|
(send! (choice-selection id val)))
|
||||||
|
(on (message (set-selection id $idx))
|
||||||
|
(send ch set-selection idx)
|
||||||
|
(selection (send ch get-string-selection))))
|
||||||
|
|
||||||
|
id)
|
||||||
|
|
Loading…
Reference in New Issue