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 math.rectangles models math.ranges sequences combinators fonts locals
   9 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 : <table> ( rows renderer -- table )
  50     table 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 ;
  57
  58 <PRIVATE
  59
  60 GENERIC: cell-width ( font cell -- x )
  61 GENERIC: cell-height ( font cell -- y )
  62 GENERIC: draw-cell ( font cell -- )
  63
  64 M: string cell-width text-width ;
  65 M: string cell-height text-height ceiling ;
  66 M: string draw-cell draw-text ;
  67
  68 M: image-name cell-width nip image-dim first ;
  69 M: image-name cell-height nip image-dim second ;
  70 M: image-name draw-cell nip draw-image ;
  71
  72 : table-rows ( table -- rows )
  73     [ control-value ] [ renderer>> ] bi '[ _ row-columns ] map ;
  74
  75 : column-offsets ( widths gap -- x xs )
  76     [ 0 ] dip '[ _ + + ] accumulate ;
  77
  78 CONSTANT: column-title-background COLOR: light-gray
  79
  80 : column-title-font ( font -- font' )
  81     column-title-background font-with-background t >>bold? ;
  82
  83 : initial-widths ( table rows -- widths )
  84     over renderer>> column-titles dup
  85     [ [ drop font>> ] dip [ text-width ] with map ]
  86     [ drop nip first length 0 <repetition> ]
  87     if ;
  88
  89 : row-column-widths ( table row -- widths )
  90     [ font>> ] dip [ cell-width ] with map ;
  91
  92 : compute-total-width ( gap widths -- total )
  93     swap [ column-offsets drop ] keep - ;
  94
  95 : compute-column-widths ( table -- total widths )
  96     dup table-rows [ drop 0 { } ] [
  97         [ drop gap>> ] [ initial-widths ] [ ] 2tri
  98         [ row-column-widths vmax ] with each
  99         [ compute-total-width ] keep
 100     ] if-empty ;
 101
 102 : update-cached-widths ( table -- )
 103     dup compute-column-widths
 104     [ >>total-width ] [ >>column-widths ] bi*
 105     drop ;
 106
 107 : filled-column-width ( table -- n )
 108     [ dim>> first ] [ total-width>> ] bi [-] ;
 109
 110 : update-filled-column ( table -- )
 111     [ filled-column-width ]
 112     [ renderer>> filled-column ]
 113     [ column-widths>> ] tri
 114     2dup empty? not and
 115     [ [ + ] change-nth ] [ 3drop ] if ;
 116
 117 M: table layout*
 118     [ update-cached-widths ] [ update-filled-column ] bi ;
 119
 120 : row-rect ( table row -- rect )
 121     [ [ line-height ] dip * 0 swap 2array ]
 122     [ drop [ dim>> first ] [ line-height ] bi 2array ] 2bi <rect> ;
 123
 124 : highlight-row ( table row color quot -- )
 125     [ [ row-rect rect-bounds ] dip gl-color ] dip
 126     '[ _ @ ] with-translation ; inline
 127
 128 : draw-selected-row ( table -- )
 129     {
 130         { [ dup selected-index>> not ] [ drop ] }
 131         [
 132             [ ] [ selected-index>> ] [ selection-color>> ] tri
 133             [ gl-fill-rect ] highlight-row
 134         ]
 135     } cond ;
 136
 137 : draw-focused-row ( table -- )
 138     {
 139         { [ dup focused?>> not ] [ drop ] }
 140         { [ dup selected-index>> not ] [ drop ] }
 141         [
 142             [ ] [ selected-index>> ] [ focus-border-color>> ] tri
 143             [ gl-rect ] highlight-row
 144         ]
 145     } cond ;
 146
 147 : draw-moused-row ( table -- )
 148     dup mouse-index>> dup [
 149         over mouse-color>> [ gl-rect ] highlight-row
 150     ] [ 2drop ] 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     [ [ cell-width ] dip swap - ] dip
 167     * >integer 0 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 selected-index>> = [ table selection-color>> >>background ] when ;
 188
 189 : draw-columns ( columns widths alignment font gap -- )
 190     '[ [ _ ] 3dip _ draw-column ] 3each ;
 191
 192 M: table draw-line ( row index table -- )
 193     [
 194         nip
 195         [ renderer>> row-columns ]
 196         [ column-widths>> ]
 197         [ table-column-alignment ]
 198         tri
 199     ]
 200     [ row-font ]
 201     [ 2nip gap>> ] 3tri
 202     draw-columns ;
 203
 204 M: table draw-gadget*
 205     dup control-value empty? [ drop ] [
 206         {
 207             [ draw-selected-row ]
 208             [ draw-lines ]
 209             [ draw-column-lines ]
 210             [ draw-focused-row ]
 211             [ draw-moused-row ]
 212         } cleave
 213     ] if ;
 214
 215 M: table line-height ( table -- y )
 216     [ font>> ] [ renderer>> prototype-row ] bi
 217     [ cell-height ] with [ max ] map-reduce ;
 218
 219 M: table pref-dim*
 220     [ compute-column-widths drop ] keep
 221     [ line-height ] [ control-value length ] bi * 2array ;
 222
 223 : nth-row ( row table -- value/f ? )
 224     over [ control-value nth t ] [ 2drop f f ] if ;
 225
 226 PRIVATE>
 227
 228 : (selected-row) ( table -- value/f ? )
 229     [ selected-index>> ] keep nth-row ;
 230
 231 : selected-row ( table -- value/f ? )
 232     [ (selected-row) ] keep
 233     swap [ renderer>> row-value t ] [ 2drop f f ] if ;
 234
 235 <PRIVATE
 236
 237 : update-selected-value ( table -- )
 238     [ selected-row drop ] [ selected-value>> ] bi set-model ;
 239
 240 : initial-selected-index ( model table -- n/f )
 241     [ value>> length 1 >= ] [ selection-required?>> ] bi* and 0 f ? ;
 242
 243 : show-row-summary ( table n -- )
 244     over nth-row
 245     [ swap [ renderer>> row-value ] keep show-summary ]
 246     [ 2drop ]
 247     if ;
 248
 249 : hide-mouse-help ( table -- )
 250     f >>mouse-index [ hide-status ] [ relayout-1 ] bi ;
 251
 252 M: table model-changed
 253     [ nip ] [ initial-selected-index ] 2bi {
 254         [ >>selected-index f >>mouse-index drop ]
 255         [ show-row-summary ]
 256         [ drop update-selected-value ]
 257         [ drop relayout ]
 258     } 2cleave ;
 259
 260 : thin-row-rect ( table row -- rect )
 261     row-rect [ { 0 1 } v* ] change-dim ;
 262
 263 : (select-row) ( table n -- )
 264     [ dup [ [ thin-row-rect ] [ drop ] 2bi scroll>rect ] [ 2drop ] if ]
 265     [ >>selected-index relayout-1 ]
 266     2bi ;
 267
 268 : mouse-row ( table -- n )
 269     [ hand-rel second ] keep y>line ;
 270
 271 : table-button-down ( table -- )
 272     dup takes-focus?>> [ dup request-focus ] when
 273     dup control-value empty? [ drop ] [
 274         dup [ mouse-row ] keep validate-line
 275         [ >>mouse-index ] [ (select-row) ] bi
 276     ] if ;
 277
 278 PRIVATE>
 279
 280 : row-action ( table -- )
 281     dup selected-row
 282     [ swap [ action>> call ] [ dup hook>> call ] bi ]
 283     [ 2drop ]
 284     if ;
 285
 286 <PRIVATE
 287
 288 : table-button-up ( table -- )
 289     dup single-click?>> hand-click# get 2 = or
 290     [ row-action ] [ update-selected-value ] if ;
 291
 292 : select-row ( table n -- )
 293     over validate-line
 294     [ (select-row) ]
 295     [ drop update-selected-value ]
 296     [ show-row-summary ]
 297     2tri ;
 298
 299 : prev/next-row ( table n -- )
 300     [ dup selected-index>> ] dip '[ _ + ] [ 0 ] if* select-row ;
 301
 302 : previous-row ( table -- )
 303     -1 prev/next-row ;
 304
 305 : next-row ( table -- )
 306     1 prev/next-row ;
 307
 308 : first-row ( table -- )
 309     0 select-row ;
 310
 311 : last-row ( table -- )
 312     dup control-value length 1- select-row ;
 313
 314 : prev/next-page ( table n -- )
 315     over visible-lines 1- * prev/next-row ;
 316
 317 : previous-page ( table -- )
 318     -1 prev/next-page ;
 319
 320 : next-page ( table -- )
 321     1 prev/next-page ;
 322
 323 : valid-row? ( row table -- ? )
 324     control-value length 1- 0 swap between? ;
 325
 326 : if-mouse-row ( table true false -- )
 327     [ [ mouse-row ] keep 2dup valid-row? ]
 328     [ ] [ '[ nip @ ] ] tri* if ; inline
 329
 330 : show-mouse-help ( table -- )
 331     [
 332         swap
 333         [ >>mouse-index relayout-1 ]
 334         [ show-row-summary ]
 335         2bi
 336     ] [ hide-mouse-help ] if-mouse-row ;
 337
 338 : show-table-menu ( table -- )
 339     [
 340         [ nip ]
 341         [ swap select-row ]
 342         [
 343             [ nth-row drop ]
 344             [ renderer>> row-value ]
 345             [ dup hook>> curry ]
 346             tri
 347         ] 2tri
 348         show-operations-menu
 349     ] [ drop ] if-mouse-row ;
 350
 351 : focus-table ( table -- ) t >>focused? drop ;
 352
 353 : unfocus-table ( table -- ) f >>focused? drop ;
 354
 355 table "sundry" f {
 356     { mouse-enter show-mouse-help }
 357     { mouse-leave hide-mouse-help }
 358     { motion show-mouse-help }
 359     { T{ button-down } table-button-down }
 360     { T{ button-up } table-button-up }
 361     { gain-focus focus-table }
 362     { lose-focus unfocus-table }
 363     { T{ drag } table-button-down }
 364 } define-command-map
 365
 366 table "row" f {
 367     { T{ button-down f f 3 } show-table-menu }
 368     { T{ key-down f f "RET" } row-action }
 369     { T{ key-down f f "UP" } previous-row }
 370     { T{ key-down f f "DOWN" } next-row }
 371     { T{ key-down f f "HOME" } first-row }
 372     { T{ key-down f f "END" } last-row }
 373     { T{ key-down f f "PAGE_UP" } previous-page }
 374     { T{ key-down f f "PAGE_DOWN" } next-page }
 375 } define-command-map
 376
 377 TUPLE: column-headers < gadget table ;
 378
 379 : <column-headers> ( table -- gadget )
 380     column-headers new
 381         swap >>table
 382         column-title-background <solid> >>interior ;
 383
 384 : draw-column-titles ( table -- )
 385     {
 386         [ renderer>> column-titles ]
 387         [ column-widths>> ]
 388         [ table-column-alignment ]
 389         [ font>> column-title-font ]
 390         [ gap>> ]
 391     } cleave
 392     draw-columns ;
 393
 394 M: column-headers draw-gadget*
 395     table>> draw-column-titles ;
 396
 397 M: column-headers pref-dim*
 398     table>> [ pref-dim first ] [ font>> "" text-height ] bi 2array ;
 399
 400 M: table viewport-column-header
 401     dup renderer>> column-titles
 402     [ <column-headers> ] [ drop f ] if ;
 403
 404 PRIVATE>