Toolbar and clock

gui.rkt

@@ -154,9 +154,16 @@
                                                (layout-item-size item)
                                                cell))))))
 
+(define (merge-box-size existing computed)
+  (match existing
+    [#f computed]
+    [(box-size h v)
+     (box-size (or h (box-size-horizontal computed))
+               (or v (box-size-vertical computed)))]))
+
 (define (solve-layout* container-id table on-layout)
   (during (requested-layout-size container-id $reqsize)
-    (define/dataflow total-size (or reqsize (table-sizing (table))))
+    (define/dataflow total-size (merge-box-size reqsize (table-sizing (table))))
     (assert (computed-layout-size container-id (total-size)))
     (define (total-width) (sizing-ideal (box-size-horizontal (total-size))))
     (define (total-height) (sizing-ideal (box-size-vertical (total-size))))
@@ -377,7 +384,8 @@
     (define/query-value touching? #f (inbound (touching id)) #t)
     (on #:when (touching?) (message (inbound (mouse-event trigger-event $s)))
         (send! (button-click id s)))
-    (assert (outbound (c 0 (rectangle x y (*width i) (*height i)))))))
+    (assert (outbound (c 0 (rectangle (x) (y) (*width i) (*height i)))))
+    (box-size (sizing (*width i) 0 0) (sizing (*height i) 0 0))))
 
 ;;---------------------------------------------------------------------------
 
@@ -418,7 +426,10 @@
                                 "Menu item selected" (random width) (random height)
                                 (format "~a" which))))
 
-       (pushbutton "Click me" 100 100 #:id 'click-me #:parent 'w #:trigger-event 'left-down)
+       (pushbutton "Click me"
+                   (lambda () 100)
+                   (lambda () 100)
+                   #:id 'click-me #:parent 'w #:trigger-event 'left-down)
        (on (message (button-click 'click-me (mouse-state $x $y _ _ _)))
            (send! (pop-up-menu-trigger 'testmenu x y 0 0.5 'left-up))))
 
@@ -443,20 +454,65 @@
        (stop-when (message (inbound (key-event #\q #t _)))
                   (actor (assert (outbound 'stop)))))
 
-;; (actor #:name 'toolbar
+(actor #:name 'toolbar
 
-;;        (field [window-width 0] [window-height 0])
-;;        (on (asserted (inbound (window $w $h)))
-;;            (window-width w)
-;;            (window-height h))
+       (field [window-width 0] [window-height 0])
+       (on (asserted (inbound (window $w $h)))
+           (window-width w)
+           (window-height h))
 
-;;        (assert (outbound ((costume #:id 'toolbar #:parent #f
-;;                                    (i:rectangle 1 1 "solid" "black"))
-;;                           -0.5
-;;                           (rectangle 0
-;;                                      (- (window-height) (theme-title-bar-height))
-;;                                      (window-width)
-;;                                      (theme-title-bar-height))))))
+       (define pad 4) ;;(theme-menu-item-padding))
+       (define pad2 (* pad 2))
+
+       (assert (requested-layout-size 'toolbar (box-size (sizing (- (window-width) pad2) 0 0) #f)))
+       (assert (observe (layout-solution 'toolbar (horizontal-layout 0) weak-fill-box-size _)))
+
+       (during (computed-layout-size 'toolbar (box-size (sizing $w _ _) (sizing $h _ _)))
+         (assert (outbound
+                  (sprite #:id 'toolbar #:parent #f
+                          -0.5
+                          `((translate 0 ,(- (window-height) h pad2))
+                            (push-matrix (scale ,(window-width) ,(+ h pad2))
+                                         (touchable toolbar ,in-unit-square?)
+                                         (texture ,(i:rectangle 1 1 "solid" "black")))
+                            (translate ,pad ,pad)
+                            (render-children)))))))
+
+(actor #:name 'start-button
+       (field [x 0] [y 0])
+       (define reqsize
+         (parameterize ((theme-button-y-padding 8)
+                        (theme-button-min-height 0))
+           (pushbutton "Start" x y #:id 'start-button #:parent 'toolbar
+                       #:trigger-event 'left-down)))
+       (during (layout-solution 'toolbar (horizontal-layout -10) reqsize (rectangle $l $t $w $h))
+         (x l)
+         (y t)
+         ;; TODO: Some way of getting hold of various stages of
+         ;; coordinate transform, so that we can pop up the menu with
+         ;; precision over the top-left corner of the start button,
+         ;; rather than whereever the mouse happens to be.
+         (on (message (button-click 'start-button (mouse-state $mx $my _ _ _)))
+             (send! (pop-up-menu-trigger 'system-menu mx my 0 1 'left-up)))))
+
+(actor #:name 'clock
+       (field [now (current-seconds)])
+       (on (message (inbound (frame-event _ $timestamp _ _)))
+           (define new (current-seconds))
+           (when (not (= new (now))) (now new)))
+       (local-require srfi/19)
+       (define/dataflow now-im (system-text (date->string (seconds->date (now)) "~a ~b ~d, ~3"))
+         #:default i:empty-image)
+       (during (layout-solution 'toolbar (horizontal-layout 10)
+                                (box-size (sizing (*width (now-im)) 0 0)
+                                          (sizing (*height (now-im)) 0 0))
+                                (rectangle $l $t $w $h))
+               (assert (outbound
+                        (sprite #:id 'clock #:parent 'toolbar
+                                0
+                                `((translate ,l ,(+ t (/ (- h (*height (now-im))) 2)))
+                                  (scale ,(*width (now-im)) ,(*height (now-im)))
+                                  (texture ,(now-im))))))))
 
 (module+ main
   (current-ground-dataspace (2d-dataspace)))