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