From 064a2e14624cc5ed25e630c101774428a3cdd6a6 Mon Sep 17 00:00:00 2001 From: Sam Caldwell Date: Wed, 10 Jul 2019 13:48:58 -0400 Subject: [PATCH] 7-GUIS port task 3 --- .../examples/7-GUIS/task-3.rkt | 69 +++++++++++++++++++ racket/syndicate-gui-toolbox/widgets.rkt | 49 ++++++++++++- 2 files changed, 116 insertions(+), 2 deletions(-) create mode 100644 racket/syndicate-gui-toolbox/examples/7-GUIS/task-3.rkt diff --git a/racket/syndicate-gui-toolbox/examples/7-GUIS/task-3.rkt b/racket/syndicate-gui-toolbox/examples/7-GUIS/task-3.rkt new file mode 100644 index 0000000..d6c0f7d --- /dev/null +++ b/racket/syndicate-gui-toolbox/examples/7-GUIS/task-3.rkt @@ -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)))) +) diff --git a/racket/syndicate-gui-toolbox/widgets.rkt b/racket/syndicate-gui-toolbox/widgets.rkt index bf25266..1db03e8 100644 --- a/racket/syndicate-gui-toolbox/widgets.rkt +++ b/racket/syndicate-gui-toolbox/widgets.rkt @@ -4,6 +4,7 @@ spawn-horizontal-pane spawn-text-field spawn-button + spawn-choice (struct-out frame@) (struct-out show-frame) (struct-out horizontal-pane@) @@ -12,7 +13,11 @@ (struct-out button@) (struct-out button-press) (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 new @@ -22,6 +27,8 @@ ;; an ID is a (Sealof Any) +(message-struct enable (id val)) + (assertion-struct frame@ (id)) (message-struct show-frame (id value)) @@ -35,6 +42,14 @@ (assertion-struct button@ (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 (define (spawn-frame #:label label) (define frame @@ -63,7 +78,7 @@ #:label label #:init-value init #:enabled [enabled? #t] - #:min-width min-width) + #:min-width [min-width 1]) (define parent-component (seal-contents parent)) (define (inject-text-field-update! _ evt) @@ -81,6 +96,7 @@ (spawn (field [val (send tf get-value)]) (assert (text-field@ id (val))) + (enable/disable-handler tf id) (on (message (set-text-field id $value)) (send tf set-value value) (val value)) @@ -107,8 +123,37 @@ (spawn (assert (button@ id)) + (enable/disable-handler but id) ;; NOTE - this assumes we are one level away from ground (on (message (inbound (button-press id))) (send! (button-press 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)