Toolbar and clock
This commit is contained in:
parent
6e1819cc3b
commit
b635932ecd
86
gui.rkt
86
gui.rkt
|
@ -154,9 +154,16 @@
|
||||||
(layout-item-size item)
|
(layout-item-size item)
|
||||||
cell))))))
|
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)
|
(define (solve-layout* container-id table on-layout)
|
||||||
(during (requested-layout-size container-id $reqsize)
|
(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)))
|
(assert (computed-layout-size container-id (total-size)))
|
||||||
(define (total-width) (sizing-ideal (box-size-horizontal (total-size))))
|
(define (total-width) (sizing-ideal (box-size-horizontal (total-size))))
|
||||||
(define (total-height) (sizing-ideal (box-size-vertical (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)
|
(define/query-value touching? #f (inbound (touching id)) #t)
|
||||||
(on #:when (touching?) (message (inbound (mouse-event trigger-event $s)))
|
(on #:when (touching?) (message (inbound (mouse-event trigger-event $s)))
|
||||||
(send! (button-click id 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)
|
"Menu item selected" (random width) (random height)
|
||||||
(format "~a" which))))
|
(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 _ _ _)))
|
(on (message (button-click 'click-me (mouse-state $x $y _ _ _)))
|
||||||
(send! (pop-up-menu-trigger 'testmenu x y 0 0.5 'left-up))))
|
(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 _)))
|
(stop-when (message (inbound (key-event #\q #t _)))
|
||||||
(actor (assert (outbound 'stop)))))
|
(actor (assert (outbound 'stop)))))
|
||||||
|
|
||||||
;; (actor #:name 'toolbar
|
(actor #:name 'toolbar
|
||||||
|
|
||||||
;; (field [window-width 0] [window-height 0])
|
(field [window-width 0] [window-height 0])
|
||||||
;; (on (asserted (inbound (window $w $h)))
|
(on (asserted (inbound (window $w $h)))
|
||||||
;; (window-width w)
|
(window-width w)
|
||||||
;; (window-height h))
|
(window-height h))
|
||||||
|
|
||||||
;; (assert (outbound ((costume #:id 'toolbar #:parent #f
|
(define pad 4) ;;(theme-menu-item-padding))
|
||||||
;; (i:rectangle 1 1 "solid" "black"))
|
(define pad2 (* pad 2))
|
||||||
;; -0.5
|
|
||||||
;; (rectangle 0
|
(assert (requested-layout-size 'toolbar (box-size (sizing (- (window-width) pad2) 0 0) #f)))
|
||||||
;; (- (window-height) (theme-title-bar-height))
|
(assert (observe (layout-solution 'toolbar (horizontal-layout 0) weak-fill-box-size _)))
|
||||||
;; (window-width)
|
|
||||||
;; (theme-title-bar-height))))))
|
(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
|
(module+ main
|
||||||
(current-ground-dataspace (2d-dataspace)))
|
(current-ground-dataspace (2d-dataspace)))
|
||||||
|
|
Loading…
Reference in New Issue