Browse Source

Reusable layout computation

main
Tony Garnock-Jones 5 years ago
parent
commit
6e1819cc3b
  1. 213
      gui.rkt
  2. 6
      layout/sizing.rkt

213
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 '())
(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))
(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))))
(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)))
(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! (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 ✓"

6
layout/sizing.rkt

@ -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…
Cancel
Save