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