1 ! Copyright (C) 2006, 2010 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: arrays kernel math math.order namespaces make sequences
4 words io math.vectors ui.gadgets ui.baseline-alignment columns
5 accessors strings.tables math.rectangles fry ;
10 { gap initial: { 0 0 } }
11 { fill? initial: t } ;
13 : new-grid ( children class -- grid )
15 swap [ >>grid ] [ concat add-gadgets ] bi ; inline
17 : <grid> ( children -- grid )
22 : grid@ ( grid pair -- col# row )
23 swap [ first2 ] [ grid>> ] bi* nth ;
27 : grid-child ( grid pair -- gadget ) grid@ nth ;
29 : grid-add ( grid child pair -- grid )
30 [ nip grid-child unparent ]
32 [ swapd grid@ set-nth ] 3tri ;
34 : grid-remove ( grid pair -- grid ) [ <gadget> ] dip grid-add ;
38 TUPLE: cell pref-dim baseline cap-height ;
40 : <cell> ( gadget -- cell )
41 [ pref-dim ] [ baseline ] [ cap-height ] tri cell boa ;
43 M: cell baseline baseline>> ;
45 M: cell cap-height cap-height>> ;
47 TUPLE: grid-layout grid gap fill? row-heights column-widths ;
49 : iterate-cell-dims ( cells quot -- seq )
50 '[ [ pref-dim>> @ ] [ max ] map-reduce ] map ; inline
52 : row-heights ( grid-layout -- heights )
53 [ grid>> ] [ fill?>> ] bi
54 [ [ second ] iterate-cell-dims ]
55 [ [ dup [ pref-dim>> ] map measure-height ] map ]
58 : column-widths ( grid-layout -- widths )
59 grid>> flip [ first ] iterate-cell-dims ;
61 : <grid-layout> ( grid -- grid-layout )
64 [ grid>> [ [ <cell> ] map ] map >>grid ]
68 dup row-heights >>row-heights
69 dup column-widths >>column-widths ;
71 : accumulate-cell-dims ( seq gap -- n ns )
72 dup '[ + _ + ] accumulate ;
74 : accumulate-cell-xs ( grid-layout -- x xs )
75 [ column-widths>> ] [ gap>> first ] bi
76 accumulate-cell-dims ;
78 : accumulate-cell-ys ( grid-layout -- y ys )
79 [ row-heights>> ] [ gap>> second ] bi
80 accumulate-cell-dims ;
82 : grid-pref-dim ( grid-layout -- dim )
83 [ accumulate-cell-xs drop ]
84 [ accumulate-cell-ys drop ]
87 M: grid pref-dim* <grid-layout> grid-pref-dim ;
89 : (compute-cell-locs) ( grid-layout -- locs )
90 [ accumulate-cell-xs nip ]
91 [ accumulate-cell-ys nip ]
92 bi cartesian-product flip ;
94 : adjust-for-baseline ( row-locs row-cells -- row-locs' )
95 align-baselines [ 0 swap 2array v+ ] 2map ;
97 : cell-locs ( grid-layout -- locs )
99 [ (compute-cell-locs) ] [
100 [ (compute-cell-locs) ] [ grid>> ] bi
101 [ adjust-for-baseline ] 2map
104 : cell-dims ( grid-layout -- dims )
106 [ [ column-widths>> ] [ row-heights>> ] bi cartesian-product flip ]
107 [ grid>> [ [ pref-dim>> ] map ] map ]
110 : grid-layout ( children grid-layout -- )
111 [ cell-locs ] [ cell-dims ] bi
112 [ [ <rect> swap set-rect-bounds ] 3each ] 3each ;
114 M: grid layout* [ grid>> ] [ <grid-layout> ] bi grid-layout ;
116 M: grid children-on ( rect gadget -- seq )
117 dup children>> empty? [ 2drop f ] [
119 [ grid>> ] [ dim>> ] bi
120 '[ _ [ loc>> vmin ] reduce ] fast-children-on
126 [ [ gadget-text ] map ] map format-table
127 [ CHAR: \n , ] [ % ] interleave ;