basis/ui/gadgets/grids/grids.factor

   1 ! Copyright (C) 2006, 2009 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: arrays kernel math math.order namespaces make sequences words io
   4 math.vectors ui.gadgets ui.baseline-alignment columns accessors strings.tables
   5 math.rectangles fry ;
   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
  15         swap [ >>grid ] [ concat add-gadgets ] bi ; inline
  16
  17 : <grid> ( children -- grid )
  18     grid new-grid ;
  19
  20 <PRIVATE
  21
  22 : grid@ ( grid pair -- col# row )
  23     swap [ first2 ] [ grid>> ] bi* nth ;
  24
  25 PRIVATE>
  26
  27 : grid-child ( grid pair -- gadget ) grid@ nth ;
  28
  29 : grid-add ( grid child pair -- grid )
  30     [ nip grid-child unparent ] [ drop add-gadget ] [ swapd grid@ set-nth ] 3tri ;
  31
  32 : grid-remove ( grid pair -- grid ) [ <gadget> ] dip grid-add ;
  33
  34 <PRIVATE
  35
  36 : cross-zip ( seq1 seq2 -- seq1xseq2 )
  37     [ [ 2array ] with map ] curry map ;
  38
  39 TUPLE: cell pref-dim baseline cap-height ;
  40
  41 : <cell> ( gadget -- cell )
  42     [ pref-dim ] [ baseline ] [ cap-height ] tri cell boa ;
  43
  44 M: cell baseline baseline>> ;
  45
  46 M: cell cap-height cap-height>> ;
  47
  48 TUPLE: grid-layout grid gap fill? row-heights column-widths ;
  49
  50 : iterate-cell-dims ( cells quot -- seq )
  51     '[ [ pref-dim>> @ ] [ max ] map-reduce ] map ; inline
  52
  53 : row-heights ( grid-layout -- heights )
  54     [ grid>> ] [ fill?>> ] bi
  55     [ [ second ] iterate-cell-dims ]
  56     [ [ dup [ pref-dim>> ] map measure-height ] map ]
  57     if ;
  58
  59 : column-widths ( grid-layout -- widths )
  60     grid>> flip [ first ] iterate-cell-dims ;
  61
  62 : <grid-layout> ( grid -- grid-layout )
  63     \ grid-layout new
  64         swap
  65         [ grid>> [ [ <cell> ] map ] map >>grid ]
  66         [ fill?>> >>fill? ]
  67         [ gap>> >>gap ]
  68         tri
  69         dup row-heights >>row-heights
  70         dup column-widths >>column-widths ;
  71
  72 : accumulate-cell-dims ( seq gap -- n ns )
  73     dup '[ + _ + ] accumulate ;
  74
  75 : accumulate-cell-xs ( grid-layout -- x xs )
  76     [ column-widths>> ] [ gap>> first ] bi
  77     accumulate-cell-dims ;
  78
  79 : accumulate-cell-ys ( grid-layout -- y ys )
  80     [ row-heights>> ] [ gap>> second ] bi
  81     accumulate-cell-dims ;
  82
  83 : grid-pref-dim ( grid-layout -- dim )
  84     [ accumulate-cell-xs drop ]
  85     [ accumulate-cell-ys drop ]
  86     bi 2array ;
  87
  88 M: grid pref-dim* <grid-layout> grid-pref-dim ;
  89
  90 : (compute-cell-locs) ( grid-layout -- locs )
  91     [ accumulate-cell-xs nip ]
  92     [ accumulate-cell-ys nip ]
  93     bi cross-zip flip ;
  94
  95 : adjust-for-baseline ( row-locs row-cells -- row-locs' )
  96     align-baselines [ 0 swap 2array v+ ] 2map ;
  97
  98 : cell-locs ( grid-layout -- locs )
  99     dup fill?>>
 100     [ (compute-cell-locs) ] [
 101         [ (compute-cell-locs) ] [ grid>> ] bi
 102         [ adjust-for-baseline ] 2map
 103     ] if ;
 104
 105 : cell-dims ( grid-layout -- dims )
 106     dup fill?>>
 107     [ [ column-widths>> ] [ row-heights>> ] bi cross-zip flip ]
 108     [ grid>> [ [ pref-dim>> ] map ] map ]
 109     if ;
 110
 111 : grid-layout ( children grid-layout -- )
 112     [ cell-locs ] [ cell-dims ] bi
 113     [ [ <rect> swap set-rect-bounds ] 3each ] 3each ;
 114
 115 M: grid layout* [ grid>> ] [ <grid-layout> ] bi grid-layout ;
 116
 117 M: grid children-on ( rect gadget -- seq )
 118     dup children>> empty? [ 2drop f ] [
 119         { 0 1 } swap grid>>
 120         [ 0 <column> fast-children-on ] keep
 121         <slice> concat
 122     ] if ;
 123
 124 M: grid gadget-text*
 125     grid>>
 126     [ [ gadget-text ] map ] map format-table
 127     [ CHAR: \n , ] [ % ] interleave ;
 128
 129 PRIVATE>