You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
633 lines
30 KiB
633 lines
30 KiB
#lang syndicate/actor |
|
|
|
(require racket/set) |
|
(require data/order) |
|
(require srfi/19) |
|
(require (prefix-in i: 2htdp/image)) |
|
(require (prefix-in p: pict)) |
|
(require syndicate-gl/2d) |
|
(require syndicate-gl/affine) |
|
(require "layout/main.rkt") |
|
(require "hsv.rkt") |
|
|
|
;;--------------------------------------------------------------------------- |
|
|
|
(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 (inbound (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 (inbound (mouse-event 'motion (mouse-state $mx $my _ _ _)))) |
|
(x (- mx dx)) |
|
(y (- my dy))) |
|
(stop-when (message (inbound (mouse-event 'left-up _))) (idle)) |
|
(stop-when (message (inbound (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 (inbound (touching 'root)) #t) |
|
(on #:when (touching?) (message (inbound (mouse-event 'right-down (mouse-state $x $y _ _ _)))) |
|
(send! (pop-up-menu-trigger 'system-menu x y 0 0.5 'right-up))) |
|
(during (inbound (window $width $height)) |
|
(assert (outbound (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) |
|
(define ctor (if vertical? vertical-layout horizontal-layout)) |
|
(define/query-set items |
|
(observe (layout-solution container-id (ctor $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 |
|
(ctor (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 |
|
(retract! (layout-solution container-id ? ? ?)) |
|
(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 (outbound |
|
(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 (outbound |
|
(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 (outbound |
|
(sprite #:id instance-id |
|
-1 |
|
`((translate ,offset-x ,offset-y) |
|
(render-children)))))) |
|
|
|
(define/query-value selected-item #f (inbound (touching `(,instance-id ,$i ,_))) i) |
|
(define/query-value selected-msg #f (inbound (touching `(,instance-id ,_ ,$msg))) msg) |
|
(stop-when (message (inbound (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 (inbound (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 (inbound (touching `(,window-id resize-corner))) #t) |
|
(on-start (draggable-mixin touching-resize-corner? width height window-id))) |
|
|
|
(define/query-value touching-close-icon? |
|
#f (inbound (touching `(,window-id close-icon))) #t) |
|
(stop-when #:when (touching-close-icon?) (message (inbound (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 (outbound (c (z) (bounds) (focus?))))) |
|
|
|
(spawn #:name 'top-widget-monitor |
|
(local-require data/heap) |
|
(field [widget-heap (make-heap (lambda (a b) (<= (cdr a) (cdr b))))]) |
|
(on (asserted (outbound (<sprite> $id 'root $z _))) |
|
(heap-add! (widget-heap) (cons id z)) |
|
(widget-heap (widget-heap))) ;; trigger dependencies |
|
(on (retracted (outbound (<sprite> $id 'root $z _))) |
|
(heap-remove! (widget-heap) (cons id z)) |
|
(widget-heap (widget-heap))) ;; 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 (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) |
|
(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 (outbound ((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 (inbound (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? #t]) |
|
(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?) (outbound 'fullscreen))) |
|
|
|
(spawn #:name 'quit-menu-item |
|
(assert (menu-item/text 'system-menu 0 "Quit" '(system-menu quit))) |
|
(stop-when (message '(system-menu quit)) |
|
(spawn (assert (outbound 'stop)))) |
|
(stop-when (message (inbound (key-event #\q #t _))) |
|
(spawn (assert (outbound 'stop))))) |
|
|
|
(spawn #:name 'toolbar |
|
|
|
(field [window-width 0] [window-height 0]) |
|
(on (asserted (inbound (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 _))) |
|
|
|
(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))))))) |
|
|
|
(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 (inbound (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 (outbound (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 (inbound (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 (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)))
|
|
|