basis/ui/gadgets/packs/packs.factor

   1 ! Copyright (C) 2005, 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: sequences ui.gadgets kernel math math.functions
   4 math.vectors math.order math.geometry.rect namespaces accessors
   5 fry ;
   6 IN: ui.gadgets.packs
   7
   8 TUPLE: pack < gadget
   9 { align initial: 0 } { fill initial: 0 } { gap initial: { 0 0 } } ;
  10
  11 : packed-dim-2 ( gadget sizes -- list )
  12     swap [ dim>> ] [ fill>> ] bi '[ _ over v- _ v*n v+ ] map ;
  13
  14 : orient ( seq1 seq2 gadget -- seq )
  15     orientation>> '[ _ set-axis ] 2map ;
  16
  17 : packed-dims ( gadget sizes -- seq )
  18     [ packed-dim-2 ] [ nip ] [ drop ] 2tri orient ;
  19
  20 : gap-locs ( gap sizes -- seq )
  21     { 0 0 } [ v+ over v+ ] accumulate 2nip ;
  22
  23 : aligned-locs ( gadget sizes -- seq )
  24     [ [ [ align>> ] [ dim>> ] bi ] dip v- n*v ] with map ;
  25
  26 : packed-locs ( gadget sizes -- seq )
  27     [ aligned-locs ] [ [ gap>> ] dip gap-locs ] [ drop ] 2tri orient ;
  28
  29 : round-dims ( seq -- newseq )
  30     { 0 0 } swap
  31     [ swap v- dup [ ceiling >fixnum ] map [ swap v- ] keep ] map
  32     nip ;
  33
  34 : pack-layout ( pack sizes -- )
  35     round-dims over children>>
  36     [ dupd packed-dims ] dip
  37     [ [ (>>dim) ] 2each ]
  38     [ [ packed-locs ] dip [ (>>loc) ] 2each ] 2bi ;
  39
  40 : <pack> ( orientation -- pack )
  41     pack new-gadget
  42         swap >>orientation ;
  43
  44 : <pile> ( -- pack ) { 0 1 } <pack> ;
  45
  46 : <filled-pile> ( -- pack ) <pile> 1 >>fill ;
  47
  48 : <shelf> ( -- pack ) { 1 0 } <pack> ;
  49
  50 : gap-dims ( sizes gadget -- seeq )
  51     [ [ dim-sum ] [ length 1 [-] ] bi ] [ gap>> ] bi* n*v v+ ;
  52
  53 : pack-pref-dim ( gadget sizes -- dim )
  54     [ nip max-dim ]
  55     [ swap gap-dims ]
  56     [ drop orientation>> ]
  57     2tri set-axis ;
  58
  59 M: pack pref-dim*
  60     dup children>> pref-dims pack-pref-dim ;
  61
  62 M: pack layout*
  63     dup children>> pref-dims pack-layout ;
  64
  65 M: pack children-on ( rect gadget -- seq )
  66     dup orientation>> swap children>>
  67     [ fast-children-on ] keep <slice> ;