basis/ui/gadgets/tables/tables.factor

   1 ! Copyright (C) 2008, 2009 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays colors fry kernel math
   4 math.geometry.rect math.order math.vectors namespaces opengl
   5 sequences ui.gadgets ui.gadgets.scrollers ui.gadgets.status-bar
   6 ui.gadgets.worlds ui.gadgets.theme ui.gestures ui.render ui.text
   7 ui.gadgets.menus models math.ranges sequences combinators ;
   8 IN: ui.gadgets.tables
   9
  10 ! Row rendererer protocol
  11 GENERIC: row-columns ( row renderer -- columns )
  12 GENERIC: row-value ( row renderer -- object )
  13
  14 SINGLETON: trivial-renderer
  15
  16 M: trivial-renderer row-columns drop ;
  17 M: object row-value drop ;
  18
  19 TUPLE: table < gadget
  20 renderer filled-column column-alignment action hook
  21 column-widths total-width
  22 font text-color selection-color focus-border-color
  23 mouse-color column-line-color selection-required?
  24 selected-index selected-value
  25 mouse-index
  26 focused? ;
  27
  28 : <table> ( rows -- table )
  29     table new-gadget
  30         swap >>model
  31         trivial-renderer >>renderer
  32         [ drop ] >>action
  33         [ ] >>hook
  34         f <model> >>selected-value
  35         sans-serif-font >>font
  36         selection-color >>selection-color
  37         focus-border-color >>focus-border-color
  38         dark-gray >>column-line-color
  39         black >>mouse-color
  40         black >>text-color ;
  41
  42 <PRIVATE
  43
  44 : line-height ( table -- n )
  45     font>> "" text-height ;
  46
  47 CONSTANT: table-gap 6
  48
  49 : table-rows ( table -- rows )
  50     [ control-value ] [ renderer>> ] bi '[ _ row-columns ] map ;
  51
  52 : (compute-column-widths) ( font rows -- total widths )
  53     [ drop 0 { } ] [
  54         [ nip first length 0 <repetition> ] 2keep
  55         [ [ text-width ] with map vmax ] with each
  56         [ [ sum ] [ length 1 [-] table-gap * ] bi + ] keep
  57     ] if-empty ;
  58
  59 : compute-column-widths ( table -- total-width column-widths )
  60     [ font>> ] [ table-rows ] bi (compute-column-widths) ;
  61
  62 : update-cached-widths ( table -- )
  63     dup compute-column-widths
  64     [ >>total-width ] [ >>column-widths ] bi*
  65     drop ;
  66
  67 : filled-column-width ( table -- n )
  68     [ dim>> first ] [ total-width>> ] bi [-] ;
  69
  70 : update-filled-column ( table -- )
  71     [ filled-column-width ]
  72     [ filled-column>> ]
  73     [ column-widths>> ] tri
  74     2dup empty? not and
  75     [ [ + ] change-nth ] [ 3drop ] if ;
  76
  77 M: table layout*
  78     [ update-cached-widths ] [ update-filled-column ] bi ;
  79
  80 : row-rect ( table row -- rect )
  81     [ [ line-height ] dip * 0 swap 2array ]
  82     [ drop [ dim>> first ] [ line-height ] bi 2array ] 2bi <rect> ;
  83
  84 : highlight-row ( table row color quot -- )
  85     [ [ row-rect rect-bounds ] dip gl-color ] dip
  86     '[ _ @ ] with-translation ; inline
  87
  88 : draw-selected-row ( table row -- )
  89     over selection-color>> [ gl-fill-rect ] highlight-row ;
  90
  91 : draw-focused-row ( table row -- )
  92     over focused?>> [
  93         over focus-border-color>> [ gl-rect ] highlight-row
  94     ] [ 2drop ] if ;
  95
  96 : draw-selected ( table -- )
  97     dup selected-index>> dup
  98     [ [ draw-selected-row ] [ draw-focused-row ] 2bi ]
  99     [ 2drop ]
 100     if ;
 101
 102 : draw-moused ( table -- )
 103     dup mouse-index>> dup [
 104         over mouse-color>> [ gl-rect ] highlight-row
 105     ] [ 2drop ] if ;
 106
 107 : column-offsets ( table -- xs )
 108     0 [ table-gap + + ] accumulate nip ;
 109
 110 : column-line-offsets ( table -- xs )
 111     column-offsets
 112     [ f ] [ rest-slice [ table-gap 2/ - ] map ] if-empty ;
 113
 114 : draw-columns ( table -- )
 115     [ column-line-color>> gl-color ]
 116     [
 117         [ column-widths>> column-line-offsets ] [ dim>> second ] bi
 118         '[ [ 0 2array ] [ _ 2array ] bi gl-line ] each
 119     ] bi ;
 120
 121 : y>row ( y table -- n )
 122     line-height /i ;
 123
 124 : validate-row ( m table -- n )
 125     control-value [ drop f ] [ length 1- min 0 max ] if-empty ;
 126
 127 : visible-row ( table quot -- n )
 128     '[
 129         [ clip get @ origin get [ second ] bi@ - ] dip
 130         y>row
 131     ] keep validate-row ; inline
 132
 133 : first-visible-row ( table -- n )
 134     [ loc>> ] visible-row ;
 135
 136 : last-visible-row ( table -- n )
 137     [ rect-extent nip ] visible-row 1+ ;
 138
 139 : column-loc ( font column width align -- loc )
 140     [ [ text-width ] dip swap - ] dip
 141     * 0 2array ;
 142
 143 : draw-column ( font column width align -- )
 144     over [
 145         [ 2dup ] 2dip column-loc draw-text
 146     ] dip table-gap + 0 2array gl-translate ;
 147
 148 : draw-row ( columns widths align font -- )
 149     '[ [ _ ] 3dip draw-column ] 3each ;
 150
 151 : each-slice-index ( from to seq quot -- )
 152     [ [ <slice> ] [ drop [a,b) ] 3bi ] dip 2each ; inline
 153
 154 : column-alignment ( table -- seq )
 155     dup column-alignment>>
 156     [ ] [ column-widths>> length 0 <repetition> ] ?if ;
 157
 158 : draw-rows ( table -- )
 159     {
 160         [ text-color>> gl-color ]
 161         [ first-visible-row ]
 162         [ last-visible-row ]
 163         [ control-value ]
 164         [ line-height ]
 165         [ renderer>> ]
 166         [ column-widths>> ]
 167         [ column-alignment ]
 168         [ font>> ]
 169     } cleave '[
 170         [ 0 ] dip _ * 2array [
 171             _ row-columns _ _ _ draw-row
 172         ] with-translation
 173     ] each-slice-index ;
 174
 175 M: table draw-gadget*
 176     dup control-value empty? [ drop ] [
 177         origin get [
 178             {
 179                 [ draw-selected ]
 180                 [ draw-columns ]
 181                 [ draw-moused ]
 182                 [ draw-rows ]
 183             } cleave
 184         ] with-translation
 185     ] if ;
 186
 187 M: table pref-dim*
 188     [ compute-column-widths drop ] keep
 189     [ font>> "" text-height ]
 190     [ control-value length ]
 191     bi * 2array ;
 192
 193 : nth-row ( row table -- value/f ? )
 194     over [ control-value nth t ] [ 2drop f f ] if ;
 195
 196 PRIVATE>
 197
 198 : (selected-row) ( table -- value/f ? )
 199     [ selected-index>> ] keep nth-row ;
 200
 201 : selected-row ( table -- value/f ? )
 202     [ (selected-row) ] keep
 203     swap [ renderer>> row-value t ] [ 2drop f f ] if ;
 204
 205 <PRIVATE
 206
 207 : update-selected-value ( table -- )
 208     [ selected-row drop ] [ selected-value>> ] bi set-model ;
 209
 210 : initial-selected-index ( model table -- n/f )
 211     [ value>> length 1 >= ] [ selection-required?>> ] bi* and 0 f ? ;
 212
 213 : show-row-summary ( table n -- )
 214     over nth-row
 215     [ swap [ renderer>> row-value ] keep show-summary ]
 216     [ 2drop ]
 217     if ;
 218
 219 M: table model-changed
 220     [ nip ] [ initial-selected-index ] 2bi {
 221         [ >>selected-index drop ]
 222         [ show-row-summary ]
 223         [ drop update-selected-value ]
 224         [ drop relayout ]
 225     } 2cleave ;
 226
 227 : thin-row-rect ( table row -- rect )
 228     row-rect [ { 0 1 } v* ] change-dim ;
 229
 230 : (select-row) ( table n -- )
 231     [ dup [ [ thin-row-rect ] [ drop ] 2bi scroll>rect ] [ 2drop ] if ]
 232     [ >>selected-index relayout-1 ]
 233     2bi ;
 234
 235 : mouse-row ( table -- n )
 236     [ hand-rel second ] keep y>row ;
 237
 238 : table-button-down ( table -- )
 239     dup request-focus
 240     dup control-value empty? [ drop ] [
 241         dup [ mouse-row ] keep validate-row
 242         [ >>mouse-index ] [ (select-row) ] bi
 243     ] if ;
 244
 245 PRIVATE>
 246
 247 : row-action ( table -- )
 248     dup selected-row [ swap action>> call ] [ 2drop ] if ;
 249
 250 <PRIVATE
 251
 252 : table-button-up ( table -- )
 253     hand-click# get 2 =
 254     [ row-action ] [ update-selected-value ] if ;
 255
 256 : select-row ( table n -- )
 257     over validate-row
 258     [ (select-row) ]
 259     [ drop update-selected-value ]
 260     [ show-row-summary ]
 261     2tri ;
 262
 263 : prev/next-row ( table n -- )
 264     [ dup selected-index>> ] dip '[ _ + ] [ 0 ] if* select-row ;
 265
 266 : prev-row ( table -- )
 267     -1 prev/next-row ;
 268
 269 : next-row ( table -- )
 270     1 prev/next-row ;
 271
 272 : first-row ( table -- )
 273     0 select-row ;
 274
 275 : last-row ( table -- )
 276     dup control-value length 1- select-row ;
 277
 278 : hide-mouse-help ( table -- )
 279     f >>mouse-index [ hide-status ] [ relayout-1 ] bi ;
 280
 281 : valid-row? ( row table -- ? )
 282     control-value length 1- 0 swap between? ;
 283
 284 : if-mouse-row ( table true false -- )
 285     [ [ mouse-row ] keep 2dup valid-row? ]
 286     [ ] [ '[ nip @ ] ] tri* if ; inline
 287
 288 : show-mouse-help ( table -- )
 289     [
 290         swap
 291         [ >>mouse-index relayout-1 ]
 292         [ show-row-summary ]
 293         2bi
 294     ] [ hide-mouse-help ] if-mouse-row ;
 295
 296 : show-table-menu ( table -- )
 297     [
 298         tuck [ nth-row drop ] [ renderer>> row-value ] [ hook>> ] tri
 299         show-operations-menu
 300     ] [ drop ] if-mouse-row ;
 301
 302 table H{
 303     { mouse-enter [ show-mouse-help ] }
 304     { mouse-leave [ hide-mouse-help ] }
 305     { motion [ show-mouse-help ] }
 306     { T{ button-down } [ table-button-down ] }
 307     { T{ button-down f f 3 } [ show-table-menu ] }
 308     { T{ button-up } [ table-button-up ] }
 309     { gain-focus [ t >>focused? drop ] }
 310     { lose-focus [ f >>focused? drop ] }
 311     { T{ drag } [ table-button-down ] }
 312     { T{ key-down f f "RET" } [ row-action ] }
 313     { T{ key-down f f "UP" } [ prev-row ] }
 314     { T{ key-down f f "DOWN" } [ next-row ] }
 315     { T{ key-down f f "HOME" } [ first-row ] }
 316     { T{ key-down f f "END" } [ last-row ] }
 317 } set-gestures
 318
 319 PRIVATE>