#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-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 ( $id 'root $z _))) (heap-add! (widget-heap) (cons id z)) (widget-heap (widget-heap))) ;; trigger dependencies (on (retracted (outbound ( $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)))