1 ! Copyright (C) 2008, 2009 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors assocs hashtables arrays colors colors.constants fry
4 kernel math math.functions math.ranges math.rectangles math.order
5 math.vectors 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 combinators
9 combinators.short-circuit fonts locals strings sets sorting ;
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 )
18 GENERIC: row-columns ( row renderer -- columns )
19 GENERIC: row-value ( row renderer -- object )
20 GENERIC: row-color ( row renderer -- color )
22 SINGLETON: trivial-renderer
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 ;
29 M: trivial-renderer row-columns drop ;
30 M: object row-value drop ;
31 M: object row-color 2drop f ;
33 TUPLE: table < line-gadget
34 { renderer initial: trivial-renderer }
35 { action initial: [ drop ] }
37 { hook initial: [ drop ] }
39 column-widths total-width
41 { mouse-color initial: COLOR: black }
48 { takes-focus? initial: t }
54 : add-selected-index ( table n -- table )
55 over selected-indices>> conjoin ;
57 : multiple>single ( values -- value/f ? )
58 dup assoc-empty? [ drop f f ] [ values first t ] if ;
60 : selected-index ( table -- n )
61 selected-indices>> multiple>single drop ;
63 : set-selected-index ( table n -- table )
64 dup associate >>selected-indices ;
68 : selected ( table -- index/indices )
69 [ selected-indices>> ] [ multiple-selection?>> ] bi
70 [ multiple>single drop ] unless ;
72 : new-table ( rows renderer class -- table )
76 sans-serif-font >>font
77 focus-border-color >>focus-border-color
78 transparent >>column-line-color
79 f <model> >>selection-index
81 H{ } clone >>selected-indices ;
83 : <table> ( rows renderer -- table ) table new-table ;
87 GENERIC: cell-width ( font cell -- x )
88 GENERIC: cell-height ( font cell -- y )
89 GENERIC: cell-padding ( cell -- y )
90 GENERIC: draw-cell ( font cell -- )
92 M: string cell-width text-width ;
93 M: string cell-height text-height ceiling ;
94 M: string cell-padding drop 0 ;
95 M: string draw-cell draw-text ;
97 CONSTANT: image-padding 2
99 M: image-name cell-width nip image-dim first ;
100 M: image-name cell-height nip image-dim second ;
101 M: image-name cell-padding drop image-padding ;
102 M: image-name draw-cell nip draw-image ;
104 : table-rows ( table -- rows )
105 [ control-value ] [ renderer>> ] bi '[ _ row-columns ] map ;
107 : column-offsets ( widths gap -- x xs )
108 [ 0 ] dip '[ _ + + ] accumulate ;
110 CONSTANT: column-title-background COLOR: light-gray
112 : column-title-font ( font -- font' )
113 column-title-background font-with-background t >>bold? ;
115 : initial-widths ( table rows -- widths )
116 over renderer>> column-titles dup
117 [ [ drop font>> ] dip [ text-width ] with map ]
118 [ drop nip first length 0 <repetition> ]
121 : row-column-widths ( table row -- widths )
122 [ font>> ] dip [ [ cell-width ] [ cell-padding ] bi + ] with map ;
124 : compute-total-width ( gap widths -- total )
125 swap [ column-offsets drop ] keep - ;
127 : compute-column-widths ( table -- total widths )
128 dup table-rows [ drop 0 { } ] [
129 [ drop gap>> ] [ initial-widths ] [ ] 2tri
130 [ row-column-widths vmax ] with each
131 [ compute-total-width ] keep
134 : update-cached-widths ( table -- )
135 dup compute-column-widths
136 [ >>total-width ] [ >>column-widths ] bi*
139 : filled-column-width ( table -- n )
140 [ dim>> first ] [ total-width>> ] bi [-] ;
142 : update-filled-column ( table -- )
143 [ filled-column-width ]
144 [ renderer>> filled-column ]
145 [ column-widths>> ] tri
147 [ [ + ] change-nth ] [ 3drop ] if ;
150 [ update-cached-widths ] [ update-filled-column ] bi ;
152 : row-rect ( table row -- rect )
153 [ [ line-height ] dip * 0 swap 2array ]
154 [ drop [ dim>> first ] [ line-height ] bi 2array ] 2bi <rect> ;
156 : row-bounds ( table row -- loc dim )
157 row-rect rect-bounds ; inline
159 : draw-selected-rows ( table -- )
161 { [ dup selected-indices>> assoc-empty? ] [ drop ] }
163 [ selected-indices>> keys ] [ selection-color>> gl-color ] [ ] tri
164 [ swap row-bounds gl-fill-rect ] curry each
168 : draw-focused-row ( table -- )
170 { [ dup focused?>> not ] [ drop ] }
171 { [ dup selected-index not ] [ drop ] }
173 [ ] [ selected-index ] [ focus-border-color>> gl-color ] tri
178 : draw-moused-row ( table -- )
179 dup mouse-index>> dup [
180 over mouse-color>> gl-color
184 : column-line-offsets ( table -- xs )
185 [ column-widths>> ] [ gap>> ] bi
186 [ column-offsets nip [ f ] ]
187 [ 2/ '[ rest-slice [ _ - ] map ] ]
190 : draw-column-lines ( table -- )
191 [ column-line-color>> gl-color ]
193 [ column-line-offsets ] [ dim>> second ] bi
194 '[ [ 0 2array ] [ _ 2array ] bi gl-line ] each
197 :: column-loc ( font column width align -- loc )
198 font column cell-width width swap - align * column cell-padding 2 / 1 align - * +
199 font column cell-height \ line-height get swap - 2 /
200 [ >integer ] bi@ 2array ;
202 : translate-column ( width gap -- )
203 + 0 2array gl-translate ;
205 : draw-column ( font column width align gap -- )
208 [ 2dup ] 2dip column-loc
209 [ draw-cell ] with-translation
211 ] dip translate-column ;
213 : table-column-alignment ( table -- seq )
214 dup renderer>> column-alignment
215 [ ] [ column-widths>> length 0 <repetition> ] ?if ;
217 :: row-font ( row ind table -- font )
219 row table renderer>> row-color [ >>foreground ] when*
220 ind table selected-indices>> key?
221 [ table selection-color>> >>background ] when ;
223 : draw-columns ( columns widths alignment font gap -- )
224 '[ [ _ ] 3dip _ draw-column ] 3each ;
226 M: table draw-line ( row index table -- )
229 [ renderer>> row-columns ]
231 [ table-column-alignment ]
238 M: table draw-gadget*
239 dup control-value empty? [ drop ] [
240 dup line-height \ line-height [
242 [ draw-selected-rows ]
244 [ draw-column-lines ]
251 M: table line-height ( table -- y )
252 [ font>> ] [ renderer>> prototype-row ] bi
253 [ [ cell-height ] [ cell-padding ] bi + ] with
257 [ compute-column-widths drop ] keep
258 [ line-height ] [ control-value length ] bi * 2array ;
260 : nth-row ( row table -- value/f ? )
261 over [ control-value nth t ] [ 2drop f f ] if ;
265 : (selected-rows) ( table -- assoc )
266 [ selected-indices>> ] keep
267 '[ _ nth-row drop ] assoc-map ;
269 : selected-rows ( table -- assoc )
270 [ selected-indices>> ] [ ] [ renderer>> ] tri
271 '[ _ nth-row drop _ row-value ] assoc-map ;
273 : (selected-row) ( table -- value/f ? ) (selected-rows) multiple>single ;
275 : selected-row ( table -- value/f ? ) selected-rows multiple>single ;
279 : set-table-model ( model value multiple? -- )
280 [ values ] [ multiple>single drop ] if swap set-model ;
282 : update-selected ( table -- )
286 [ multiple-selection?>> ] tri
290 [ selection-index>> ]
291 [ selected-indices>> ]
292 [ multiple-selection?>> ] tri
296 : show-row-summary ( table n -- )
298 [ swap [ renderer>> row-value ] keep show-summary ]
302 : hide-mouse-help ( table -- )
303 f >>mouse-index [ hide-status ] [ relayout-1 ] bi ;
305 : find-row-index ( value table -- n/f )
306 [ model>> value>> ] [ renderer>> ] bi
307 '[ _ row-value eq? ] with find drop ;
309 : (update-selected-indices) ( table -- set )
310 [ selection>> value>> dup [ array? not ] [ ] bi and [ 1array ] when ] keep
311 '[ _ find-row-index ] map sift unique f assoc-like ;
313 : initial-selected-indices ( table -- set )
315 [ model>> value>> empty? not ]
316 [ selection-required?>> ]
317 [ drop { 0 } unique ]
320 : update-selected-indices ( table -- set )
322 [ (update-selected-indices) ]
323 [ initial-selected-indices ]
326 M: table model-changed
327 nip dup update-selected-indices {
328 [ >>selected-indices f >>mouse-index drop ]
329 [ multiple>single drop show-row-summary ]
330 [ drop update-selected ]
334 : thin-row-rect ( table row -- rect )
335 row-rect [ { 0 1 } v* ] change-dim ;
337 : scroll-to-row ( table n -- )
338 dup [ [ thin-row-rect ] [ drop ] 2bi scroll>rect ] [ 2drop ] if ;
340 : add-selected-row ( table n -- )
342 [ add-selected-index relayout-1 ] 2bi ;
344 : (select-row) ( table n -- )
346 [ set-selected-index relayout-1 ]
349 : mouse-row ( table -- n )
350 [ hand-rel second ] keep y>line ;
352 : if-mouse-row ( table true: ( mouse-index table -- ) false: ( table -- ) -- )
353 [ [ mouse-row ] keep 2dup valid-line? ]
354 [ ] [ '[ nip @ ] ] tri* if ; inline
356 : (table-button-down) ( quot table -- )
357 dup takes-focus?>> [ dup request-focus ] when swap
358 '[ swap [ >>mouse-index ] _ bi ] [ drop ] if-mouse-row ; inline
360 : table-button-down ( table -- )
361 [ (select-row) ] swap (table-button-down) ;
363 : continued-button-down ( table -- )
364 dup multiple-selection?>>
365 [ [ add-selected-row ] swap (table-button-down) ] [ table-button-down ] if ;
367 : thru-button-down ( table -- )
368 dup multiple-selection?>> [
369 [ 2dup over selected-index (a,b) swap
370 [ swap add-selected-index drop ] curry each add-selected-row ]
371 swap (table-button-down)
372 ] [ table-button-down ] if ;
376 : row-action ( table -- )
378 [ swap [ action>> call( value -- ) ] [ dup hook>> call( table -- ) ] bi ]
382 : row-action? ( table -- ? )
383 single-click?>> hand-click# get 2 = or ;
387 : table-button-up ( table -- )
388 dup [ mouse-row ] keep valid-line? [
389 dup row-action? [ row-action ] [ update-selected ] if
394 : select-row ( table n -- )
397 [ drop update-selected ]
403 : prev/next-row ( table n -- )
404 [ dup selected-index ] dip '[ _ + ] [ 0 ] if* select-row ;
406 : previous-row ( table -- )
409 : next-row ( table -- )
412 : first-row ( table -- )
415 : last-row ( table -- )
416 dup control-value length 1 - select-row ;
418 : prev/next-page ( table n -- )
419 over visible-lines 1 - * prev/next-row ;
421 : previous-page ( table -- )
424 : next-page ( table -- )
427 : show-mouse-help ( table -- )
430 [ >>mouse-index relayout-1 ]
433 ] [ hide-mouse-help ] if-mouse-row ;
435 : show-table-menu ( table -- )
441 [ renderer>> row-value ]
446 ] [ drop ] if-mouse-row ;
448 : focus-table ( table -- ) t >>focused? relayout-1 ;
450 : unfocus-table ( table -- ) f >>focused? relayout-1 ;
453 { mouse-enter show-mouse-help }
454 { mouse-leave hide-mouse-help }
455 { motion show-mouse-help }
456 { T{ button-down f { S+ } 1 } thru-button-down }
457 { T{ button-down f { A+ } 1 } continued-button-down }
458 { T{ button-up } table-button-up }
459 { T{ button-up f { S+ } } table-button-up }
460 { T{ button-down } table-button-down }
461 { gain-focus focus-table }
462 { lose-focus unfocus-table }
463 { T{ drag } table-button-down }
467 { T{ button-down f f 3 } show-table-menu }
468 { T{ key-down f f "RET" } row-action }
469 { T{ key-down f f "UP" } previous-row }
470 { T{ key-down f f "DOWN" } next-row }
471 { T{ key-down f f "HOME" } first-row }
472 { T{ key-down f f "END" } last-row }
473 { T{ key-down f f "PAGE_UP" } previous-page }
474 { T{ key-down f f "PAGE_DOWN" } next-page }
477 TUPLE: column-headers < gadget table ;
479 : <column-headers> ( table -- gadget )
482 column-title-background <solid> >>interior ;
484 : draw-column-titles ( table -- )
485 dup font>> font-metrics height>> \ line-height [
487 [ renderer>> column-titles ]
489 [ table-column-alignment ]
490 [ font>> column-title-font ]
496 M: column-headers draw-gadget*
497 table>> draw-column-titles ;
499 M: column-headers pref-dim*
500 table>> [ pref-dim first ] [ font>> "" text-height ] bi 2array ;
502 M: table viewport-column-header
503 dup renderer>> column-titles
504 [ <column-headers> ] [ drop f ] if ;