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 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 )
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
43 { mouse-color initial: COLOR: black }
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 : single-line ( str -- str' )
71 dup [ "\r\n" member? ] any? [ string-lines " " join ] when ;
73 M: string cell-dim single-line text-dim first2 ceiling 0 ;
74 M: string draw-cell single-line draw-text ;
76 CONSTANT: image-padding 2
78 M: image-name cell-dim nip image-dim first2 image-padding ;
79 M: image-name draw-cell nip draw-image ;
81 : column-offsets ( widths gap -- x xs )
82 [ 0 ] dip '[ _ + + ] accumulate ;
84 : column-title-font ( font -- font' )
85 column-title-background font-with-background t >>bold? ;
87 : initial-widths ( table rows -- widths )
88 over renderer>> column-titles dup
89 [ [ drop font>> ] dip [ text-width ] with map ]
90 [ drop nip first length 0 <repetition> ]
93 : row-column-widths ( table row -- widths )
94 [ font>> ] dip [ cell-dim nip + ] with map ;
96 : compute-total-width ( gap widths -- total )
97 swap [ column-offsets drop ] keep - ;
99 : compute-column-widths ( table -- total widths )
100 dup rows>> [ drop 0 { } ] [
101 [ drop gap>> ] [ initial-widths ] [ ] 2tri
102 [ row-column-widths vmax ] with each
103 [ compute-total-width ] keep
106 : update-cached-widths ( table -- )
107 dup compute-column-widths
108 [ >>total-width ] [ >>column-widths ] bi*
111 : filled-column-width ( table -- n )
112 [ dim>> first ] [ total-width>> ] bi [-] ;
114 : update-filled-column ( table -- )
115 [ filled-column-width ]
116 [ renderer>> filled-column ]
117 [ column-widths>> ] tri
119 [ [ + ] change-nth ] [ 3drop ] if ;
122 [ update-cached-widths ] [ update-filled-column ] bi ;
124 : row-rect ( table row -- rect )
125 [ [ line-height ] dip * 0 swap 2array ]
126 [ drop [ dim>> first ] [ line-height ] bi 2array ] 2bi <rect> ;
128 : row-bounds ( table row -- loc dim )
129 row-rect rect-bounds ; inline
131 : draw-selected-row ( table -- )
132 dup selection-index>> value>> [
133 dup selection-color>> gl-color
134 dup selection-index>> value>> row-bounds gl-fill-rect
137 : draw-focused-row ( table -- )
138 dup { [ focused?>> ] [ selection-index>> value>> ] } 1&& [
139 dup focus-border-color>> gl-color
140 dup selection-index>> value>> row-bounds gl-rect
143 : draw-moused-row ( table -- )
145 dup mouse-color>> gl-color
146 dup mouse-index>> row-bounds gl-rect
149 : column-line-offsets ( table -- xs )
150 [ column-widths>> ] [ gap>> ] bi
151 [ column-offsets nip [ f ] ]
152 [ 2/ '[ rest-slice [ _ - ] map ] ]
155 : draw-column-lines ( table -- )
156 [ column-line-color>> gl-color ]
158 [ column-line-offsets ] [ dim>> second ] bi
159 '[ [ 0 2array ] [ _ 2array ] bi gl-line ] each
162 :: column-loc ( font column width align -- loc )
163 font column cell-dim :> ( cell-width cell-height cell-padding )
164 cell-width width swap - align *
165 cell-padding 2 / 1 align - * +
166 cell-height \ line-height get swap - 2 /
167 [ >integer ] bi@ 2array ;
169 : translate-column ( width gap -- )
170 + 0 2array gl-translate ;
172 : draw-column ( font column width align gap -- )
175 [ 2dup ] 2dip column-loc
176 [ draw-cell ] with-translation
178 ] dip translate-column ;
180 : table-column-alignment ( table -- seq )
181 dup renderer>> column-alignment
182 [ ] [ column-widths>> length 0 <repetition> ] ?if ;
184 :: row-font ( row index table -- font )
186 row table renderer>> row-color [ >>foreground ] when*
187 index table selection-index>> value>> =
188 [ table selection-color>> >>background ] when ;
190 : draw-columns ( columns widths alignment font gap -- )
191 '[ [ _ ] 3dip _ draw-column ] 3each ;
193 M:: table draw-line ( row index table -- )
194 row table renderer>> row-columns
195 table column-widths>>
196 table table-column-alignment
197 row index table row-font
201 M: table draw-gadget*
202 dup control-value empty? [ drop ] [
203 dup line-height \ line-height [
205 [ draw-selected-row ]
207 [ draw-column-lines ]
214 M: table line-height* ( table -- y )
215 [ font>> ] [ renderer>> prototype-row ] bi
216 [ cell-dim + nip ] with [ max ] map-reduce ;
219 [ compute-column-widths drop ] keep
220 [ line-height ] [ control-value length ] bi * 2array ;
222 : nth-row ( index table -- value/f ? )
223 over [ control-value nth t ] [ 2drop f f ] if ;
227 : (selected-row) ( table -- value/f ? )
228 [ selection-index>> value>> ] keep nth-row ;
230 : selected-row ( table -- value/f ? )
231 [ (selected-row) ] [ renderer>> ] bi
232 swap [ row-value t ] [ 2drop f f ] if ;
236 : show-row-summary ( table n -- )
238 [ swap [ renderer>> row-value ] keep show-summary ]
242 : update-status ( table -- )
244 [ dup selection-index>> value>> ] unless*
247 : hide-mouse-help ( table -- )
248 f >>mouse-index [ update-status ] [ relayout-1 ] bi ;
250 : select-table-row ( n table -- )
251 [ selection-index>> set-model ]
252 [ [ selected-row drop ] keep selection>> set-model ]
255 : update-mouse-index ( table -- )
256 dup [ control-value ] [ mouse-index>> ] bi
257 dup [ swap length [ drop f ] [ 1 - min ] if-zero ] [ 2drop f ] if
260 : initial-selection-index ( table -- n/f )
262 [ control-value empty? not ]
263 [ selection-required?>> ]
267 : find-row-index ( value table -- n/f )
268 [ control-value ] [ renderer>> ] bi
269 '[ _ row-value? ] with find drop ;
271 : update-table-rows ( table -- )
273 [ control-value ] [ renderer>> ] bi
274 '[ _ row-columns ] map
276 [ rows<< ] bi ; inline
278 : update-selection ( table -- )
281 [ [ selection>> value>> ] keep find-row-index ]
282 [ initial-selection-index ]
285 over [ select-table-row ] [
286 [ selection-index>> set-model ]
287 [ selection>> set-model ]
291 M: table model-changed
293 dup update-table-rows
295 dup update-mouse-index
296 [ update-status ] [ relayout ] bi ;
298 : thin-row-rect ( table row -- rect )
299 row-rect [ { 0 1 } v* ] change-dim ;
301 : scroll-to-row ( table n -- )
302 dup [ [ thin-row-rect ] [ drop ] 2bi scroll>rect ] [ 2drop ] if ;
304 : (select-row) ( table n -- )
306 [ swap select-table-row ]
310 : mouse-row ( table -- n )
311 [ hand-rel second ] keep y>line ;
313 : if-mouse-row ( table true: ( mouse-index table -- ) false: ( table -- ) -- )
314 [ [ mouse-row ] keep 2dup valid-line? ]
315 [ ] [ '[ nip @ ] ] tri* if ; inline
317 : table-button-down ( table -- )
318 dup takes-focus?>> [ dup request-focus ] when
319 [ swap [ >>mouse-index ] [ (select-row) ] bi ] [ drop ] if-mouse-row ; inline
323 : row-action ( table -- )
325 [ swap [ dup hook>> call( table -- ) ] [ action>> call( value -- ) ] bi ]
329 : row-action? ( table -- ? )
330 single-click?>> hand-click# get 2 = or ;
334 : table-button-up ( table -- )
335 dup [ mouse-row ] keep valid-line? [
336 dup row-action? [ row-action ] [ drop ] if
341 : select-row ( table n -- )
343 [ (select-row) ] [ show-row-summary ] 2bi ;
347 : prev/next-row ( table n -- )
348 [ dup selection-index>> value>> ] dip
349 '[ _ + ] [ 0 ] if* select-row ;
351 : previous-row ( table -- )
354 : next-row ( table -- )
357 : first-row ( table -- )
360 : last-row ( table -- )
361 dup control-value length 1 - select-row ;
363 : prev/next-page ( table n -- )
364 over visible-lines 1 - * prev/next-row ;
366 : previous-page ( table -- )
369 : next-page ( table -- )
372 : show-mouse-help ( table -- )
375 [ >>mouse-index relayout-1 ]
378 ] [ hide-mouse-help ] if-mouse-row ;
380 : show-table-menu ( table -- )
386 [ renderer>> row-value ]
391 ] [ drop ] if-mouse-row ;
393 : focus-table ( table -- ) t >>focused? relayout-1 ;
395 : unfocus-table ( table -- ) f >>focused? relayout-1 ;
398 { mouse-enter show-mouse-help }
399 { mouse-leave hide-mouse-help }
400 { motion show-mouse-help }
401 { T{ button-up } table-button-up }
402 { T{ button-up f { S+ } } table-button-up }
403 { T{ button-down } table-button-down }
404 { gain-focus focus-table }
405 { lose-focus unfocus-table }
406 { T{ drag } table-button-down }
410 { T{ button-down f f 3 } show-table-menu }
411 { T{ key-down f f "RET" } row-action }
412 { T{ key-down f f "UP" } previous-row }
413 { T{ key-down f f "DOWN" } next-row }
414 { T{ key-down f f "HOME" } first-row }
415 { T{ key-down f f "END" } last-row }
416 { T{ key-down f f "PAGE_UP" } previous-page }
417 { T{ key-down f f "PAGE_DOWN" } next-page }
420 TUPLE: column-headers < gadget table ;
422 : <column-headers> ( table -- gadget )
425 column-title-background <solid> >>interior ;
427 : draw-column-titles ( table -- )
428 dup font>> font-metrics height>> \ line-height [
430 [ renderer>> column-titles ]
432 [ table-column-alignment ]
433 [ font>> column-title-font ]
439 M: column-headers draw-gadget*
440 table>> draw-column-titles ;
442 M: column-headers pref-dim*
443 table>> [ pref-dim first ] [ font>> "" text-height ] bi 2array ;
445 M: table viewport-column-header
446 dup renderer>> column-titles
447 [ <column-headers> ] [ drop f ] if ;