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