basis/ui/gadgets/packs/packs.factor

   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 ;
   6 IN: ui.gadgets.packs
   7
   8 TUPLE: pack < gadget
   9 { align initial: 0 } { fill initial: 0 } { gap initial: { 0 0 } } ;
  10
  11 <PRIVATE
  12
  13 : (packed-dims) ( gadget sizes -- list )
  14     swap [ dim>> ] [ fill>> ] bi '[ _ over v- _ v*n v+ ] map ;
  15
  16 : orient ( seq1 seq2 gadget -- seq )
  17     orientation>> '[ _ set-axis ] 2map ;
  18
  19 : packed-dims ( gadget sizes -- seq )
  20     [ (packed-dims) ] [ nip ] [ drop ] 2tri orient ;
  21
  22 : gap-locs ( sizes gap -- seq )
  23     [ { 0 0 } ] dip '[ v+ _ v+ ] accumulate nip ;
  24
  25 : numerically-aligned-locs ( sizes pack -- seq )
  26     [ align>> ] [ dim>> ] bi '[ [ _ _ ] dip v- [ * >integer ] with map ] map ;
  27
  28 : baseline-aligned-locs ( pack -- seq )
  29     children>> align-baselines [ 0 swap 2array ] map ;
  30
  31 : aligned-locs ( sizes pack -- seq )
  32     dup align>> +baseline+ eq?
  33     [ nip baseline-aligned-locs ]
  34     [ numerically-aligned-locs ]
  35     if ;
  36
  37 : packed-locs ( sizes pack -- seq )
  38     [ aligned-locs ] [ gap>> gap-locs ] [ nip ] 2tri orient ;
  39
  40 : round-dims ( seq -- newseq )
  41     [ { 0 0 } ] dip
  42     [ swap v- dup [ ceiling ] map [ swap v- ] keep ] map
  43     nip ;
  44
  45 PRIVATE>
  46
  47 : pack-layout ( pack sizes -- )
  48     [ round-dims packed-dims ] [ drop ] 2bi
  49     [ children>> [ dim<< ] 2each ]
  50     [ [ packed-locs ] [ children>> ] bi [ loc<< ] 2each ] 2bi ;
  51
  52 : <pack> ( orientation -- pack )
  53     pack new
  54         swap >>orientation ;
  55
  56 : <pile> ( -- pack ) vertical <pack> ;
  57
  58 : <filled-pile> ( -- pack ) <pile> 1 >>fill ;
  59
  60 : <shelf> ( -- pack ) horizontal <pack> ;
  61
  62 <PRIVATE
  63
  64 : gap-dim ( pack -- dim )
  65     [ gap>> ] [ children>> length 1 [-] ] bi v*n ;
  66
  67 : max-pack-dim ( pack sizes -- dim )
  68     over align>> +baseline+ eq?
  69     [ [ children>> ] dip measure-height 0 swap 2array ] [ nip max-dim ] if ;
  70
  71 : pack-pref-dim ( pack sizes -- dim )
  72     [ max-pack-dim ]
  73     [ [ gap-dim ] [ dim-sum ] bi* v+ ]
  74     [ drop orientation>> ]
  75     2tri set-axis ;
  76
  77 M: pack pref-dim*
  78     dup children>> pref-dims pack-pref-dim ;
  79
  80 : vertical-baseline ( pack -- y )
  81     children>> [ f ] [ first baseline ] if-empty ;
  82
  83 : horizontal-baseline ( pack -- y )
  84     children>> dup pref-dims measure-metrics drop ;
  85
  86 : pack-cap-height ( pack -- n )
  87     children>> [ cap-height ] map ?supremum ;
  88
  89 PRIVATE>
  90
  91 M: pack baseline
  92     dup orientation>> {
  93         { vertical [ vertical-baseline ] }
  94         { horizontal [ horizontal-baseline ] }
  95     } case ;
  96
  97 M: pack cap-height pack-cap-height ;
  98
  99 M: pack layout*
 100     dup children>> pref-dims pack-layout ;
 101
 102 M: pack children-on ( rect gadget -- seq )
 103     [ orientation>> ] [ children>> ] bi [ loc>> ] fast-children-on ;