extra/ui/gadgets/grids/grids.factor

   1 ! Copyright (C) 2006 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: arrays kernel math namespaces sequences words io
   4 io.streams.string math.vectors ui.gadgets ;
   5 IN: ui.gadgets.grids
   6
   7 TUPLE: grid children gap fill? ;
   8
   9 : set-grid-children* ( children grid -- )
  10     [ set-grid-children ] 2keep >r concat r> add-gadgets ;
  11
  12 : <grid> ( children -- grid )
  13     grid construct-gadget
  14     [ set-grid-children* ] keep
  15     { 0 0 } over set-grid-gap
  16     t over set-grid-fill? ;
  17
  18 : grid-child ( grid i j -- gadget ) rot grid-children nth nth ;
  19
  20 : grid-add ( gadget grid i j -- )
  21     >r >r 2dup add-gadget r> r>
  22     3dup grid-child unparent rot grid-children nth set-nth ;
  23
  24 : grid-remove ( grid i j -- )
  25     >r >r >r <gadget> r> r> r> grid-add ;
  26
  27 : pref-dim-grid ( grid -- dims )
  28     grid-children [ [ pref-dim ] map ] map ;
  29
  30 : (compute-grid) [ max-dim ] map ;
  31
  32 : compute-grid ( grid -- horiz vert )
  33     pref-dim-grid dup flip (compute-grid) swap (compute-grid) ;
  34
  35 : (pair-up) ( horiz vert -- dim )
  36     >r first r> second 2array ;
  37
  38 : pair-up ( horiz vert -- dims )
  39     [ [ (pair-up) ] curry map ] curry* map ;
  40
  41 : add-gaps ( gap seq -- newseq )
  42     [ v+ ] curry* map ;
  43
  44 : gap-sum ( gap seq -- newseq )
  45     dupd add-gaps dim-sum v+ ;
  46
  47 M: grid pref-dim*
  48     dup grid-gap swap compute-grid >r over r>
  49     gap-sum >r gap-sum r> (pair-up) ;
  50
  51 : do-grid ( dims grid quot -- )
  52     -rot grid-children
  53     [ [ pick call ] 2each ] 2each
  54     drop ; inline
  55
  56 : grid-positions ( grid dims -- locs )
  57     >r grid-gap dup r> add-gaps swap [ v+ ] accumulate nip ;
  58
  59 : position-grid ( grid horiz vert -- )
  60     pick >r
  61     >r over r> grid-positions >r grid-positions r>
  62     pair-up r> [ set-rect-loc ] do-grid ;
  63
  64 : resize-grid ( grid horiz vert -- )
  65     pick grid-fill? [
  66         pair-up swap [ set-layout-dim ] do-grid
  67     ] [
  68         2drop grid-children [ [ prefer ] each ] each
  69     ] if ;
  70
  71 : grid-layout ( grid horiz vert -- )
  72     [ position-grid ] 3keep resize-grid ;
  73
  74 M: grid layout* dup compute-grid grid-layout ;
  75
  76 M: grid children-on ( rect gadget -- seq )
  77     dup gadget-children empty? [
  78         2drop f
  79     ] [
  80         { 0 1 } swap grid-children
  81         [ 0 <column> fast-children-on ] keep
  82         <slice> concat
  83     ] if ;
  84
  85 M: grid gadget-text*
  86     grid-children
  87     [ [ gadget-text ] map ] map format-table
  88     [ CHAR: \n , ] [ % ] interleave ;