Reusable layout computation
This commit is contained in:
parent
ad177f2d74
commit
6e1819cc3b
203
gui.rkt
203
gui.rkt
|
@ -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 menu-separator (menu-id order) #: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))
|
||||
(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 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
|
||||
(define/query-set items ($ i (menu-item menu-id _ _ _)) i)
|
||||
(define/query-set separators ($ s (menu-separator menu-id _)) s)
|
||||
(define/dataflow ordered-items (sort (append (set->list (items))
|
||||
(set->list (separators)))
|
||||
(order-<? datum-order)
|
||||
#:key menu-item-order-key)
|
||||
#:default '())
|
||||
(define/dataflow menu-table (for/list [(i (ordered-items))]
|
||||
(match i
|
||||
[(menu-item _ _ (seal im) _)
|
||||
(list (box-size (sizing (+ pad2 (*width im)) 0 0)
|
||||
(sizing (+ pad2 (*height im)) 0 0)))]
|
||||
[(menu-separator _ _)
|
||||
(list (box-size (sizing 0 weak-fill 0)
|
||||
(sizing (theme-menu-separator-width) 0 0)))])))
|
||||
(define/dataflow total-size (table-sizing (menu-table))
|
||||
#:default zero-box-size)
|
||||
(define (menu-width) (sizing-ideal (box-size-horizontal (total-size))))
|
||||
(define (menu-height) (sizing-ideal (box-size-vertical (total-size))))
|
||||
(define/dataflow layout (table-layout (menu-table) 0 0 (menu-width) (menu-height))
|
||||
#:default '())
|
||||
(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))))))))
|
||||
|
||||
(define (render-menu)
|
||||
(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))
|
||||
(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)
|
||||
(push-matrix (scale ,(menu-width) ,(menu-height))
|
||||
(texture ,(i:rectangle 1 1 "solid" (theme-menu-item-background-color))))
|
||||
,@(for/list [(item (ordered-items)) (row (layout))]
|
||||
(match-define (rectangle left top width height) (car row))
|
||||
(match item
|
||||
[(menu-item _ _ (seal im) _)
|
||||
`(begin
|
||||
(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))))
|
||||
(render-children))))))
|
||||
|
||||
(define/query-value selected-item* #f (inbound (touching `(,instance-id ,$sealed-item)))
|
||||
(seal-contents sealed-item))
|
||||
(field [selected-item #f])
|
||||
(begin/dataflow (when (not (eq? (selected-item) (selected-item*)))
|
||||
(selected-item (selected-item*))))
|
||||
|
||||
(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 _)))
|
||||
(when (selected-item)
|
||||
(send! (menu-item-message (selected-item)))))
|
||||
(on (asserted ($ s (mouse-state _ _ _ _ _)))
|
||||
(log-info "MENU ~v: ~v" menu-id s))))
|
||||
(when (selected-item) (send! (selected-msg))))))
|
||||
|
||||
;;---------------------------------------------------------------------------
|
||||
|
||||
|
@ -350,7 +425,7 @@
|
|||
;;---------------------------------------------------------------------------
|
||||
|
||||
(actor #:name 'fullscreen-menu-item
|
||||
(field [fullscreen? #t])
|
||||
(field [fullscreen? #f])
|
||||
(assert (menu-item/text 'system-menu -1
|
||||
(if (fullscreen?)
|
||||
"Fullscreen ✓"
|
||||
|
|
|
@ -8,7 +8,9 @@
|
|||
|
||||
weak-fill
|
||||
zero-sizing
|
||||
weak-fill-sizing
|
||||
zero-box-size
|
||||
weak-fill-box-size
|
||||
zero-rectangle
|
||||
|
||||
fill+
|
||||
|
@ -54,8 +56,12 @@
|
|||
|
||||
(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 weak-fill-box-size (box-size weak-fill-sizing weak-fill-sizing))
|
||||
|
||||
(define zero-rectangle (rectangle 0 0 0 0))
|
||||
|
||||
;;---------------------------------------------------------------------------
|
||||
|
|
Loading…
Reference in New Issue