basis/ui/gadgets/tables/tables.factor

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