7-GUIS port task 3

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

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)