#lang imperative-syndicate

(require racket/set)
(require data/order)
(require srfi/19)
(require (prefix-in i: 2htdp/image))
(require (prefix-in p: pict))
(require syndicate-gl/affine)
(require "layout/main.rkt")
(require "hsv.rkt")
(require imperative-syndicate/bag)
(require imperative-syndicate/pattern)

(require/activate imperative-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 (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)

;;---------------------------------------------------------------------------

(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 (window $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 (window $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)
