syndicate-rkt/syndicate-examples/gui/gui.rkt

666 lines
30 KiB
Racket
Raw Blame History

This file contains ambiguous Unicode characters

This file contains Unicode characters that might be confused with other characters. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.

;;; SPDX-License-Identifier: LGPL-3.0-or-later
;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
#lang syndicate
(require racket/set)
(require data/order)
(require srfi/19)
(require (prefix-in i: 2htdp/image))
(require (prefix-in p: pict))
(require syndicate/drivers/gl-2d/affine)
(require "layout/main.rkt")
(require "hsv.rkt")
(require syndicate/bag)
(require syndicate/pattern)
(require/activate syndicate/drivers/gl-2d)
;;---------------------------------------------------------------------------
(define theme-font (make-parameter "Roboto"))
(define theme-font-size (make-parameter 16))
(define theme-title-font (make-parameter "Roboto Condensed"))
(define theme-title-font-size (make-parameter 20))
(define theme-title-font-color (make-parameter "white"))
(define theme-title-bar-color (make-parameter (hsv->color 260 1 0.6)))
(define theme-title-bar-selected-color (make-parameter (hsv->color 260 1 1)))
(define theme-title-bar-height (make-parameter 48))
(define theme-button-background-color (make-parameter (hsv->color 30 0.9 1)))
(define theme-button-color (make-parameter "white"))
(define theme-button-x-padding (make-parameter 40))
(define theme-button-y-padding (make-parameter 24))
(define theme-button-min-height (make-parameter 48))
(define theme-window-border-width (make-parameter 8))
(define theme-window-resize-corner-size (make-parameter 16))
(define theme-menu-item-color (make-parameter "white"))
(define theme-menu-item-background-color (make-parameter (hsv->color 240 1 0.8)))
(define theme-menu-item-selected-background-color (make-parameter (hsv->color 345 1 1)))
(define theme-menu-item-padding (make-parameter 16))
(define theme-menu-separator-width (make-parameter 2))
(define theme-menu-separator-color (make-parameter "white"))
;;---------------------------------------------------------------------------
(define (*width x)
(cond [(i:image? x) (i:image-width x)]
[(p:pict? x) (p:pict-width x)]
[else (error '*width "Neither an image nor a pict: ~v" x)]))
(define (*height x)
(cond [(i:image? x) (i:image-height x)]
[(p:pict? x) (p:pict-height x)]
[else (error '*height "Neither an image nor a pict: ~v" x)]))
(define (costume #:id [id #f] #:parent [parent-id #f] #:coordinate-map-id [coordinate-map-id #f] i)
(define iw (*width i))
(define ih (*height i))
(define iaspect (/ iw ih))
(lambda (z rect)
(match-define (rectangle left top sw sh) rect)
(define saspect (if (and (positive? sw) (positive? sh)) (/ sw sh) 1))
(define-values (scale-w scale-h translate-x translate-y)
(if (> saspect iaspect)
(let ((scale-h (/ sw iaspect)))
(values sw scale-h 0 (/ (- sh scale-h) 2)))
(let ((scale-w (* sh iaspect)))
(values scale-w sh (/ (- sw scale-w) 2) 0))))
(sprite #:id (or id (gensym 'costume))
#:parent parent-id
z
`((translate ,left ,top)
(push-matrix (scale ,sw ,sh)
,@(if id
`((touchable ,id ,in-unit-square?))
`())
,@(if coordinate-map-id
`((coordinate-map ,coordinate-map-id))
`())
(texture ,i
,(- (/ translate-x scale-w))
,(- (/ translate-y scale-h))
,(/ sw scale-w)
,(/ sh scale-h)
))
(render-children)))))
(define (draggable-mixin touching? x y id-to-raise)
(define (idle)
(react (stop-when #:when (touching?)
(message (mouse-event 'left-down (mouse-state $mx $my _ _ _)))
(dragging (- mx (x)) (- my (y))))))
(define (dragging dx dy)
(when id-to-raise (send! (raise-widget id-to-raise)))
(react (on (message (mouse-event 'motion (mouse-state $mx $my _ _ _)))
(x (- mx dx))
(y (- my dy)))
(stop-when (message (mouse-event 'left-up _)) (idle))
(stop-when (message (mouse-event 'leave _)) (idle))))
(idle))
(spawn #:name 'root-window
(define c (costume #:id 'root (i:bitmap "oakura-beach-20081225.jpg")))
(define/query-value touching? #f (touching 'root) #t)
(on #:when (touching?) (message (mouse-event 'right-down (mouse-state $x $y _ _ _)))
(send! (pop-up-menu-trigger 'system-menu x y 0 0.5 'right-up)))
;; (during (window $width $height)
;; (assert-scene `((translate ,width 0) (rotate -90)) `())
;; (assert (desktop height width))
;; (assert (c 0 (rectangle 0 0 height width))))
(during (window $width $height)
(assert (desktop width height))
(assert (c 0 (rectangle 0 0 width height))))
)
(define (button-underlay i)
(define w (+ (*width i) (theme-button-x-padding)))
(define h (max (+ (*height i) (theme-button-y-padding)) (theme-button-min-height)))
(i:rectangle w h "solid" (theme-button-background-color)))
;;---------------------------------------------------------------------------
;; Protocol: Layout.
;;---------------------------------------------------------------------------
;; Roles:
;;
;; Layout Solver
;; Responds to assertions of interest in layout solutions by
;; computing layouts and asserting the resulting positions.
;;
;; (Observe LayoutSolution)+ ==>
;; RequestedLayoutSize ==>
;; ComputedLayoutSize ∧ LayoutSolution+
;;
;; Layout Observer
;; Supplies any initial constraints on the overall layout size,
;; and may observe the final overall computed layout size.
;;
;; RequestedLayoutSize ∧ (ComputedLayoutSize ==> 1)?
;;
;; Layout Participant
;; Supplies constraints on an individual item to be laid out
;; and monitors the resulting position decision for that item.
;;
;; LayoutSolution ==> 1
;;---------------------------------------------------------------------------
;; A LayoutSpec is one of
;; - (horizontal-layout Any)
;; - (vertical-layout Any)
;; - (tabular-layout Nat Nat)
;; where the first two use their keys for *ordering* peers relative to
;; each other using datum-order, and the last uses the given row and
;; column to place the item within an implicitly-sized grid layout.
(struct horizontal-layout (key) #:transparent)
(struct vertical-layout (key) #:transparent)
(struct tabular-layout (row col) #:transparent)
;; ASSERTION. A RequestedLayoutSize is a
;; (requested-layout-size Any (Option (box-size (Option Sizing) (Option Sizing))))
;; and describes overall constraints on the total size of the layout to be
;; constructed. Supplying `size` as `#f` means that there is no constraint at all;
;; otherwise, the `box-size` given is used as the exact dimensions of
;; the layout, unless one or both of the dimensions of the `box-size`
;; are given as `#f`, in which case there is no constraint for that
;; dimension.
(struct requested-layout-size (container-id size) #:transparent)
;; ASSERTION. A ComputedLayoutSize is a
;; (computed-layout-size Any BoxSize)
;; and gives the concrete dimensions of the layout after layout
;; computation has completed.
(struct computed-layout-size (container-id size) #:transparent)
;; ASSERTION. A LayoutSolution is a
;; (layout-solution Any LayoutSpec BoxSize Rectangle)
;; and denotes the computed bounds of a given item within a layout.
;; TODO: introduce an item ID??
(struct layout-solution (container-id
spec
size
rectangle) #:transparent)
;; ASSERTION. Describes the size of the desktop area.
(struct desktop (width height) #:transparent)
;;---------------------------------------------------------------------------
(struct layout-item (spec size) #:transparent)
(define (layout-item-spec-key li)
(define v (layout-item-spec li))
(if (number? v) (exact->inexact v) v))
(spawn #:name 'layout-driver
(during/spawn (observe (layout-solution $container-id _ _ _))
#:name (list 'layout container-id)
(stop-when (asserted (observe (layout-solution container-id (horizontal-layout _) _ _)))
(react (solve-hv-layout #f container-id)))
(stop-when (asserted (observe (layout-solution container-id (vertical-layout _) _ _)))
(react (solve-hv-layout #t container-id)))
(stop-when (asserted (observe (layout-solution container-id (tabular-layout _ _) _ _)))
(react (solve-tabular-layout container-id)))))
(define (solve-hv-layout vertical? container-id)
(field [items (set)])
(if vertical?
(query-set* items
(observe (layout-solution container-id (vertical-layout $key) $size _))
(layout-item key size))
(query-set* items
(observe (layout-solution container-id (horizontal-layout $key) $size _))
(layout-item key size)))
(define/dataflow ordered-items (sort (set->list (items))
(order-<? datum-order)
#:key layout-item-spec-key)
#:default '())
(define/dataflow table
(if vertical?
(map list (map layout-item-size (ordered-items)))
(list (map layout-item-size (ordered-items)))))
(solve-layout* container-id
table
(lambda (layout)
(for [(item (ordered-items))
(cell (if vertical? (map car layout) (car layout)))]
(assert! (layout-solution container-id
(if vertical?
(vertical-layout (layout-item-spec item))
(horizontal-layout (layout-item-spec item)))
(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 (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))))
(define/dataflow layout (table-layout (table) 0 0 (total-width) (total-height)) #:default '())
(begin/dataflow
(for [(a (in-bag (current-adhoc-assertions)))]
(match a
[(layout-solution (== container-id) _ _ _) (retract! a)]
[_ (void)]))
(on-layout (layout)))))
(define (solve-tabular-layout container-id)
(define/query-set items
(observe (layout-solution container-id (tabular-layout $row $col) $size _))
(layout-item (cons row col) size))
(define/dataflow items-table
(let* ((specs (map layout-item-spec (set->list (items))))
(row-count (+ 1 (apply max -1 (map car specs))))
(col-count (+ 1 (apply max -1 (map cdr specs))))
(mtx (for/vector [(r row-count)] (make-vector col-count #f))))
(for [(item (items))]
(vector-set! (vector-ref mtx (car (layout-item-spec item)))
(cdr (layout-item-spec item))
item))
mtx))
(define/dataflow table
(for/list [(row (items-table))]
(for/list [(item row)]
(if item (layout-item-size item) weak-fill-box-size))))
(solve-layout* container-id
table
(lambda (layout)
(define mtx (list->vector (map list->vector layout)))
(for [(item (items))]
(match-define (cons row col) (layout-item-spec item))
(assert! (layout-solution container-id
(tabular-layout row col)
(layout-item-size item)
(vector-ref (vector-ref mtx row) col)))))))
;;---------------------------------------------------------------------------
;; TODO: Having pop-up-menu-trigger be a message means that it's not
;; possible to cancel or move the menu once it has been triggered.
;; Consider using the "start" button in the corner to pop up a menu,
;; following which the screen is resized before the menu is dismissed.
;; Currently, the menu will continue to float in an incorrect location
;; rather than following the screen resize. If, however, the trigger
;; for a menu was an assertion, then the menu could track changes in
;; its triggering parameters and could be repositioned without fuss.
(struct pop-up-menu-trigger (menu-id x y x-pin y-pin release-event) #:transparent)
(struct menu-separator (menu-id order) #:transparent)
(struct menu-item (menu-id order image message) #:transparent)
(spawn #:name 'pop-up-menu-driver
(on (message (pop-up-menu-trigger $menu-id $x $y $x-pin $y-pin $release-event))
(run-pop-up-menu menu-id x y x-pin y-pin release-event)))
(define (run-pop-up-menu menu-id pop-up-cursor-x pop-up-cursor-y x-pin y-pin release-event)
(define instance-id (list menu-id (gensym 'instance)))
(define pad (theme-menu-item-padding))
(define pad2 (* pad 2))
(define normal (i:rectangle 1 1 "solid" (theme-menu-item-background-color)))
(define highlight (i:rectangle 1 1 "solid" (theme-menu-item-selected-background-color)))
(define separator (i:rectangle 1 1 "solid" (theme-menu-separator-color)))
(spawn #:name instance-id
(assert (requested-layout-size instance-id #f))
(during (menu-item menu-id $order $sealed-image $msg)
(define item-id (gensym 'item))
(define im (seal-contents sealed-image))
(define imsize (box-size (sizing (+ pad2 (*width im)) 0 0)
(sizing (+ pad2 (*height im)) 0 0)))
(during (layout-solution instance-id (vertical-layout order) imsize $rect)
(match-define (rectangle left top width height) rect)
(assert (sprite #:id item-id #:parent instance-id
0
`((translate ,left ,top)
(push-matrix
(scale ,width ,height)
(touchable (,instance-id ,item-id ,msg) ,in-unit-square?)
(texture ,(if (eq? (selected-item) item-id) highlight normal)))
(push-matrix
(translate ,pad ,pad)
(scale ,(*width im) ,(*height im))
(texture ,im)))))))
(during (menu-separator menu-id $order)
(define sep-id (gensym 'sep))
(during (layout-solution instance-id (vertical-layout order)
(box-size weak-fill-sizing
(sizing (theme-menu-separator-width) 0 0))
$rect)
(match-define (rectangle left top width height) rect)
(assert (sprite #:id sep-id #:parent instance-id
0
`((translate ,left ,top)
(scale ,width ,height)
(texture ,separator))))))
(during (computed-layout-size instance-id $menu-size)
(match-define (box-size (sizing menu-width _ _) (sizing menu-height _ _)) menu-size)
(define offset-x (- pop-up-cursor-x (* x-pin (+ menu-width 2)) -1))
(define offset-y (- pop-up-cursor-y (* y-pin (+ menu-height 2)) -1))
(assert (sprite #:id instance-id
-1
`((translate ,offset-x ,offset-y)
(render-children)))))
(define/query-value selected-item #f (touching `(,instance-id ,$i ,_)) i)
(define/query-value selected-msg #f (touching `(,instance-id ,_ ,$msg)) msg)
(stop-when (message (mouse-event release-event _))
(when (selected-item) (send! (selected-msg))))))
;;---------------------------------------------------------------------------
(define (system-text str [color #f])
(i:text/font str (theme-font-size) (or color "white")
(theme-font) 'default 'normal 'normal #f))
(define (title-font-text str)
(i:text/font str (theme-title-font-size) (theme-title-font-color)
(theme-title-font) 'default 'normal 'normal #f))
(define (menu-item/text menu-id order str message)
(menu-item menu-id order (seal (system-text str (theme-menu-item-color))) message))
;;---------------------------------------------------------------------------
(struct window-state (window-id title state) #:transparent)
(struct raise-widget (id) #:transparent)
(struct top-widget (id) #:transparent)
(define close-icon-i
(parameterize ((theme-font-size (round (* 4/3 (theme-title-font-size)))))
(system-text "×" (theme-title-font-color))))
(define (window-frame id title backdrop-color
#:close-icon? [close-icon? #t]
#:parent [parent-id 'root])
(define title-text-i (title-font-text title))
(define title-text-w (i:image-width title-text-i))
(define title-text-h (i:image-height title-text-i))
(define (title-bar-i focus?) (i:rectangle 1 1 "solid"
(if focus?
(theme-title-bar-selected-color)
(theme-title-bar-color))))
(define close-icon-w (i:image-width close-icon-i))
(define close-icon-h (i:image-height close-icon-i))
(define gap (/ (- (theme-title-bar-height) close-icon-w) 2))
(define backdrop (i:rectangle 1 1 "solid" backdrop-color))
(lambda (z rect focus?)
(match-define (rectangle left top width height) rect)
(sprite #:id id
#:parent parent-id
z
`((translate ,left ,top)
(push-matrix (translate ,(- (theme-window-border-width))
,(- (theme-title-bar-height)))
(scale ,(+ width (* 2 (theme-window-border-width)))
,(+ height (theme-title-bar-height) (theme-window-border-width)))
(touchable (,id window-backdrop) ,in-unit-square?)
(texture ,(title-bar-i focus?)))
(push-matrix (translate 0 ,(- (theme-title-bar-height)))
(scale ,width ,(theme-title-bar-height))
(touchable (,id title-bar) ,in-unit-square?))
(push-matrix (translate ,(- (+ width (theme-window-border-width))
(theme-window-resize-corner-size))
,(- (+ height (theme-window-border-width))
(theme-window-resize-corner-size)))
(scale ,(theme-window-resize-corner-size)
,(theme-window-resize-corner-size))
(touchable (,id resize-corner) ,in-unit-square?))
,@(if close-icon?
`((push-matrix
(translate ,gap ,(- (/ (+ (theme-title-bar-height) close-icon-h) 2)))
(scale ,close-icon-w ,close-icon-h)
(touchable (,id close-icon) ,in-unit-square?)
(texture ,close-icon-i)))
`())
(push-matrix (translate ,(/ (- width title-text-w) 2)
,(- (/ (+ (theme-title-bar-height) title-text-h) 2)))
(scale ,title-text-w ,title-text-h)
(texture ,title-text-i))
(push-matrix (scale ,width ,height)
(texture ,backdrop))
(render-children)))))
(define (open-window window-id window-title x y width height [backdrop-color (hsv->color 200 1 1)]
#:resizable? [resizable? #t])
(define c (window-frame window-id window-title backdrop-color))
(field [z (- (current-inexact-milliseconds))])
(define/query-value touching-title-bar?
#f (touching `(,window-id title-bar)) #t)
(on-start (draggable-mixin touching-title-bar? x y window-id))
(when resizable?
(define/query-value touching-resize-corner?
#f (touching `(,window-id resize-corner)) #t)
(on-start (draggable-mixin touching-resize-corner? width height window-id)))
(define/query-value touching-close-icon?
#f (touching `(,window-id close-icon)) #t)
(stop-when #:when (touching-close-icon?) (message (mouse-event 'left-up _)))
(on (message (raise-widget window-id))
(z (- (current-inexact-milliseconds))))
(define/query-value focus? #f (top-widget window-id) #t)
(define/dataflow bounds (rectangle (x) (y) (width) (height)) #:default zero-rectangle)
(assert (window-state window-id window-title (bounds)))
(assert (c (z) (bounds) (focus?))))
(spawn #:name 'top-widget-monitor
(local-require data/heap)
(define *widget-heap* (make-heap (lambda (a b) (<= (cdr a) (cdr b)))))
(field [widget-heap-version 0])
(define (widget-heap) (begin (widget-heap-version) *widget-heap*)) ;; gross hack
;; ^ this is to cope with the use of mutable data in a field.
;; Field update only registers damage if the field *changes*, as detected by `equal?`.
(define (trigger-dependencies!) (widget-heap-version (+ (widget-heap-version) 1)))
(on (asserted (<sprite> $id 'root $z _))
(heap-add! (widget-heap) (cons id z))
(trigger-dependencies!))
(on (retracted (<sprite> $id 'root $z _))
(heap-remove! (widget-heap) (cons id z))
(trigger-dependencies!))
(assert #:when (positive? (heap-count (widget-heap)))
(top-widget (car (heap-min (widget-heap))))))
;;---------------------------------------------------------------------------
(struct button-click (id mouse-state) #:transparent)
(begin-for-declarations
;; TODO: figure out what it is about (define (f #:x x) x) that
;; mandates begin-for-declarations to hide it from syndicate/lang's
;; local-expansion here :-(
(define (pushbutton label-str x y [w #f] [h #f]
#:shrink-x [shrink-x 0]
#:id id
#:coordinate-map-id [coordinate-map-id #f]
#:parent parent-id
#:trigger-event [trigger-event 'left-up])
(define label (system-text label-str (theme-button-color)))
(define i (i:overlay/align "middle" "middle" label (button-underlay label)))
(define c (costume #:id id #:parent parent-id #:coordinate-map-id coordinate-map-id i))
(define/query-value touching? #f (touching id) #t)
(on #:when (touching?) (message (mouse-event trigger-event $s))
(send! (button-click id s)))
(assert (c 0 (rectangle (x)
(y)
(or (and w (w)) (*width i))
(or (and h (h)) (*height i)))))
(box-size (sizing (*width i) 0 (* shrink-x (*width i))) (sizing (*height i) 0 0))))
;;---------------------------------------------------------------------------
(define (enforce-minimum f v)
(begin/dataflow (when (< (f) v) (f v))))
(begin-for-declarations
(define (message-box title init-x init-y body #:id id)
(define msg (system-text body))
(spawn #:name (list 'message-box id)
(field [x init-x]
[y init-y]
[width (max 250 (*width msg))]
[height (max 100 (*height msg))])
(open-window id title x y width height #:resizable? #f)
(assert ((costume #:parent id msg)
0
(rectangle (/ (- (width) (*width msg)) 2)
(/ (- (height) (*height msg)) 2)
(*width msg)
(*height msg)))))))
(spawn #:name 'test-window
(field [x 140] [y 140] [width 400] [height 300])
(open-window 'w "Window Title" x y width height)
(enforce-minimum width 300)
(enforce-minimum height 300)
(assert (menu-item/text 'testmenu 0 "First item" '(testmenu first)))
(assert (menu-item/text 'testmenu 1 "Second item" '(testmenu second)))
(assert (menu-item/text 'testmenu 2 "Third item" '(testmenu third)))
(during (desktop $width $height)
(on (message `(testmenu ,$which))
(define box-id (gensym 'box))
(message-box #:id box-id
(date->string (seconds->date (current-seconds))
"Selected at ~3")
(random width) (random height)
(format "~a" which))))
(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))))
;;---------------------------------------------------------------------------
(spawn #:name 'fullscreen-menu-item
(field [fullscreen? #f])
(assert (menu-item/text 'system-menu -1
(if (fullscreen?)
"Fullscreen ✓"
"Fullscreen")
'(system-menu toggle-fullscreen)))
(assert (menu-separator 'system-menu -0.9))
(on (message '(system-menu toggle-fullscreen))
(fullscreen? (not (fullscreen?))))
(assert #:when (fullscreen?) (gl-control 'fullscreen)))
(spawn #:name 'quit-menu-item
(assert (menu-item/text 'system-menu 0 "Quit" '(system-menu quit)))
(stop-when (message '(system-menu quit))
(send! (gl-control 'stop)))
(stop-when (message (key-event #\q #t _))
(send! (gl-control 'stop))))
(spawn #:name 'toolbar
(field [window-width 0] [window-height 0])
(on (asserted (desktop $w $h))
(window-width w)
(window-height h))
(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.0 0.0))
weak-fill-box-size
(discard))))
(during (computed-layout-size 'toolbar (box-size (sizing $w _ _) (sizing $h _ _)))
(assert (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))))))
(spawn #: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
#:coordinate-map-id 'start-button
#:trigger-event 'left-down)))
(during (layout-solution 'toolbar (horizontal-layout '(-10.0 0.0)) reqsize
(rectangle $l $t $w $h))
(x l)
(y t)
(during (coordinate-map 'start-button $xform)
(on (message (button-click 'start-button _))
(define pt (- (transform-point xform 0+0i) 1+4i)) ;; padding + unoffset
(send!
(pop-up-menu-trigger 'system-menu (real-part pt) (imag-part pt) 0 1 'left-up))))))
(spawn #:name 'window-list-monitor
(during/spawn (window-state $id $title _)
#:name (list 'window-list id)
(field [x 0] [y 0] [width #f] [height #f])
(define reqsize
(parameterize ((theme-button-y-padding 8)
(theme-button-min-height 0)
(theme-button-background-color (hsv->color 240 1 0.6)))
(pushbutton title x y width height #:id (list 'window-list id) #:parent 'toolbar
#:shrink-x 1
#:trigger-event 'left-down)))
(during (layout-solution 'toolbar (horizontal-layout `(-5.0 ,id)) reqsize
(rectangle $l $t $w $h))
(begin (x l) (y t) (width w) (height h))
(during (top-widget id)
(assert (sprite #:id (list 'window-list id 'highlight)
#:parent (list 'window-list id)
0
`((translate 0 ,(- h 1))
(scale ,w 1)
(texture ,(i:rectangle 1 1 "solid" "white"))))))
(on (message (button-click (list 'window-list id) _))
(send! (raise-widget id))))))
(spawn #:name 'clock
(field [now (current-seconds)])
(on (message (frame-event _ $timestamp _ _))
(define new (current-seconds))
(when (not (= new (now))) (now new)))
(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.0 0.0))
(box-size (sizing (*width (now-im)) 0 0)
(sizing (*height (now-im)) 0 0))
(rectangle $l $t $w $h))
(assert (sprite #:id 'clock #:parent 'toolbar
0
`((translate ,l ,(+ t (/ (- h (*height (now-im))) 2)))
(scale ,(*width (now-im)) ,(*height (now-im)))
(texture ,(now-im)))))))
(spawn-gl-2d-driver)