1 ! Copyright (C) 2008, 2011 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors arrays colors colors.constants combinators
4 combinators.short-circuit fonts fry kernel locals math
5 math.functions math.order math.rectangles math.vectors models
6 namespaces opengl sequences splitting strings ui.commands
7 ui.gadgets ui.gadgets.line-support ui.gadgets.menus
8 ui.gadgets.scrollers ui.gadgets.status-bar ui.gadgets.worlds
9 ui.gestures ui.images ui.pens.solid ui.render ui.text ui.theme ;
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 )
18 GENERIC: row-columns ( row renderer -- columns )
19 GENERIC: row-value ( row renderer -- object )
20 GENERIC: row-color ( row renderer -- color )
21 GENERIC: row-value? ( value row renderer -- ? )
23 SINGLETON: trivial-renderer
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 ;
30 M: trivial-renderer row-columns drop ;
31 M: object row-value drop ;
32 M: object row-color 2drop f ;
33 M: object row-value? drop eq? ;
35 TUPLE: table < line-gadget
36 { renderer initial: trivial-renderer }
37 { action initial: [ drop ] }
39 { hook initial: [ drop ] }
41 column-widths total-width
49 { takes-focus? initial: t }
53 : new-table ( rows renderer class -- table )
57 sans-serif-font >>font
58 focus-border-color >>focus-border-color
59 transparent >>column-line-color
60 f <model> >>selection-index
61 f <model> >>selection ;
63 : <table> ( rows renderer -- table ) table new-table ;
67 GENERIC: cell-dim ( font cell -- width height padding )
68 GENERIC: draw-cell ( font cell -- )
70 M: f cell-dim 2drop 0 0 0 ;
71 M: f draw-cell 2drop ;
73 : single-line ( str -- str' )
74 dup [ "\r\n" member? ] any? [ lines " " join ] when ;
76 M: string cell-dim single-line text-dim first2 ceiling 0 ;
77 M: string draw-cell single-line draw-text ;
79 CONSTANT: image-padding 2
81 M: image-name cell-dim nip image-dim first2 image-padding ;
82 M: image-name draw-cell nip draw-image ;
84 : column-offsets ( widths gap -- x xs )
85 [ 0 ] dip '[ _ + + ] accumulate ;
87 : column-title-font ( font -- font' )
88 column-title-background font-with-background t >>bold? ;
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> ]
96 : row-column-widths ( table row -- widths )
97 [ font>> ] dip [ cell-dim nip + ] with map ;
99 : compute-total-width ( gap widths -- total )
100 swap [ column-offsets drop ] keep - ;
102 GENERIC: compute-column-widths ( table -- total widths )
104 M: table compute-column-widths
105 dup rows>> [ drop 0 { } ] [
106 [ drop gap>> ] [ initial-widths ] [ ] 2tri
107 [ row-column-widths vmax ] with each
108 [ compute-total-width ] keep
111 : update-cached-widths ( table -- )
112 dup compute-column-widths
113 [ >>total-width ] [ >>column-widths ] bi*
116 : filled-column-width ( table -- n )
117 [ dim>> first ] [ total-width>> ] bi [-] ;
119 : update-filled-column ( table -- )
120 [ filled-column-width ]
121 [ renderer>> filled-column ]
122 [ column-widths>> ] tri
124 [ [ + ] change-nth ] [ 3drop ] if ;
127 [ update-cached-widths ] [ update-filled-column ] bi ;
129 : row-rect ( table row -- rect )
130 [ [ line-height ] dip * 0 swap 2array ]
131 [ drop [ dim>> first ] [ line-height ] bi 2array ] 2bi <rect> ;
133 : row-bounds ( table row -- loc dim )
134 row-rect rect-bounds ; inline
136 : draw-selected-row ( table -- )
137 dup selection-index>> value>> [
138 dup selection-color>> gl-color
139 dup selection-index>> value>> row-bounds gl-fill-rect
142 : draw-focused-row ( table -- )
143 dup { [ focused?>> ] [ selection-index>> value>> ] } 1&& [
144 dup focus-border-color>> gl-color
145 dup selection-index>> value>> row-bounds gl-rect
148 : draw-moused-row ( table -- )
150 dup mouse-color>> [ text-color ] unless* gl-color
151 dup mouse-index>> row-bounds gl-rect
154 : column-line-offsets ( table -- xs )
155 [ column-widths>> ] [ gap>> ] bi
156 [ column-offsets nip [ f ] ]
157 [ 2/ '[ rest-slice [ _ - ] map ] ]
160 : draw-column-lines ( table -- )
161 [ column-line-color>> gl-color ]
163 [ column-line-offsets ] [ dim>> second ] bi
164 '[ [ 0 2array ] [ _ 2array ] bi gl-line ] each
167 :: column-loc ( font column width align -- loc )
168 font column cell-dim :> ( cell-width cell-height cell-padding )
169 cell-width width swap - align *
170 cell-padding 2 / 1 align - * +
171 cell-height \ line-height get swap - 2 /
172 [ >integer ] bi@ 2array ;
174 : translate-column ( width gap -- )
175 + 0 2array gl-translate ;
177 : draw-column ( font column width align gap -- )
180 [ 2dup ] 2dip column-loc
181 [ draw-cell ] with-translation
183 ] dip translate-column ;
185 : table-column-alignment ( table -- seq )
186 dup renderer>> column-alignment
187 [ ] [ column-widths>> length 0 <repetition> ] ?if ;
189 :: row-font ( row index table -- font )
191 row table renderer>> row-color [ >>foreground ] when*
192 index table selection-index>> value>> =
193 [ table selection-color>> >>background ] when ;
195 : draw-columns ( columns widths alignment font gap -- )
196 '[ [ _ ] 3dip _ draw-column ] 3each ;
198 M:: table draw-line ( row index table -- )
199 row table renderer>> row-columns
200 table column-widths>>
201 table table-column-alignment
202 row index table row-font
206 M: table draw-gadget*
207 dup control-value empty? [ drop ] [
208 dup line-height \ line-height [
210 [ draw-selected-row ]
212 [ draw-column-lines ]
219 M: table line-height*
220 [ font>> ] [ renderer>> prototype-row ] bi
221 [ cell-dim + nip ] with [ max ] map-reduce ;
224 [ compute-column-widths drop ] keep
225 [ line-height ] [ control-value length ] bi * 2array ;
227 : nth-row ( index table -- value/f ? )
228 over [ control-value nth t ] [ 2drop f f ] if ;
232 : (selected-row) ( table -- value/f ? )
233 [ selection-index>> value>> ] keep nth-row ;
235 : selected-row ( table -- value/f ? )
236 [ (selected-row) ] [ renderer>> ] bi
237 swap [ row-value t ] [ 2drop f f ] if ;
241 : show-row-summary ( table n -- )
243 [ swap [ renderer>> row-value ] keep show-summary ]
247 : update-status ( table -- )
249 [ dup selection-index>> value>> ] unless*
252 : hide-mouse-help ( table -- )
253 f >>mouse-index [ update-status ] [ relayout-1 ] bi ;
255 : select-table-row ( n table -- )
256 [ selection-index>> set-model ]
257 [ [ selected-row drop ] keep selection>> set-model ]
260 : update-mouse-index ( table -- )
261 dup [ control-value ] [ mouse-index>> ] bi
262 dup [ swap length [ drop f ] [ 1 - min ] if-zero ] [ 2drop f ] if
265 : initial-selection-index ( table -- n/f )
267 [ control-value empty? not ]
268 [ selection-required?>> ]
272 : find-row-index ( value table -- n/f )
273 [ control-value ] [ renderer>> ] bi
274 '[ _ row-value? ] with find drop ;
276 : update-table-rows ( table -- )
278 [ control-value ] [ renderer>> ] bi
279 '[ _ row-columns ] map
281 [ rows<< ] bi ; inline
283 : update-selection ( table -- )
286 [ [ selection>> value>> ] keep find-row-index ]
287 [ initial-selection-index ]
290 over [ select-table-row ] [
291 [ selection-index>> set-model ]
292 [ selection>> set-model ]
296 M: table model-changed
298 dup update-table-rows
300 dup update-mouse-index
301 [ update-status ] [ relayout ] bi ;
303 : thin-row-rect ( table row -- rect )
304 row-rect [ { 0 1 } v* ] change-dim ;
306 : scroll-to-row ( table n -- )
307 [ [ thin-row-rect ] [ drop ] 2bi scroll>rect ] [ drop ] if* ;
309 : (select-row) ( table n -- )
311 [ swap select-table-row ]
315 : mouse-row ( table -- n )
316 [ hand-rel second ] keep y>line ;
318 : if-mouse-row ( table true: ( mouse-index table -- ) false: ( table -- ) -- )
319 [ [ mouse-row ] keep 2dup valid-line? ]
320 [ ] [ '[ nip @ ] ] tri* if ; inline
322 : table-button-down ( table -- )
323 dup takes-focus?>> [ dup request-focus ] when
324 [ swap [ >>mouse-index ] [ (select-row) ] bi ] [ drop ] if-mouse-row ; inline
328 : row-action ( table -- )
330 over action>> call( value -- )
331 ] [ drop ] if dup hook>> call( table -- ) ;
333 : row-action? ( table -- ? )
334 single-click?>> hand-click# get 2 = or ;
338 : table-button-up ( table -- )
339 dup [ mouse-row ] keep valid-line? [
340 dup row-action? [ row-action ] [ drop ] if
345 : select-row ( table n -- )
347 [ (select-row) ] [ show-row-summary ] 2bi ;
351 : prev/next-row ( table n -- )
352 [ dup selection-index>> value>> ] dip
353 '[ _ + ] [ 0 ] if* select-row ;
355 : previous-row ( table -- )
358 : next-row ( table -- )
361 : first-row ( table -- )
364 : last-row ( table -- )
365 dup control-value length 1 - select-row ;
367 : prev/next-page ( table n -- )
368 over visible-lines 1 - * prev/next-row ;
370 : previous-page ( table -- )
373 : next-page ( table -- )
376 : show-mouse-help ( table -- )
379 [ >>mouse-index relayout-1 ]
382 ] [ hide-mouse-help ] if-mouse-row ;
384 : show-table-menu ( table -- )
390 [ renderer>> row-value ]
395 ] [ drop ] if-mouse-row ;
397 : focus-table ( table -- ) t >>focused? relayout-1 ;
399 : unfocus-table ( table -- ) f >>focused? relayout-1 ;
402 { mouse-enter show-mouse-help }
403 { mouse-leave hide-mouse-help }
404 { motion show-mouse-help }
405 { T{ button-up } table-button-up }
406 { T{ button-up f { S+ } } table-button-up }
407 { T{ button-down } table-button-down }
408 { gain-focus focus-table }
409 { lose-focus unfocus-table }
410 { T{ drag } table-button-down }
414 { T{ button-down f f 3 } show-table-menu }
415 { T{ key-down f f "RET" } row-action }
416 { T{ key-down f f "UP" } previous-row }
417 { T{ key-down f f "DOWN" } next-row }
418 { T{ key-down f f "HOME" } first-row }
419 { T{ key-down f f "END" } last-row }
420 { T{ key-down f f "PAGE_UP" } previous-page }
421 { T{ key-down f f "PAGE_DOWN" } next-page }
424 TUPLE: column-headers < gadget table ;
426 : <column-headers> ( table -- gadget )
429 column-title-background <solid> >>interior ;
431 : draw-column-titles ( table -- )
432 dup font>> font-metrics height>> \ line-height [
434 [ renderer>> column-titles ]
436 [ table-column-alignment ]
437 [ font>> column-title-font ]
443 M: column-headers draw-gadget*
444 table>> draw-column-titles ;
446 M: column-headers pref-dim*
447 table>> [ pref-dim first ] [ font>> "" text-height ] bi 2array ;
449 M: table viewport-column-header
450 dup renderer>> column-titles
451 [ <column-headers> ] [ drop f ] if ;