1 ! Copyright (C) 2005, 2008 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors arrays assocs kernel math models namespaces
4 make sequences words strings system hashtables math.parser
5 math.vectors classes.tuple classes ui.gadgets boxes calendar
6 alarms symbols combinators sets columns ;
9 : set-gestures ( class hash -- ) "gestures" set-word-prop ;
11 GENERIC: handle-gesture ( gesture gadget -- ? )
13 M: object handle-gesture
14 tuck class superclasses
15 [ "gestures" word-prop ] map
16 assoc-stack dup [ call f ] [ 2drop t ] if ;
18 : send-gesture ( gesture gadget -- ? )
19 [ dupd handle-gesture ] each-parent nip ;
21 : user-input ( str gadget -- )
23 [ [ dupd user-input* ] each-parent ] unless
27 TUPLE: motion ; C: <motion> motion
28 TUPLE: drag # ; C: <drag> drag
29 TUPLE: button-up mods # ; C: <button-up> button-up
30 TUPLE: button-down mods # ; C: <button-down> button-down
31 TUPLE: mouse-scroll ; C: <mouse-scroll> mouse-scroll
32 TUPLE: mouse-enter ; C: <mouse-enter> mouse-enter
33 TUPLE: mouse-leave ; C: <mouse-leave> mouse-leave
34 TUPLE: lose-focus ; C: <lose-focus> lose-focus
35 TUPLE: gain-focus ; C: <gain-focus> gain-focus
37 ! Higher-level actions
38 TUPLE: cut-action ; C: <cut-action> cut-action
39 TUPLE: copy-action ; C: <copy-action> copy-action
40 TUPLE: paste-action ; C: <paste-action> paste-action
41 TUPLE: delete-action ; C: <delete-action> delete-action
42 TUPLE: select-all-action ; C: <select-all-action> select-all-action
44 TUPLE: left-action ; C: <left-action> left-action
45 TUPLE: right-action ; C: <right-action> right-action
46 TUPLE: up-action ; C: <up-action> up-action
47 TUPLE: down-action ; C: <down-action> down-action
49 TUPLE: zoom-in-action ; C: <zoom-in-action> zoom-in-action
50 TUPLE: zoom-out-action ; C: <zoom-out-action> zoom-out-action
52 : generalize-gesture ( gesture -- newgesture )
56 SYMBOLS: C+ A+ M+ S+ ;
58 TUPLE: key-down mods sym ;
60 : <key-gesture> ( mods sym action? class -- mods' sym' )
61 >r [ S+ rot remove swap ] unless r> boa ; inline
63 : <key-down> ( mods sym action? -- key-down )
64 key-down <key-gesture> ;
66 TUPLE: key-up mods sym ;
68 : <key-up> ( mods sym action? -- key-up )
69 key-up <key-gesture> ;
73 ! Note that these are only really useful inside an event
74 ! handler, and that the locations hand-loc and hand-click-loc
75 ! are in the co-ordinate system of the world which contains
76 ! the gadget in question.
80 { 0 0 } hand-loc set-global
83 SYMBOL: hand-click-loc
85 SYMBOL: hand-last-button
86 SYMBOL: hand-last-time
87 0 hand-last-button set-global
88 0 hand-last-time set-global
91 V{ } clone hand-buttons set-global
93 SYMBOL: scroll-direction
94 { 0 0 } scroll-direction set-global
96 SYMBOL: double-click-timeout
97 300 double-click-timeout set-global
99 : hand-moved? ( -- ? )
100 hand-loc get hand-click-loc get = not ;
102 : button-gesture ( gesture -- )
103 hand-clicked get-global 2dup send-gesture [
104 >r generalize-gesture r> send-gesture drop
109 : drag-gesture ( -- )
110 hand-buttons get-global
111 [ first <drag> button-gesture ] unless-empty ;
115 <box> drag-timer set-global
117 : start-drag-timer ( -- )
118 hand-buttons get-global empty? [
120 300 milliseconds hence
122 add-alarm drag-timer get-global >box
125 : stop-drag-timer ( -- )
126 hand-buttons get-global empty? [
127 drag-timer get-global ?box
128 [ cancel-alarm ] [ drop ] if
132 hand-buttons get-global empty? [
133 T{ motion } hand-gadget get-global send-gesture drop
138 : each-gesture ( gesture seq -- )
139 [ handle-gesture drop ] with each ;
141 : hand-gestures ( new old -- )
142 drop-prefix <reversed>
143 T{ mouse-leave } swap each-gesture
144 T{ mouse-enter } swap each-gesture ;
146 : forget-rollover ( -- )
147 f hand-world set-global
148 hand-gadget get-global >r
149 f hand-gadget set-global
150 f r> parents hand-gestures ;
152 : send-lose-focus ( gadget -- )
153 T{ lose-focus } swap handle-gesture drop ;
155 : send-gain-focus ( gadget -- )
156 T{ gain-focus } swap handle-gesture drop ;
158 : focus-child ( child gadget ? -- )
171 : modifier ( mod modifiers -- seq )
172 [ second swap bitand 0 > ] with filter
173 0 <column> prune [ f ] [ >array ] if-empty ;
175 : drag-loc ( -- loc )
176 hand-loc get-global hand-click-loc get-global v- ;
178 : hand-rel ( gadget -- loc )
179 hand-loc get-global swap screen-loc v- ;
181 : hand-click-rel ( gadget -- loc )
182 hand-click-loc get-global swap screen-loc v- ;
184 : multi-click-timeout? ( -- ? )
185 millis hand-last-time get - double-click-timeout get <= ;
187 : multi-click-button? ( button -- button ? )
188 dup hand-last-button get = ;
190 : multi-click-position? ( -- ? )
191 hand-loc get hand-click-loc get v- norm-sq 100 <= ;
193 : multi-click? ( button -- ? )
195 { [ multi-click-timeout? not ] [ f ] }
196 { [ multi-click-button? not ] [ f ] }
197 { [ multi-click-position? not ] [ f ] }
198 { [ multi-click-position? not ] [ f ] }
202 : update-click# ( button -- )
210 millis hand-last-time set
213 : update-clicked ( -- )
214 hand-gadget get-global hand-clicked set-global
215 hand-loc get-global hand-click-loc set-global ;
217 : under-hand ( -- seq )
218 hand-gadget get-global parents <reversed> ;
220 : move-hand ( loc world -- )
221 dup hand-world set-global
222 under-hand >r over hand-loc set-global
223 pick-up hand-gadget set-global
224 under-hand r> hand-gestures ;
226 : send-button-down ( gesture loc world -- )
230 dup update-click# hand-buttons get-global push
234 : send-button-up ( gesture loc world -- )
236 dup #>> hand-buttons get-global delete
240 : send-wheel ( direction loc world -- )
242 scroll-direction set-global
243 T{ mouse-scroll } hand-gadget get-global send-gesture
246 : world-focus ( world -- gadget )
247 dup focus>> [ world-focus ] [ ] ?if ;
249 : send-action ( world gesture -- )
250 swap world-focus send-gesture drop ;
252 GENERIC: gesture>string ( gesture -- string/f )
254 : modifiers>string ( modifiers -- string )
255 [ name>> ] map concat >string ;
257 M: key-down gesture>string
258 dup mods>> modifiers>string
261 M: button-up gesture>string
263 dup mods>> modifiers>string %
265 #>> [ " " % # ] when*
268 M: button-down gesture>string
270 dup mods>> modifiers>string %
272 #>> [ " " % # ] when*
275 M: left-action gesture>string drop "Swipe left" ;
277 M: right-action gesture>string drop "Swipe right" ;
279 M: up-action gesture>string drop "Swipe up" ;
281 M: down-action gesture>string drop "Swipe down" ;
283 M: zoom-in-action gesture>string drop "Zoom in" ;
285 M: zoom-out-action gesture>string drop "Zoom out (pinch)" ;
287 M: object gesture>string drop f ;