basis/ui/gadgets/grids/grids.factor

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