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