1 ! Copyright (C) 2006 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
4 USING: gadgets gadgets-scrolling kernel sequences models opengl
7 TUPLE: list index presenter action color ;
9 : list-theme ( list -- )
10 { 0.8 0.8 1.0 1.0 } swap set-list-color ;
12 C: list ( model presenter action -- gadget )
13 [ set-list-action ] keep
14 [ set-list-presenter ] keep
15 dup rot <pile> 1 over set-pack-fill delegate>control
19 : bound-index ( list -- )
20 dup list-index over control-value length 1- max 0 min
25 dup control-value over list-presenter map over add-gadgets
28 : selected-rect ( list -- rect )
29 dup list-index swap gadget-children 2dup bounds-check?
30 [ nth ] [ 2drop f ] if ;
33 dup list-color gl-color
35 rect-bounds >r origin get v+ r> gl-fill-rect
38 M: list focusable-child* drop t ;
40 : list-value ( list -- object )
41 dup list-index swap control-value ?nth ;
43 : scroll>selected ( list -- )
44 #! We change the rectangle's width to zero to avoid
46 [ selected-rect rect-bounds { 0 1 } v* <rect> ] keep
49 : list-empty? ( list -- ? ) control-value empty? ;
51 : select-index ( n list -- )
55 [ control-value length rem ] keep
56 [ set-list-index ] keep
61 : select-prev ( list -- )
62 dup list-index 1- swap select-index ;
64 : select-next ( list -- )
65 dup list-index 1+ swap select-index ;
67 : call-action ( list -- )
69 dup list-value over list-action call
72 : click-list ( list -- )
73 hand-gadget get [ gadget-parent list? ] find-parent
75 over gadget-children index dup -1 =
76 [ 2drop ] [ swap select-index ] if
82 { T{ button-down } [ dup request-focus click-list ] }
83 { T{ drag } [ click-list ] }
84 { T{ key-down f f "UP" } [ select-prev ] }
85 { T{ key-down f f "DOWN" } [ select-next ] }
86 { T{ key-down f f "RETURN" } [ call-action ] }