syndicate-lang
/
syndicate-gui-2017
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

Reusable layout computation

This commit is contained in:
Tony Garnock-Jones 2016-09-25 19:32:04 -04:00
parent ad177f2d74
commit 6e1819cc3b
2 changed files with 147 additions and 66 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

207
gui.rkt
View File

@ -103,6 +103,100 @@
;;--------------------------------------------------------------------------- ;;---------------------------------------------------------------------------
(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 pop-up-menu-trigger (menu-id x y x-pin y-pin release-event) #:transparent)
(struct menu-separator (menu-id order) #:transparent) (struct menu-separator (menu-id order) #:transparent)
(struct menu-item (menu-id order image message) #:transparent) (struct menu-item (menu-id order image message) #:transparent)
@ -111,82 +205,63 @@
(on (message (pop-up-menu-trigger $menu-id $x $y $x-pin $y-pin $release-event)) (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))) (run-pop-up-menu menu-id x y x-pin y-pin release-event)))
(define (menu-item-order-key i)
(define v (cond [(menu-item? i) (menu-item-order i)]
[(menu-separator? i) (menu-separator-order i)]))
(if (number? v)
(exact->inexact v)
v))
(define (run-pop-up-menu menu-id pop-up-cursor-x pop-up-cursor-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 instance-id (list menu-id (gensym 'instance)))
(define pad (theme-menu-item-padding)) (define pad (theme-menu-item-padding))
(define pad2 (* pad 2)) (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 highlight (i:rectangle 1 1 "solid" (theme-menu-item-selected-background-color)))
(define separator (i:rectangle 1 1 "solid" (theme-menu-separator-color))) (define separator (i:rectangle 1 1 "solid" (theme-menu-separator-color)))
(actor #:name instance-id (actor #:name instance-id
(define/query-set items ($ i (menu-item menu-id _ _ _)) i) (assert (requested-layout-size instance-id #f))
(define/query-set separators ($ s (menu-separator menu-id _)) s) (during (menu-item menu-id $order $sealed-image $msg)
(define/dataflow ordered-items (sort (append (set->list (items)) (define item-id (gensym 'item))
(set->list (separators))) (define im (seal-contents sealed-image))
(order-<? datum-order) (define imsize (box-size (sizing (+ pad2 (*width im)) 0 0)
#:key menu-item-order-key) (sizing (+ pad2 (*height im)) 0 0)))
#:default '()) (during (layout-solution instance-id (vertical-layout order) imsize $rect)
(define/dataflow menu-table (for/list [(i (ordered-items))] (match-define (rectangle left top width height) rect)
(match i (assert (outbound
[(menu-item _ _ (seal im) _) (sprite #:id item-id #:parent instance-id
(list (box-size (sizing (+ pad2 (*width im)) 0 0) 0
(sizing (+ pad2 (*height im)) 0 0)))] `((translate ,left ,top)
[(menu-separator _ _) (push-matrix
(list (box-size (sizing 0 weak-fill 0) (scale ,width ,height)
(sizing (theme-menu-separator-width) 0 0)))]))) (touchable (,instance-id ,item-id ,msg) ,in-unit-square?)
(define/dataflow total-size (table-sizing (menu-table)) (texture ,(if (eq? (selected-item) item-id) highlight normal)))
#:default zero-box-size) (push-matrix
(define (menu-width) (sizing-ideal (box-size-horizontal (total-size)))) (translate ,pad ,pad)
(define (menu-height) (sizing-ideal (box-size-vertical (total-size)))) (scale ,(*width im) ,(*height im))
(define/dataflow layout (table-layout (menu-table) 0 0 (menu-width) (menu-height)) (texture ,im))))))))
#:default '())
(define (render-menu) (during (menu-separator menu-id $order)
(define offset-x (- pop-up-cursor-x (* x-pin (+ (menu-width) 2)) -1)) (define sep-id (gensym 'sep))
(define offset-y (- pop-up-cursor-y (* y-pin (+ (menu-height) 2)) -1)) (during (layout-solution instance-id (vertical-layout order)
(sprite #:id instance-id (box-size weak-fill-sizing
-1 (sizing (theme-menu-separator-width) 0 0))
`((translate ,offset-x ,offset-y) $rect)
(push-matrix (scale ,(menu-width) ,(menu-height)) (match-define (rectangle left top width height) rect)
(texture ,(i:rectangle 1 1 "solid" (theme-menu-item-background-color)))) (assert (outbound
,@(for/list [(item (ordered-items)) (row (layout))] (sprite #:id sep-id #:parent instance-id
(match-define (rectangle left top width height) (car row)) 0
(match item `((translate ,left ,top)
[(menu-item _ _ (seal im) _) (scale ,width ,height)
`(begin (texture ,separator)))))))
(push-matrix (translate ,left ,top)
(scale ,width ,height)
(touchable (,instance-id ,(seal item)) ,in-unit-square?)
,@(if (eq? (selected-item) item)
`((texture ,highlight))
`()))
(push-matrix (translate ,(+ left pad) ,(+ top pad))
(scale ,(*width im) ,(*height im))
(texture ,im)))]
[(menu-separator _ _)
`(push-matrix (translate ,left ,top)
(scale ,width ,height)
(texture ,separator))]))
(render-children))))
(define/query-value selected-item* #f (inbound (touching `(,instance-id ,$sealed-item))) (during (computed-layout-size instance-id $menu-size)
(seal-contents sealed-item)) (match-define (box-size (sizing menu-width _ _) (sizing menu-height _ _)) menu-size)
(field [selected-item #f]) (define offset-x (- pop-up-cursor-x (* x-pin (+ menu-width 2)) -1))
(begin/dataflow (when (not (eq? (selected-item) (selected-item*))) (define offset-y (- pop-up-cursor-y (* y-pin (+ menu-height 2)) -1))
(selected-item (selected-item*)))) (assert (outbound
(sprite #:id instance-id
-1
`((translate ,offset-x ,offset-y)
(render-children))))))
(assert (outbound (render-menu))) (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 _))) (stop-when (message (inbound (mouse-event release-event _)))
(when (selected-item) (when (selected-item) (send! (selected-msg))))))
(send! (menu-item-message (selected-item)))))
(on (asserted ($ s (mouse-state _ _ _ _ _)))
(log-info "MENU ~v: ~v" menu-id s))))
;;--------------------------------------------------------------------------- ;;---------------------------------------------------------------------------
@ -350,7 +425,7 @@
;;--------------------------------------------------------------------------- ;;---------------------------------------------------------------------------
(actor #:name 'fullscreen-menu-item (actor #:name 'fullscreen-menu-item
(field [fullscreen? #t]) (field [fullscreen? #f])
(assert (menu-item/text 'system-menu -1 (assert (menu-item/text 'system-menu -1
(if (fullscreen?) (if (fullscreen?)
"Fullscreen ✓" "Fullscreen ✓"

6
layout/sizing.rkt
View File

@ -8,7 +8,9 @@
weak-fill weak-fill
zero-sizing zero-sizing
weak-fill-sizing
zero-box-size zero-box-size
weak-fill-box-size
zero-rectangle zero-rectangle
fill+ fill+
@ -54,8 +56,12 @@
(define zero-sizing (sizing 0 0 0)) (define zero-sizing (sizing 0 0 0))
(define weak-fill-sizing (sizing 0 weak-fill 0))
(define zero-box-size (box-size zero-sizing zero-sizing)) (define zero-box-size (box-size zero-sizing zero-sizing))
(define weak-fill-box-size (box-size weak-fill-sizing weak-fill-sizing))
(define zero-rectangle (rectangle 0 0 0 0)) (define zero-rectangle (rectangle 0 0 0 0))
;;--------------------------------------------------------------------------- ;;---------------------------------------------------------------------------