basis/ui/gadgets/tables/tables.factor

   1 ! Copyright (C) 2008, 2011 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays colors colors.constants combinators
   4 combinators.short-circuit fonts fry kernel locals math
   5 math.functions math.order math.rectangles math.vectors models
   6 namespaces opengl sequences splitting strings ui.commands
   7 ui.gadgets ui.gadgets.line-support ui.gadgets.menus
   8 ui.gadgets.scrollers ui.gadgets.status-bar ui.gadgets.worlds
   9 ui.gestures ui.images ui.pens.solid ui.render ui.text ui.theme ;
  10 IN: ui.gadgets.tables
  11
  12 ! Row renderer protocol
  13 GENERIC: prototype-row ( renderer -- columns )
  14 GENERIC: column-alignment ( renderer -- alignment )
  15 GENERIC: filled-column ( renderer -- n )
  16 GENERIC: column-titles ( renderer -- strings )
  17
  18 GENERIC: row-columns ( row renderer -- columns )
  19 GENERIC: row-value ( row renderer -- object )
  20 GENERIC: row-color ( row renderer -- color )
  21 GENERIC: row-value? ( value row renderer -- ? )
  22
  23 SINGLETON: trivial-renderer
  24
  25 M: object prototype-row drop { "" } ;
  26 M: object column-alignment drop f ;
  27 M: object filled-column drop f ;
  28 M: object column-titles drop f ;
  29
  30 M: trivial-renderer row-columns drop ;
  31 M: object row-value drop ;
  32 M: object row-color 2drop f ;
  33 M: object row-value? drop eq? ;
  34
  35 TUPLE: table < line-gadget
  36 { renderer initial: trivial-renderer }
  37 { action initial: [ drop ] }
  38 single-click?
  39 { hook initial: [ drop ] }
  40 { gap initial: 2 }
  41 column-widths total-width
  42 focus-border-color
  43 mouse-color
  44 column-line-color
  45 selection-required?
  46 selection-index
  47 selection
  48 mouse-index
  49 { takes-focus? initial: t }
  50 focused?
  51 rows ;
  52
  53 : new-table ( rows renderer class -- table )
  54     new-line-gadget
  55         swap >>renderer
  56         swap >>model
  57         sans-serif-font >>font
  58         focus-border-color >>focus-border-color
  59         transparent >>column-line-color
  60         f <model> >>selection-index
  61         f <model> >>selection ;
  62
  63 : <table> ( rows renderer -- table ) table new-table ;
  64
  65 <PRIVATE
  66
  67 GENERIC: cell-dim ( font cell -- width height padding )
  68 GENERIC: draw-cell ( font cell -- )
  69
  70 M: f cell-dim 2drop 0 0 0 ;
  71 M: f draw-cell 2drop ;
  72
  73 : single-line ( str -- str' )
  74     dup [ "\r\n" member? ] any? [ string-lines " " join ] when ;
  75
  76 M: string cell-dim single-line text-dim first2 ceiling 0 ;
  77 M: string draw-cell single-line draw-text ;
  78
  79 CONSTANT: image-padding 2
  80
  81 M: image-name cell-dim nip image-dim first2 image-padding ;
  82 M: image-name draw-cell nip draw-image ;
  83
  84 : column-offsets ( widths gap -- x xs )
  85     [ 0 ] dip '[ _ + + ] accumulate ;
  86
  87 : column-title-font ( font -- font' )
  88     column-title-background font-with-background t >>bold? ;
  89
  90 : initial-widths ( table rows -- widths )
  91     over renderer>> column-titles dup
  92     [ [ drop font>> ] dip [ text-width ] with map ]
  93     [ drop nip first length 0 <repetition> ]
  94     if ;
  95
  96 : row-column-widths ( table row -- widths )
  97     [ font>> ] dip [ cell-dim nip + ] with map ;
  98
  99 : compute-total-width ( gap widths -- total )
 100     swap [ column-offsets drop ] keep - ;
 101
 102 GENERIC: compute-column-widths ( table -- total widths )
 103
 104 M: table compute-column-widths
 105     dup rows>> [ drop 0 { } ] [
 106         [ drop gap>> ] [ initial-widths ] [ ] 2tri
 107         [ row-column-widths vmax ] with each
 108         [ compute-total-width ] keep
 109     ] if-empty ;
 110
 111 : update-cached-widths ( table -- )
 112     dup compute-column-widths
 113     [ >>total-width ] [ >>column-widths ] bi*
 114     drop ;
 115
 116 : filled-column-width ( table -- n )
 117     [ dim>> first ] [ total-width>> ] bi [-] ;
 118
 119 : update-filled-column ( table -- )
 120     [ filled-column-width ]
 121     [ renderer>> filled-column ]
 122     [ column-widths>> ] tri
 123     2dup empty? not and
 124     [ [ + ] change-nth ] [ 3drop ] if ;
 125
 126 M: table layout*
 127     [ update-cached-widths ] [ update-filled-column ] bi ;
 128
 129 : row-rect ( table row -- rect )
 130     [ [ line-height ] dip * 0 swap 2array ]
 131     [ drop [ dim>> first ] [ line-height ] bi 2array ] 2bi <rect> ;
 132
 133 : row-bounds ( table row -- loc dim )
 134     row-rect rect-bounds ; inline
 135
 136 : draw-selected-row ( table -- )
 137     dup selection-index>> value>> [
 138         dup selection-color>> gl-color
 139         dup selection-index>> value>> row-bounds gl-fill-rect
 140     ] [ drop ] if ;
 141
 142 : draw-focused-row ( table -- )
 143     dup { [ focused?>> ] [ selection-index>> value>> ] } 1&& [
 144         dup focus-border-color>> gl-color
 145         dup selection-index>> value>> row-bounds gl-rect
 146     ] [ drop ] if ;
 147
 148 : draw-moused-row ( table -- )
 149     dup mouse-index>> [
 150         dup mouse-color>> [ text-color ] unless* gl-color
 151         dup mouse-index>> row-bounds gl-rect
 152     ] [ drop ] if ;
 153
 154 : column-line-offsets ( table -- xs )
 155     [ column-widths>> ] [ gap>> ] bi
 156     [ column-offsets nip [ f ] ]
 157     [ 2/ '[ rest-slice [ _ - ] map ] ]
 158     bi if-empty ;
 159
 160 : draw-column-lines ( table -- )
 161     [ column-line-color>> gl-color ]
 162     [
 163         [ column-line-offsets ] [ dim>> second ] bi
 164         '[ [ 0 2array ] [ _ 2array ] bi gl-line ] each
 165     ] bi ;
 166
 167 :: column-loc ( font column width align -- loc )
 168     font column cell-dim :> ( cell-width cell-height cell-padding )
 169     cell-width width swap - align *
 170     cell-padding 2 / 1 align - * +
 171     cell-height \ line-height get swap - 2 /
 172     [ >integer ] bi@ 2array ;
 173
 174 : translate-column ( width gap -- )
 175     + 0 2array gl-translate ;
 176
 177 : draw-column ( font column width align gap -- )
 178     [
 179         over [
 180             [ 2dup ] 2dip column-loc
 181             [ draw-cell ] with-translation
 182         ] dip
 183     ] dip translate-column ;
 184
 185 : table-column-alignment ( table -- seq )
 186     dup renderer>> column-alignment
 187     [ ] [ column-widths>> length 0 <repetition> ] ?if ;
 188
 189 :: row-font ( row index table -- font )
 190     table font>> clone
 191     row table renderer>> row-color [ >>foreground ] when*
 192     index table selection-index>> value>> =
 193     [ table selection-color>> >>background ] when ;
 194
 195 : draw-columns ( columns widths alignment font gap -- )
 196     '[ [ _ ] 3dip _ draw-column ] 3each ;
 197
 198 M:: table draw-line ( row index table -- )
 199     row table renderer>> row-columns
 200     table column-widths>>
 201     table table-column-alignment
 202     row index table row-font
 203     table gap>>
 204     draw-columns ;
 205
 206 M: table draw-gadget*
 207     dup control-value empty? [ drop ] [
 208         dup line-height \ line-height [
 209             {
 210                 [ draw-selected-row ]
 211                 [ draw-lines ]
 212                 [ draw-column-lines ]
 213                 [ draw-focused-row ]
 214                 [ draw-moused-row ]
 215             } cleave
 216         ] with-variable
 217     ] if ;
 218
 219 M: table line-height* ( table -- y )
 220     [ font>> ] [ renderer>> prototype-row ] bi
 221     [ cell-dim + nip ] with [ max ] map-reduce ;
 222
 223 M: table pref-dim*
 224     [ compute-column-widths drop ] keep
 225     [ line-height ] [ control-value length ] bi * 2array ;
 226
 227 : nth-row ( index table -- value/f ? )
 228     over [ control-value nth t ] [ 2drop f f ] if ;
 229
 230 PRIVATE>
 231
 232 : (selected-row) ( table -- value/f ? )
 233     [ selection-index>> value>> ] keep nth-row ;
 234
 235 : selected-row ( table -- value/f ? )
 236     [ (selected-row) ] [ renderer>> ] bi
 237     swap [ row-value t ] [ 2drop f f ] if ;
 238
 239 <PRIVATE
 240
 241 : show-row-summary ( table n -- )
 242     over nth-row
 243     [ swap [ renderer>> row-value ] keep show-summary ]
 244     [ drop hide-status ]
 245     if ;
 246
 247 : update-status ( table -- )
 248     dup mouse-index>>
 249     [ dup selection-index>> value>> ] unless*
 250     show-row-summary ;
 251
 252 : hide-mouse-help ( table -- )
 253     f >>mouse-index [ update-status ] [ relayout-1 ] bi ;
 254
 255 : select-table-row ( n table -- )
 256     [ selection-index>> set-model ]
 257     [ [ selected-row drop ] keep selection>> set-model ]
 258     bi ;
 259
 260 : update-mouse-index ( table -- )
 261     dup [ control-value ] [ mouse-index>> ] bi
 262     dup [ swap length [ drop f ] [ 1 - min ] if-zero ] [ 2drop f ] if
 263     >>mouse-index drop ;
 264
 265 : initial-selection-index ( table -- n/f )
 266     {
 267         [ control-value empty? not ]
 268         [ selection-required?>> ]
 269         [ drop 0 ]
 270     } 1&& ;
 271
 272 : find-row-index ( value table -- n/f )
 273     [ control-value ] [ renderer>> ] bi
 274     '[ _ row-value? ] with find drop ;
 275
 276 : update-table-rows ( table -- )
 277     [
 278         [ control-value ] [ renderer>> ] bi
 279         '[ _ row-columns ] map
 280     ]
 281     [ rows<< ] bi ; inline
 282
 283 : update-selection ( table -- )
 284     [
 285         {
 286             [ [ selection>> value>> ] keep find-row-index ]
 287             [ initial-selection-index ]
 288         } 1||
 289     ] keep
 290     over [ select-table-row ] [
 291         [ selection-index>> set-model ]
 292         [ selection>> set-model ]
 293         2bi
 294     ] if ;
 295
 296 M: table model-changed
 297     nip
 298         dup update-table-rows
 299         dup update-selection
 300         dup update-mouse-index
 301     [ update-status ] [ relayout ] bi ;
 302
 303 : thin-row-rect ( table row -- rect )
 304     row-rect [ { 0 1 } v* ] change-dim ;
 305
 306 : scroll-to-row ( table n -- )
 307     [ [ thin-row-rect ] [ drop ] 2bi scroll>rect ] [ drop ] if* ;
 308
 309 : (select-row) ( table n -- )
 310     [ scroll-to-row ]
 311     [ swap select-table-row ]
 312     [ drop relayout-1 ]
 313     2tri ;
 314
 315 : mouse-row ( table -- n )
 316     [ hand-rel second ] keep y>line ;
 317
 318 : if-mouse-row ( table true: ( mouse-index table -- ) false: ( table -- ) -- )
 319     [ [ mouse-row ] keep 2dup valid-line? ]
 320     [ ] [ '[ nip @ ] ] tri* if ; inline
 321
 322 : table-button-down ( table -- )
 323     dup takes-focus?>> [ dup request-focus ] when
 324     [ swap [ >>mouse-index ] [ (select-row) ] bi ] [ drop ] if-mouse-row ; inline
 325
 326 PRIVATE>
 327
 328 : row-action ( table -- )
 329     dup selected-row [
 330         over action>> call( value -- )
 331     ] [ drop ] if dup hook>> call( table -- ) ;
 332
 333 : row-action? ( table -- ? )
 334     single-click?>> hand-click# get 2 = or ;
 335
 336 <PRIVATE
 337
 338 : table-button-up ( table -- )
 339     dup [ mouse-row ] keep valid-line? [
 340         dup row-action? [ row-action ] [ drop ] if
 341     ] [ drop ] if ;
 342
 343 PRIVATE>
 344
 345 : select-row ( table n -- )
 346     over validate-line
 347     [ (select-row) ] [ show-row-summary ] 2bi ;
 348
 349 <PRIVATE
 350
 351 : prev/next-row ( table n -- )
 352     [ dup selection-index>> value>> ] dip
 353     '[ _ + ] [ 0 ] if* select-row ;
 354
 355 : previous-row ( table -- )
 356     -1 prev/next-row ;
 357
 358 : next-row ( table -- )
 359     1 prev/next-row ;
 360
 361 : first-row ( table -- )
 362     0 select-row ;
 363
 364 : last-row ( table -- )
 365     dup control-value length 1 - select-row ;
 366
 367 : prev/next-page ( table n -- )
 368     over visible-lines 1 - * prev/next-row ;
 369
 370 : previous-page ( table -- )
 371     -1 prev/next-page ;
 372
 373 : next-page ( table -- )
 374     1 prev/next-page ;
 375
 376 : show-mouse-help ( table -- )
 377     [
 378         swap
 379         [ >>mouse-index relayout-1 ]
 380         [ show-row-summary ]
 381         2bi
 382     ] [ hide-mouse-help ] if-mouse-row ;
 383
 384 : show-table-menu ( table -- )
 385     [
 386         [ nip ]
 387         [ swap select-row ]
 388         [
 389             [ nth-row drop ]
 390             [ renderer>> row-value ]
 391             [ dup hook>> curry ]
 392             tri
 393         ] 2tri
 394         show-operations-menu
 395     ] [ drop ] if-mouse-row ;
 396
 397 : focus-table ( table -- ) t >>focused? relayout-1 ;
 398
 399 : unfocus-table ( table -- ) f >>focused? relayout-1 ;
 400
 401 table "sundry" f {
 402     { mouse-enter show-mouse-help }
 403     { mouse-leave hide-mouse-help }
 404     { motion show-mouse-help }
 405     { T{ button-up } table-button-up }
 406     { T{ button-up f { S+ } } table-button-up }
 407     { T{ button-down } table-button-down }
 408     { gain-focus focus-table }
 409     { lose-focus unfocus-table }
 410     { T{ drag } table-button-down }
 411 } define-command-map
 412
 413 table "row" f {
 414     { T{ button-down f f 3 } show-table-menu }
 415     { T{ key-down f f "RET" } row-action }
 416     { T{ key-down f f "UP" } previous-row }
 417     { T{ key-down f f "DOWN" } next-row }
 418     { T{ key-down f f "HOME" } first-row }
 419     { T{ key-down f f "END" } last-row }
 420     { T{ key-down f f "PAGE_UP" } previous-page }
 421     { T{ key-down f f "PAGE_DOWN" } next-page }
 422 } define-command-map
 423
 424 TUPLE: column-headers < gadget table ;
 425
 426 : <column-headers> ( table -- gadget )
 427     column-headers new
 428         swap >>table
 429         column-title-background <solid> >>interior ;
 430
 431 : draw-column-titles ( table -- )
 432     dup font>> font-metrics height>> \ line-height [
 433         {
 434             [ renderer>> column-titles ]
 435             [ column-widths>> ]
 436             [ table-column-alignment ]
 437             [ font>> column-title-font ]
 438             [ gap>> ]
 439         } cleave
 440         draw-columns
 441     ] with-variable ;
 442
 443 M: column-headers draw-gadget*
 444     table>> draw-column-titles ;
 445
 446 M: column-headers pref-dim*
 447     table>> [ pref-dim first ] [ font>> "" text-height ] bi 2array ;
 448
 449 M: table viewport-column-header
 450     dup renderer>> column-titles
 451     [ <column-headers> ] [ drop f ] if ;
 452
 453 PRIVATE>