1 ! Copyright (C) 2005, 2010 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: sequences ui.gadgets ui.baseline-alignment
4 ui.baseline-alignment.private kernel math math.functions math.vectors
5 math.order math.rectangles namespaces accessors fry combinators arrays ;
9 { align initial: 0 } { fill initial: 0 } { gap initial: { 0 0 } } ;
13 : (packed-dims) ( gadget sizes -- list )
14 swap [ dim>> ] [ fill>> ] bi '[ _ over v- _ v*n v+ ] map ;
16 : orient ( seq1 seq2 gadget -- seq )
17 orientation>> '[ _ set-axis ] 2map ;
19 : packed-dims ( gadget sizes -- seq )
20 [ (packed-dims) ] [ nip ] [ drop ] 2tri orient ;
22 : gap-locs ( sizes gap -- seq )
23 [ { 0 0 } ] dip '[ v+ _ v+ ] accumulate nip ;
25 : numerically-aligned-locs ( sizes pack -- seq )
26 [ align>> ] [ dim>> ] bi '[ [ _ _ ] dip v- [ * >integer ] with map ] map ;
28 : baseline-aligned-locs ( pack -- seq )
29 children>> align-baselines [ 0 swap 2array ] map ;
31 : aligned-locs ( sizes pack -- seq )
32 dup align>> +baseline+ eq?
33 [ nip baseline-aligned-locs ]
34 [ numerically-aligned-locs ]
37 : packed-locs ( sizes pack -- seq )
38 [ aligned-locs ] [ gap>> gap-locs ] [ nip ] 2tri orient ;
40 : round-dims ( seq -- newseq )
42 [ swap v- dup [ ceiling ] map [ swap v- ] keep ] map
47 : pack-layout ( pack sizes -- )
48 [ round-dims packed-dims ] [ drop ] 2bi
49 [ children>> [ (>>dim) ] 2each ]
50 [ [ packed-locs ] [ children>> ] bi [ (>>loc) ] 2each ] 2bi ;
52 : <pack> ( orientation -- pack )
56 : <pile> ( -- pack ) vertical <pack> ;
58 : <filled-pile> ( -- pack ) <pile> 1 >>fill ;
60 : <shelf> ( -- pack ) horizontal <pack> ;
64 : gap-dim ( pack -- dim )
65 [ gap>> ] [ children>> length 1 [-] ] bi v*n ;
67 : max-pack-dim ( pack sizes -- dim )
68 over align>> +baseline+ eq?
69 [ [ children>> ] dip measure-height 0 swap 2array ] [ nip max-dim ] if ;
71 : pack-pref-dim ( pack sizes -- dim )
73 [ [ gap-dim ] [ dim-sum ] bi* v+ ]
74 [ drop orientation>> ]
78 dup children>> pref-dims pack-pref-dim ;
80 : vertical-baseline ( pack -- y )
81 children>> [ f ] [ first baseline ] if-empty ;
83 : horizontal-baseline ( pack -- y )
84 children>> dup pref-dims measure-metrics drop ;
86 : pack-cap-height ( pack -- n )
87 children>> [ cap-height ] map ?supremum ;
93 { vertical [ vertical-baseline ] }
94 { horizontal [ horizontal-baseline ] }
97 M: pack cap-height pack-cap-height ;
100 dup children>> pref-dims pack-layout ;
102 M: pack children-on ( rect gadget -- seq )
103 [ orientation>> ] [ children>> ] bi [ loc>> ] fast-children-on ;