463 lines
21 KiB
Racket
463 lines
21 KiB
Racket
#lang syndicate/actor
|
||
|
||
(require racket/set)
|
||
(require data/order)
|
||
(require (prefix-in i: 2htdp/image))
|
||
(require (prefix-in p: pict))
|
||
(require syndicate-gl/2d)
|
||
(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 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] 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?))
|
||
`())
|
||
(texture ,i
|
||
,(- (/ translate-x scale-w))
|
||
,(- (/ translate-y scale-h))
|
||
,(/ sw scale-w)
|
||
,(/ sh scale-h)
|
||
))
|
||
(render-children)))))
|
||
|
||
(define (draggable-mixin touching? x y z)
|
||
(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)
|
||
(z (- (current-inexact-milliseconds)))
|
||
(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))
|
||
|
||
(actor #: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)))
|
||
|
||
;;---------------------------------------------------------------------------
|
||
|
||
(struct horizontal-layout (key) #:transparent)
|
||
(struct vertical-layout (key) #:transparent)
|
||
(struct tabular-layout (row col) #:transparent)
|
||
|
||
(struct requested-layout-size (container-id size) #:transparent)
|
||
(struct computed-layout-size (container-id size) #:transparent)
|
||
(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))
|
||
|
||
(actor #:name 'layout-driver
|
||
(during/actor (observe (layout-solution $container-id (horizontal-layout _) _ _))
|
||
#:name (list 'horizontal-layout container-id)
|
||
(solve-hv-layout #f container-id))
|
||
(during/actor (observe (layout-solution $container-id (vertical-layout _) _ _))
|
||
#:name (list 'vertical-layout container-id)
|
||
(solve-hv-layout #t container-id))
|
||
(during/actor (observe (layout-solution $container-id (tabular-layout _ _) _ _))
|
||
#:name (list 'tabular-layout container-id)
|
||
(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 (solve-layout* container-id table on-layout)
|
||
(during (requested-layout-size container-id $reqsize)
|
||
(define/dataflow total-size (or 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)))))))
|
||
|
||
;;---------------------------------------------------------------------------
|
||
|
||
(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)
|
||
|
||
(actor #: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)))
|
||
(actor #: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 state) #:transparent)
|
||
(struct raise-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 (i:rectangle 1 1 "solid" (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)
|
||
(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))
|
||
(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 z))
|
||
|
||
(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 z)))
|
||
|
||
(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/dataflow bounds (rectangle (x) (y) (width) (height)) #:default zero-rectangle)
|
||
(assert (window-state window-id (bounds)))
|
||
(assert (outbound (c (z) (bounds)))))
|
||
|
||
;;---------------------------------------------------------------------------
|
||
|
||
(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
|
||
#:id id
|
||
#: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 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 (*width i) (*height i)))))))
|
||
|
||
;;---------------------------------------------------------------------------
|
||
|
||
(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))
|
||
(actor #: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))))))))
|
||
|
||
(actor #: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
|
||
"Menu item selected" (random width) (random height)
|
||
(format "~a" which))))
|
||
|
||
(pushbutton "Click me" 100 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))))
|
||
|
||
;;---------------------------------------------------------------------------
|
||
|
||
(actor #: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?) (outbound 'fullscreen)))
|
||
|
||
(actor #:name 'quit-menu-item
|
||
(assert (menu-item/text 'system-menu 0 "Quit" '(system-menu quit)))
|
||
(stop-when (message '(system-menu quit))
|
||
(actor (assert (outbound 'stop))))
|
||
(stop-when (message (inbound (key-event #\q #t _)))
|
||
(actor (assert (outbound 'stop)))))
|
||
|
||
;; (actor #:name 'toolbar
|
||
|
||
;; (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))))))
|
||
|
||
(module+ main
|
||
(current-ground-dataspace (2d-dataspace)))
|