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 ;
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-summary ( row renderer -- object )
21 GENERIC: row-color ( row renderer -- color )
22 GENERIC: row-value? ( value row renderer -- ? )
24 SINGLETON: trivial-renderer
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 ;
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? ;
37 TUPLE: table < line-gadget
38 { renderer initial: trivial-renderer }
39 { action initial: [ drop ] }
41 { hook initial: [ drop ] }
43 column-widths total-width
51 { takes-focus? initial: t }
55 : new-table ( rows renderer class -- table )
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 ;
65 : <table> ( rows renderer -- table ) table new-table ;
69 GENERIC: cell-dim ( font cell -- width height padding )
70 GENERIC: draw-cell ( font cell -- )
72 M: f cell-dim 2drop 0 0 0 ;
73 M: f draw-cell 2drop ;
75 : single-line ( str -- str' )
76 dup [ "\r\n" member? ] any? [ split-lines join-words ] when ;
78 M: string cell-dim single-line text-dim first2 ceiling 0 ;
79 M: string draw-cell single-line draw-text ;
81 CONSTANT: image-padding 2
83 M: image-name cell-dim nip image-dim first2 image-padding ;
84 M: image-name draw-cell nip draw-image ;
86 : column-offsets ( widths gap -- x xs )
87 [ 0 ] dip '[ _ + + ] accumulate ;
89 : column-title-font ( font -- font' )
90 column-title-background font-with-background t >>bold? ;
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> ]
98 : row-column-widths ( table row -- widths )
99 [ font>> ] dip [ cell-dim nip + ] with map ;
101 : compute-total-width ( gap widths -- total )
102 swap [ column-offsets drop ] keep - ;
104 GENERIC: compute-column-widths ( table -- total widths )
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
113 : update-cached-widths ( table -- )
114 dup compute-column-widths
115 [ >>total-width ] [ >>column-widths ] bi*
118 : filled-column-width ( table -- n )
119 [ dim>> first ] [ total-width>> ] bi [-] ;
121 : update-filled-column ( table -- )
122 [ filled-column-width ]
123 [ renderer>> filled-column ]
124 [ column-widths>> ] tri
126 [ [ + ] change-nth ] [ 3drop ] if ;
129 [ update-cached-widths ] [ update-filled-column ] bi ;
131 : row-rect ( table row -- rect )
132 [ [ line-height ] dip * 0 swap 2array ]
133 [ drop [ dim>> first ] [ line-height ] bi 2array ] 2bi <rect> ;
135 : row-bounds ( table row -- loc dim )
136 row-rect rect-bounds ; inline
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
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
150 : draw-moused-row ( table -- )
152 dup mouse-color>> [ text-color ] unless* gl-color
153 dup mouse-index>> row-bounds gl-rect
156 : column-line-offsets ( table -- xs )
157 [ column-widths>> ] [ gap>> ] bi
158 [ column-offsets nip [ f ] ]
159 [ 2/ '[ rest-slice [ _ - ] map ] ]
162 : draw-column-lines ( table -- )
163 [ column-line-color>> gl-color ]
165 [ column-line-offsets ] [ dim>> second ] bi
166 '[ [ 0 2array ] [ _ 2array ] bi gl-line ] each
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 ;
176 : translate-column ( width gap -- )
177 + 0 2array gl-translate ;
179 : draw-column ( font column width align gap -- )
182 [ 2dup ] 2dip column-loc
183 [ draw-cell ] with-translation
185 ] dip translate-column ;
187 : table-column-alignment ( table -- seq )
188 [ renderer>> column-alignment ]
189 [ column-widths>> length 0 <repetition> ] ?unless ;
191 :: row-font ( row index table -- font )
193 row table renderer>> row-color [ >>foreground ] when*
194 index table selection-index>> value>> =
195 [ table selection-color>> >>background ] when ;
197 : draw-columns ( columns widths alignment font gap -- )
198 '[ [ _ ] 3dip _ draw-column ] 3each ;
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
208 M: table draw-gadget*
209 dup control-value empty? [ drop ] [
210 dup line-height \ line-height [
212 [ draw-selected-row ]
214 [ draw-column-lines ]
221 M: table line-height*
222 [ font>> ] [ renderer>> prototype-row ] bi
223 [ cell-dim + nip ] with [ max ] map-reduce ;
226 [ compute-column-widths drop ] keep
227 [ line-height ] [ control-value length ] bi * 2array ;
229 : nth-row ( index table -- value/f ? )
230 over [ control-value nth t ] [ 2drop f f ] if ;
234 : (selected-row) ( table -- value/f ? )
235 [ selection-index>> value>> ] keep nth-row ;
237 : selected-row ( table -- value/f ? )
238 [ (selected-row) ] [ renderer>> ] bi
239 swap [ row-value t ] [ 2drop f f ] if ;
243 : show-row-summary ( table n -- )
245 [ swap [ renderer>> row-summary ] keep show-summary ]
249 : update-status ( table -- )
251 [ dup selection-index>> value>> ] unless*
254 : hide-mouse-help ( table -- )
255 f >>mouse-index [ update-status ] [ relayout-1 ] bi ;
257 : select-table-row ( n table -- )
258 [ selection-index>> set-model ]
259 [ [ selected-row drop ] keep selection>> set-model ]
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
267 : initial-selection-index ( table -- n/f )
269 [ control-value empty? not ]
270 [ selection-required?>> ]
274 : find-row-index ( value table -- n/f )
275 [ control-value ] [ renderer>> ] bi
276 '[ _ row-value? ] with find drop ;
278 : update-table-rows ( table -- )
280 [ control-value ] [ renderer>> ] bi
281 '[ _ row-columns ] map
283 [ rows<< ] bi ; inline
285 : update-selection ( table -- )
288 [ [ selection>> value>> ] keep find-row-index ]
289 [ initial-selection-index ]
292 over [ select-table-row ] [
293 [ selection-index>> set-model ]
294 [ selection>> set-model ]
298 M: table model-changed
300 dup update-table-rows
302 dup update-mouse-index
303 [ update-status ] [ relayout ] bi ;
305 : thin-row-rect ( table row -- rect )
306 row-rect [ { 0 1 } v* ] change-dim ;
308 : scroll-to-row ( table n -- )
309 [ [ thin-row-rect ] [ drop ] 2bi scroll>rect ] [ drop ] if* ;
311 : (select-row) ( table n -- )
313 [ swap select-table-row ]
317 : mouse-row ( table -- n )
318 [ hand-rel second ] keep y>line ;
320 : if-mouse-row ( table true: ( mouse-index table -- ) false: ( table -- ) -- )
321 [ [ mouse-row ] keep 2dup valid-line? ]
322 [ ] [ '[ nip @ ] ] tri* if ; inline
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
330 : row-action ( table -- )
332 over action>> call( value -- )
333 ] [ drop ] if dup hook>> call( table -- ) ;
335 : row-action? ( table -- ? )
336 single-click?>> hand-click# get 2 = or ;
340 : table-button-up ( table -- )
341 dup [ mouse-row ] keep valid-line? [
342 dup row-action? [ row-action ] [ drop ] if
347 : select-row ( table n -- )
349 [ (select-row) ] [ show-row-summary ] 2bi ;
353 : prev/next-row ( table n -- )
354 [ dup selection-index>> value>> ] dip
355 '[ _ + ] [ 0 ] if* select-row ;
357 : previous-row ( table -- )
360 : next-row ( table -- )
363 : first-row ( table -- )
366 : last-row ( table -- )
367 dup control-value length 1 - select-row ;
369 : prev/next-page ( table n -- )
370 over visible-lines 1 - * prev/next-row ;
372 : previous-page ( table -- )
375 : next-page ( table -- )
378 : show-mouse-help ( table -- )
381 [ >>mouse-index relayout-1 ]
384 ] [ hide-mouse-help ] if-mouse-row ;
386 : show-table-menu ( table -- )
392 [ renderer>> row-value ]
397 ] [ drop ] if-mouse-row ;
399 : focus-table ( table -- ) t >>focused? relayout-1 ;
401 : unfocus-table ( table -- ) f >>focused? relayout-1 ;
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 }
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 f "DOWN" } next-row }
420 { T{ key-down f f "HOME" } first-row }
421 { T{ key-down f f "END" } last-row }
422 { T{ key-down f f "PAGE_UP" } previous-page }
423 { T{ key-down f f "PAGE_DOWN" } next-page }
426 TUPLE: column-headers < gadget table ;
428 : <column-headers> ( table -- gadget )
431 column-title-background <solid> >>interior ;
433 : draw-column-titles ( table -- )
434 dup font>> font-metrics height>> \ line-height [
436 [ renderer>> column-titles ]
438 [ table-column-alignment ]
439 [ font>> column-title-font ]
445 M: column-headers draw-gadget*
446 table>> draw-column-titles ;
448 M: column-headers pref-dim*
449 table>> [ pref-dim first ] [ font>> "" text-height ] bi 2array ;
451 M: table viewport-column-header
452 dup renderer>> column-titles
453 [ <column-headers> ] [ drop f ] if ;