start on racket guis, 7-GUIS task 1

racket/syndicate-gui-toolbox/examples/7-GUIS/task-1.rkt

@@ -0,0 +1,25 @@
+#lang syndicate
+
+(require "../../widgets.rkt")
+(require (only-in racket/format ~a))
+
+;; a mouse-click counter
+
+(spawn
+ (on-start
+
+(define frame (spawn-frame #:label "Counter"))
+(define pane  (spawn-horizontal-pane #:parent frame))
+(define view  (spawn-text-field #:parent pane #:label "" #:init-value "0" #:enabled #f #:min-width 100))
+(define _but  (spawn-button #:parent pane #:label "Count"))
+
+(spawn
+ (field [counter 0])
+ (on (message (button-press _but))
+     (counter (add1 (counter)))
+     (send! (set-text-field view (~a (counter)))))
+ (on-start
+  (send! (show-frame frame #t))))))
+
+(module+ main
+  (void))

racket/syndicate-gui-toolbox/info.rkt

@@ -0,0 +1 @@
+#lang setup/infotab

racket/syndicate-gui-toolbox/widgets.rkt

@@ -0,0 +1,96 @@
+#lang syndicate
+
+(provide spawn-frame
+         spawn-horizontal-pane
+         spawn-text-field
+         spawn-button
+         (struct-out frame@)
+         (struct-out show-frame)
+         (struct-out horizontal-pane@)
+         (struct-out text-field@)
+         (struct-out set-text-field)
+         (struct-out button@)
+         (struct-out button-press))
+
+(require (only-in racket/class
+                  new
+                  send))
+(require racket/gui/base)
+
+;; an ID is a (Sealof Any)
+
+(assertion-struct frame@ (id))
+(message-struct show-frame (id value))
+
+(assertion-struct horizontal-pane@ (id))
+
+(assertion-struct text-field@ (id))
+(message-struct set-text-field (id value))
+
+(assertion-struct button@ (id))
+(message-struct button-press (id))
+
+;; String -> ID
+(define (spawn-frame #:label label)
+  (define frame
+    (parameterize ((current-eventspace (make-eventspace)))
+      (new frame% [label label])))
+  (define id (seal frame))
+  (spawn
+   (assert (frame@ id))
+   (on (message (show-frame id $val))
+       (send frame show val)))
+  id)
+
+;; ID -> ID
+(define (spawn-horizontal-pane #:parent parent)
+  (define parent-component (seal-contents parent))
+  (define pane (new horizontal-pane% [parent parent-component]))
+  (define id (seal pane))
+
+  (spawn
+   (assert (horizontal-pane@ id)))
+
+  id)
+
+; ID String String Bool Nat -> ID
+(define (spawn-text-field #:parent parent
+                          #:label label
+                          #:init-value init
+                          #:enabled enabled?
+                          #:min-width min-width)
+  (define parent-component (seal-contents parent))
+  (define tf (new text-field%
+                  [parent parent-component]
+                  [label label]
+                  [init-value init]
+                  [enabled enabled?]
+                  [min-width min-width]))
+  (define id (seal tf))
+
+  (spawn
+   (assert (text-field@ id))
+   (on (message (set-text-field id $value))
+       (send tf set-value value)))
+
+  id)
+
+;; ID String -> ID
+(define (spawn-button #:parent parent
+                      #:label label)
+  (define (inject-button-press! b e)
+    (send-ground-message (button-press id)))
+  (define parent-component (seal-contents parent))
+  (define but (new button%
+                   [parent parent-component]
+                   [label label]
+                   [callback inject-button-press!]))
+  (define id (seal but))
+
+  (spawn
+   (assert (button@ id))
+   ;; NOTE - this assumes we are one level away from ground
+   (on (message (inbound (button-press id)))
+       (send! (button-press id))))
+
+  id)