1 ! Copyright (C) 2006, 2009 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors math.vectors classes.tuple math.rectangles colors
4 kernel sequences models opengl math math.order namespaces
5 ui.commands ui.gestures ui.render ui.gadgets ui.gadgets.labels
6 ui.gadgets.scrollers ui.gadgets.presentations ui.gadgets.viewports
10 TUPLE: list < pack index presenter color hook ;
12 : list-theme ( list -- list )
13 selection-color >>color ; inline
15 : <list> ( hook presenter model -- gadget )
25 : calc-bounded-index ( n list -- m )
26 control-value length 1- min 0 max ;
28 : bound-index ( list -- )
29 dup index>> over calc-bounded-index >>index drop ;
31 : list-presentation-hook ( list -- quot )
32 hook>> [ [ list? ] find-parent ] prepend ;
34 : <list-presentation> ( hook elt presenter -- gadget )
35 [ call( elt -- obj ) ] [ drop ] 2bi [ >label text-theme ] dip
39 : <list-items> ( list -- seq )
40 [ list-presentation-hook ]
44 [ 2dup ] dip swap <list-presentation>
50 dup <list-items> add-gadgets
53 : selected-rect ( list -- rect )
54 dup index>> swap children>> ?nth ;
60 rect-bounds gl-fill-rect
64 M: list focusable-child* drop t ;
66 : list-value ( list -- object )
67 dup index>> swap control-value ?nth ;
69 : scroll>selected ( list -- )
70 #! We change the rectangle's width to zero to avoid
72 [ selected-rect rect-bounds { 0 1 } v* <rect> ] keep
75 : list-empty? ( list -- ? ) control-value empty? ;
77 : select-index ( n list -- )
81 tuck control-value length rem >>index
82 [ relayout-1 ] [ scroll>selected ] bi
85 : select-previous ( list -- )
86 [ index>> 1- ] keep select-index ;
88 : select-next ( list -- )
89 [ index>> 1+ ] keep select-index ;
91 : invoke-value-action ( list -- )
93 dup hook>> call( list -- )
95 [ index>> ] keep nth-gadget invoke-secondary
98 : select-gadget ( gadget list -- )
100 [ swap select-index ] [ drop ] if* ;
102 : clamp-loc ( point max -- point )
105 : select-at ( point list -- )
106 [ dim>> clamp-loc ] keep
110 : list-page ( list vec -- )
111 [ dup selected-rect rect-bounds 2 v/n v+ over visible-dim ] dip
112 v* v+ swap select-at ;
114 : list-page-up ( list -- ) { 0 -1 } list-page ;
116 : list-page-down ( list -- ) { 0 1 } list-page ;
118 list "keyboard-navigation" "Lists can be navigated from the keyboard." {
119 { T{ button-down } request-focus }
120 { T{ key-down f f "UP" } select-previous }
121 { T{ key-down f f "DOWN" } select-next }
122 { T{ key-down f f "PAGE_UP" } list-page-up }
123 { T{ key-down f f "PAGE_DOWN" } list-page-down }
124 { T{ key-down f f "RET" } invoke-value-action }