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