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 colors.constants fry kernel math
   4 math.functions math.rectangles math.order math.vectors namespaces
   5 opengl sequences ui.gadgets ui.gadgets.scrollers ui.gadgets.status-bar
   6 ui.gadgets.worlds ui.gestures ui.render ui.pens.solid ui.text
   7 ui.commands ui.images ui.gadgets.menus ui.gadgets.line-support
   8 models math.ranges combinators
   9 combinators.short-circuit fonts locals strings ;
  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 selected-index selected-value
  45 mouse-index
  46 { takes-focus? initial: t }
  47 focused? ;
  48
  49 : new-table ( rows renderer class -- table )
  50     new-line-gadget
  51         swap >>renderer
  52         swap >>model
  53         f <model> >>selected-value
  54         sans-serif-font >>font
  55         focus-border-color >>focus-border-color
  56         transparent >>column-line-color ; inline
  57
  58 : <table> ( rows renderer -- table ) table new-table ;
  59
  60 <PRIVATE
  61
  62 GENERIC: cell-width ( font cell -- x )
  63 GENERIC: cell-height ( font cell -- y )
  64 GENERIC: cell-padding ( cell -- y )
  65 GENERIC: draw-cell ( font cell -- )
  66
  67 M: string cell-width text-width ;
  68 M: string cell-height text-height ceiling ;
  69 M: string cell-padding drop 0 ;
  70 M: string draw-cell draw-text ;
  71
  72 CONSTANT: image-padding 2
  73
  74 M: image-name cell-width nip image-dim first ;
  75 M: image-name cell-height nip image-dim second ;
  76 M: image-name cell-padding drop image-padding ;
  77 M: image-name draw-cell nip draw-image ;
  78
  79 : table-rows ( table -- rows )
  80     [ control-value ] [ renderer>> ] bi '[ _ row-columns ] map ;
  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-width ] [ cell-padding ] bi + ] 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 table-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     {
 136         { [ dup selected-index>> not ] [ drop ] }
 137         [
 138             [ ] [ selected-index>> ] [ selection-color>> gl-color ] tri
 139             row-bounds gl-fill-rect
 140         ]
 141     } cond ;
 142
 143 : draw-focused-row ( table -- )
 144     {
 145         { [ dup focused?>> not ] [ drop ] }
 146         { [ dup selected-index>> not ] [ drop ] }
 147         [
 148             [ ] [ selected-index>> ] [ focus-border-color>> gl-color ] tri
 149             row-bounds gl-rect
 150         ]
 151     } cond ;
 152
 153 : draw-moused-row ( table -- )
 154     dup mouse-index>> dup [
 155         over mouse-color>> gl-color
 156         row-bounds gl-rect
 157     ] [ 2drop ] if ;
 158
 159 : column-line-offsets ( table -- xs )
 160     [ column-widths>> ] [ gap>> ] bi
 161     [ column-offsets nip [ f ] ]
 162     [ 2/ '[ rest-slice [ _ - ] map ] ]
 163     bi if-empty ;
 164
 165 : draw-column-lines ( table -- )
 166     [ column-line-color>> gl-color ]
 167     [
 168         [ column-line-offsets ] [ dim>> second ] bi
 169         '[ [ 0 2array ] [ _ 2array ] bi gl-line ] each
 170     ] bi ;
 171
 172 :: column-loc ( font column width align -- loc )
 173     font column cell-width width swap - align * column cell-padding 2 / 1 align - * +
 174     font column cell-height \ line-height get swap - 2 /
 175     [ >integer ] bi@ 2array ;
 176
 177 : translate-column ( width gap -- )
 178     + 0 2array gl-translate ;
 179
 180 : draw-column ( font column width align gap -- )
 181     [
 182         over [
 183             [ 2dup ] 2dip column-loc
 184             [ draw-cell ] with-translation
 185         ] dip
 186     ] dip translate-column ;
 187
 188 : table-column-alignment ( table -- seq )
 189     dup renderer>> column-alignment
 190     [ ] [ column-widths>> length 0 <repetition> ] ?if ;
 191
 192 :: row-font ( row index table -- font )
 193     table font>> clone
 194     row table renderer>> row-color [ >>foreground ] when*
 195     index table selected-index>> = [ table selection-color>> >>background ] when ;
 196
 197 : draw-columns ( columns widths alignment font gap -- )
 198     '[ [ _ ] 3dip _ draw-column ] 3each ;
 199
 200 M: table draw-line ( row index table -- )
 201     [
 202         nip
 203         [ renderer>> row-columns ]
 204         [ column-widths>> ]
 205         [ table-column-alignment ]
 206         tri
 207     ]
 208     [ row-font ]
 209     [ 2nip gap>> ] 3tri
 210     draw-columns ;
 211
 212 M: table draw-gadget*
 213     dup control-value empty? [ drop ] [
 214         dup line-height \ line-height [
 215             {
 216                 [ draw-selected-row ]
 217                 [ draw-lines ]
 218                 [ draw-column-lines ]
 219                 [ draw-focused-row ]
 220                 [ draw-moused-row ]
 221             } cleave
 222         ] with-variable
 223     ] if ;
 224
 225 M: table line-height ( table -- y )
 226     [ font>> ] [ renderer>> prototype-row ] bi
 227     [ [ cell-height ] [ cell-padding ] bi + ] with
 228     [ max ] map-reduce ;
 229
 230 M: table pref-dim*
 231     [ compute-column-widths drop ] keep
 232     [ line-height ] [ control-value length ] bi * 2array ;
 233
 234 : nth-row ( row table -- value/f ? )
 235     over [ control-value nth t ] [ 2drop f f ] if ;
 236
 237 PRIVATE>
 238
 239 : (selected-row) ( table -- value/f ? )
 240     [ selected-index>> ] keep nth-row ;
 241
 242 : selected-row ( table -- value/f ? )
 243     [ (selected-row) ] keep
 244     swap [ renderer>> row-value t ] [ 2drop f f ] if ;
 245
 246 <PRIVATE
 247
 248 : update-selected-value ( table -- )
 249     [ selected-row drop ] [ selected-value>> ] bi set-model ;
 250
 251 : show-row-summary ( table n -- )
 252     over nth-row
 253     [ swap [ renderer>> row-value ] keep show-summary ]
 254     [ 2drop ]
 255     if ;
 256
 257 : hide-mouse-help ( table -- )
 258     f >>mouse-index [ hide-status ] [ relayout-1 ] bi ;
 259
 260 : find-row-index ( value table -- n/f )
 261     [ model>> value>> ] [ renderer>> '[ _ row-value ] map index ] bi ;
 262
 263 : initial-selected-index ( table -- n/f )
 264     {
 265         [ model>> value>> empty? not ]
 266         [ selection-required?>> ]
 267         [ drop 0 ]
 268     } 1&& ;
 269
 270 : (update-selected-index) ( table -- n/f )
 271     [ selected-value>> value>> ] keep over
 272     [ find-row-index ] [ 2drop f ] if ;
 273
 274 : update-selected-index ( table -- n/f )
 275     {
 276         [ (update-selected-index) ]
 277         [ initial-selected-index ]
 278     } 1|| ;
 279
 280 M: table model-changed
 281     nip dup update-selected-index {
 282         [ >>selected-index f >>mouse-index drop ]
 283         [ show-row-summary ]
 284         [ drop update-selected-value ]
 285         [ drop relayout ]
 286     } 2cleave ;
 287
 288 : thin-row-rect ( table row -- rect )
 289     row-rect [ { 0 1 } v* ] change-dim ;
 290
 291 : (select-row) ( table n -- )
 292     [ dup [ [ thin-row-rect ] [ drop ] 2bi scroll>rect ] [ 2drop ] if ]
 293     [ >>selected-index relayout-1 ]
 294     2bi ;
 295
 296 : mouse-row ( table -- n )
 297     [ hand-rel second ] keep y>line ;
 298
 299 : if-mouse-row ( table true: ( table mouse-index -- ) false: ( table -- ) -- )
 300     [ [ mouse-row ] keep 2dup valid-line? ]
 301     [ ] [ '[ nip @ ] ] tri* if ; inline
 302
 303 : table-button-down ( table -- )
 304     dup takes-focus?>> [ dup request-focus ] when
 305     [ swap [ >>mouse-index ] [ (select-row) ] bi ] [ drop ] if-mouse-row ;
 306
 307 PRIVATE>
 308
 309 : row-action ( table -- )
 310     dup selected-row
 311     [ swap [ action>> call( value -- ) ] [ dup hook>> call( table -- ) ] bi ]
 312     [ 2drop ]
 313     if ;
 314
 315 : row-action? ( table -- ? )
 316     single-click?>> hand-click# get 2 = or ;
 317
 318 <PRIVATE
 319
 320 : table-button-up ( table -- )
 321     dup [ mouse-row ] keep valid-line? [
 322         dup row-action? [ row-action ] [ update-selected-value ] if
 323     ] [ drop ] if ;
 324
 325 PRIVATE>
 326
 327 : select-row ( table n -- )
 328     over validate-line
 329     [ (select-row) ]
 330     [ drop update-selected-value ]
 331     [ show-row-summary ]
 332     2tri ;
 333
 334 <PRIVATE
 335
 336 : prev/next-row ( table n -- )
 337     [ dup selected-index>> ] dip '[ _ + ] [ 0 ] if* select-row ;
 338
 339 : previous-row ( table -- )
 340     -1 prev/next-row ;
 341
 342 : next-row ( table -- )
 343     1 prev/next-row ;
 344
 345 : first-row ( table -- )
 346     0 select-row ;
 347
 348 : last-row ( table -- )
 349     dup control-value length 1- select-row ;
 350
 351 : prev/next-page ( table n -- )
 352     over visible-lines 1- * prev/next-row ;
 353
 354 : previous-page ( table -- )
 355     -1 prev/next-page ;
 356
 357 : next-page ( table -- )
 358     1 prev/next-page ;
 359
 360 : show-mouse-help ( table -- )
 361     [
 362         swap
 363         [ >>mouse-index relayout-1 ]
 364         [ show-row-summary ]
 365         2bi
 366     ] [ hide-mouse-help ] if-mouse-row ;
 367
 368 : show-table-menu ( table -- )
 369     [
 370         [ nip ]
 371         [ swap select-row ]
 372         [
 373             [ nth-row drop ]
 374             [ renderer>> row-value ]
 375             [ dup hook>> curry ]
 376             tri
 377         ] 2tri
 378         show-operations-menu
 379     ] [ drop ] if-mouse-row ;
 380
 381 : focus-table ( table -- ) t >>focused? relayout-1 ;
 382
 383 : unfocus-table ( table -- ) f >>focused? relayout-1 ;
 384
 385 table "sundry" f {
 386     { mouse-enter show-mouse-help }
 387     { mouse-leave hide-mouse-help }
 388     { motion show-mouse-help }
 389     { T{ button-down } table-button-down }
 390     { T{ button-up } table-button-up }
 391     { gain-focus focus-table }
 392     { lose-focus unfocus-table }
 393     { T{ drag } table-button-down }
 394 } define-command-map
 395
 396 table "row" f {
 397     { T{ button-down f f 3 } show-table-menu }
 398     { T{ key-down f f "RET" } row-action }
 399     { T{ key-down f f "UP" } previous-row }
 400     { T{ key-down f f "DOWN" } next-row }
 401     { T{ key-down f f "HOME" } first-row }
 402     { T{ key-down f f "END" } last-row }
 403     { T{ key-down f f "PAGE_UP" } previous-page }
 404     { T{ key-down f f "PAGE_DOWN" } next-page }
 405 } define-command-map
 406
 407 TUPLE: column-headers < gadget table ;
 408
 409 : <column-headers> ( table -- gadget )
 410     column-headers new
 411         swap >>table
 412         column-title-background <solid> >>interior ;
 413
 414 : draw-column-titles ( table -- )
 415     dup font>> font-metrics height>> \ line-height [
 416         {
 417             [ renderer>> column-titles ]
 418             [ column-widths>> ]
 419             [ table-column-alignment ]
 420             [ font>> column-title-font ]
 421             [ gap>> ]
 422         } cleave
 423         draw-columns
 424     ] with-variable ;
 425
 426 M: column-headers draw-gadget*
 427     table>> draw-column-titles ;
 428
 429 M: column-headers pref-dim*
 430     table>> [ pref-dim first ] [ font>> "" text-height ] bi 2array ;
 431
 432 M: table viewport-column-header
 433     dup renderer>> column-titles
 434     [ <column-headers> ] [ drop f ] if ;
 435
 436 PRIVATE>