1 ! Copyright (C) 2005, 2008 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors arrays assocs kernel math math.order models
4 namespaces make sequences words strings system hashtables
5 math.parser math.vectors classes.tuple classes boxes calendar
6 alarms combinators sets columns fry deques ui.gadgets ;
9 GENERIC: handle-gesture ( gesture gadget -- ? )
11 M: object handle-gesture
12 tuck class superclasses
13 [ "gestures" word-prop ] map
14 assoc-stack dup [ call f ] [ 2drop t ] if ;
16 : set-gestures ( class hash -- ) "gestures" set-word-prop ;
18 : gesture-queue ( -- deque ) \ gesture-queue get ;
20 GENERIC: send-queued-gesture ( request -- )
22 TUPLE: send-gesture gesture gadget ;
24 M: send-gesture send-queued-gesture
25 [ gesture>> ] [ gadget>> ] bi handle-gesture drop ;
27 : queue-gesture ( ... class -- )
28 boa gesture-queue push-front notify-ui-thread ; inline
30 : send-gesture ( gesture gadget -- )
31 \ send-gesture queue-gesture ;
33 : each-gesture ( gesture seq -- ) [ send-gesture ] with each ;
35 TUPLE: propagate-gesture gesture gadget ;
37 M: propagate-gesture send-queued-gesture
38 [ gesture>> ] [ gadget>> ] bi
39 [ handle-gesture ] with each-parent drop ;
41 : propagate-gesture ( gesture gadget -- )
42 \ propagate-gesture queue-gesture ;
44 TUPLE: propagate-key-gesture gesture world ;
46 : world-focus ( world -- gadget )
47 dup focus>> [ world-focus ] [ ] ?if ;
49 M: propagate-key-gesture send-queued-gesture
50 [ gesture>> ] [ world>> world-focus ] bi
51 [ handle-gesture ] with each-parent drop ;
53 : propagate-key-gesture ( gesture world -- )
54 \ propagate-key-gesture queue-gesture ;
56 TUPLE: user-input string world ;
58 M: user-input send-queued-gesture
59 [ string>> ] [ world>> world-focus ] bi
60 [ user-input* ] with each-parent drop ;
62 : user-input ( string world -- )
63 '[ _ \ user-input queue-gesture ] unless-empty ;
66 TUPLE: motion ; C: <motion> motion
67 TUPLE: drag # ; C: <drag> drag
68 TUPLE: button-up mods # ; C: <button-up> button-up
69 TUPLE: button-down mods # ; C: <button-down> button-down
70 TUPLE: mouse-scroll ; C: <mouse-scroll> mouse-scroll
71 TUPLE: mouse-enter ; C: <mouse-enter> mouse-enter
72 TUPLE: mouse-leave ; C: <mouse-leave> mouse-leave
73 TUPLE: lose-focus ; C: <lose-focus> lose-focus
74 TUPLE: gain-focus ; C: <gain-focus> gain-focus
76 ! Higher-level actions
77 TUPLE: cut-action ; C: <cut-action> cut-action
78 TUPLE: copy-action ; C: <copy-action> copy-action
79 TUPLE: paste-action ; C: <paste-action> paste-action
80 TUPLE: delete-action ; C: <delete-action> delete-action
81 TUPLE: select-all-action ; C: <select-all-action> select-all-action
83 TUPLE: left-action ; C: <left-action> left-action
84 TUPLE: right-action ; C: <right-action> right-action
85 TUPLE: up-action ; C: <up-action> up-action
86 TUPLE: down-action ; C: <down-action> down-action
88 TUPLE: zoom-in-action ; C: <zoom-in-action> zoom-in-action
89 TUPLE: zoom-out-action ; C: <zoom-out-action> zoom-out-action
92 SYMBOLS: C+ A+ M+ S+ ;
94 TUPLE: key-down mods sym ;
96 : <key-gesture> ( mods sym action? class -- mods' sym' )
97 [ [ [ S+ swap remove f like ] dip ] unless ] dip boa ; inline
99 : <key-down> ( mods sym action? -- key-down )
100 key-down <key-gesture> ;
102 TUPLE: key-up mods sym ;
104 : <key-up> ( mods sym action? -- key-up )
105 key-up <key-gesture> ;
109 ! Note that these are only really useful inside an event
110 ! handler, and that the locations hand-loc and hand-click-loc
111 ! are in the co-ordinate system of the world which contains
112 ! the gadget in question.
116 { 0 0 } hand-loc set-global
119 SYMBOL: hand-click-loc
121 SYMBOL: hand-last-button
122 SYMBOL: hand-last-time
123 0 hand-last-button set-global
124 <zero> hand-last-time set-global
127 V{ } clone hand-buttons set-global
129 SYMBOL: scroll-direction
130 { 0 0 } scroll-direction set-global
132 SYMBOL: double-click-timeout
133 300 milliseconds double-click-timeout set-global
135 : hand-moved? ( -- ? )
136 hand-loc get hand-click-loc get = not ;
138 : button-gesture ( gesture -- )
139 hand-clicked get-global propagate-gesture ;
141 : drag-gesture ( -- )
142 hand-buttons get-global
143 [ first <drag> button-gesture ] unless-empty ;
147 <box> drag-timer set-global
149 : start-drag-timer ( -- )
150 hand-buttons get-global empty? [
152 300 milliseconds hence
154 add-alarm drag-timer get-global >box
157 : stop-drag-timer ( -- )
158 hand-buttons get-global empty? [
159 drag-timer get-global ?box
160 [ cancel-alarm ] [ drop ] if
164 hand-buttons get-global empty? [
165 T{ motion } hand-gadget get-global propagate-gesture
170 : hand-gestures ( new old -- )
171 drop-prefix <reversed>
172 T{ mouse-leave } swap each-gesture
173 T{ mouse-enter } swap each-gesture ;
175 : forget-rollover ( -- )
176 f hand-world set-global
177 hand-gadget get-global
178 [ f hand-gadget set-global f ] dip
179 parents hand-gestures ;
181 : send-lose-focus ( gadget -- )
182 T{ lose-focus } swap send-gesture ;
184 : send-gain-focus ( gadget -- )
185 T{ gain-focus } swap send-gesture ;
187 : focus-child ( child gadget ? -- )
200 : modifier ( mod modifiers -- seq )
201 [ second swap bitand 0 > ] with filter
202 0 <column> prune [ f ] [ >array ] if-empty ;
204 : drag-loc ( -- loc )
205 hand-loc get-global hand-click-loc get-global v- ;
207 : hand-rel ( gadget -- loc )
208 hand-loc get-global swap screen-loc v- ;
210 : hand-click-rel ( gadget -- loc )
211 hand-click-loc get-global swap screen-loc v- ;
213 : multi-click-timeout? ( -- ? )
214 now hand-last-time get time- double-click-timeout get before=? ;
216 : multi-click-button? ( button -- button ? )
217 dup hand-last-button get = ;
219 : multi-click-position? ( -- ? )
220 hand-loc get hand-click-loc get distance 10 <= ;
222 : multi-click? ( button -- ? )
224 { [ multi-click-timeout? not ] [ f ] }
225 { [ multi-click-button? not ] [ f ] }
226 { [ multi-click-position? not ] [ f ] }
227 { [ multi-click-position? not ] [ f ] }
231 : update-click# ( button -- )
239 now hand-last-time set
242 : update-clicked ( -- )
243 hand-gadget get-global hand-clicked set-global
244 hand-loc get-global hand-click-loc set-global ;
246 : under-hand ( -- seq )
247 hand-gadget get-global parents <reversed> ;
249 : move-hand ( loc world -- )
250 dup hand-world set-global
252 over hand-loc set-global
253 pick-up hand-gadget set-global
255 ] dip hand-gestures ;
257 : send-button-down ( gesture loc world -- )
261 dup update-click# hand-buttons get-global push
265 : send-button-up ( gesture loc world -- )
267 dup #>> hand-buttons get-global delete
271 : send-wheel ( direction loc world -- )
273 scroll-direction set-global
274 T{ mouse-scroll } hand-gadget get-global propagate-gesture ;
276 : send-action ( world gesture -- )
277 swap world-focus propagate-gesture ;
279 GENERIC: gesture>string ( gesture -- string/f )
281 : modifiers>string ( modifiers -- string )
282 [ name>> ] map concat >string ;
284 M: key-down gesture>string
285 dup mods>> modifiers>string
288 M: button-up gesture>string
290 dup mods>> modifiers>string %
292 #>> [ " " % # ] when*
295 M: button-down gesture>string
297 dup mods>> modifiers>string %
299 #>> [ " " % # ] when*
302 M: left-action gesture>string drop "Swipe left" ;
304 M: right-action gesture>string drop "Swipe right" ;
306 M: up-action gesture>string drop "Swipe up" ;
308 M: down-action gesture>string drop "Swipe down" ;
310 M: zoom-in-action gesture>string drop "Zoom in" ;
312 M: zoom-out-action gesture>string drop "Zoom out (pinch)" ;
314 M: object gesture>string drop f ;