1 ! Copyright (C) 2005, 2010 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 math.parser
5 math.vectors classes.tuple classes boxes calendar timers combinators
6 sets columns fry deques ui.gadgets ui.gadgets.private ascii
7 combinators.short-circuit ;
10 : get-gesture-handler ( gesture gadget -- quot )
11 class-of superclasses-of [ "gestures" word-prop ] map assoc-stack ;
13 GENERIC: handle-gesture ( gesture gadget -- ? )
15 M: object handle-gesture
17 [ get-gesture-handler ] 2bi
18 dup [ call( gadget -- ) f ] [ 2drop t ] if ;
20 GENERIC: handles-gesture? ( gesture gadget -- ? )
22 M: object handles-gesture? ( gesture gadget -- ? )
23 get-gesture-handler >boolean ;
25 : parents-handle-gesture? ( gesture gadget -- ? )
26 [ handles-gesture? not ] with each-parent not ;
28 : set-gestures ( class hash -- ) "gestures" set-word-prop ;
30 : gesture-queue ( -- deque ) \ gesture-queue get ;
32 GENERIC: send-queued-gesture ( request -- )
34 TUPLE: send-gesture-tuple gesture gadget ;
36 M: send-gesture-tuple send-queued-gesture
37 [ gesture>> ] [ gadget>> ] bi handle-gesture drop ;
39 : queue-gesture ( ... class -- )
40 boa gesture-queue push-front notify-ui-thread ; inline
42 : send-gesture ( gesture gadget -- )
43 \ send-gesture-tuple queue-gesture ;
45 : each-gesture ( gesture seq -- ) [ send-gesture ] with each ;
47 TUPLE: propagate-gesture-tuple gesture gadget ;
49 : resend-gesture ( gesture gadget -- ? )
50 [ handle-gesture ] with each-parent ;
52 M: propagate-gesture-tuple send-queued-gesture
53 [ gesture>> ] [ gadget>> ] bi resend-gesture drop ;
55 : propagate-gesture ( gesture gadget -- )
56 \ propagate-gesture-tuple queue-gesture ;
58 TUPLE: propagate-key-gesture-tuple gesture world ;
60 : world-focus ( world -- gadget )
61 dup focus>> [ world-focus ] [ ] ?if ;
63 M: propagate-key-gesture-tuple send-queued-gesture
64 [ gesture>> ] [ world>> world-focus ] bi
65 [ handle-gesture ] with each-parent drop ;
67 : propagate-key-gesture ( gesture world -- )
68 \ propagate-key-gesture-tuple queue-gesture ;
70 TUPLE: user-input-tuple string world ;
72 M: user-input-tuple send-queued-gesture
73 [ string>> ] [ world>> world-focus ] bi
74 [ user-input* ] with each-parent drop ;
76 : user-input ( string world -- )
77 '[ _ \ user-input-tuple queue-gesture ] unless-empty ;
80 TUPLE: drag # ; C: <drag> drag
81 TUPLE: button-up mods # ; C: <button-up> button-up
82 TUPLE: button-down mods # ; C: <button-down> button-down
87 mouse-enter mouse-leave
88 lose-focus gain-focus ;
90 ! Higher-level actions
92 undo-action redo-action
93 cut-action copy-action paste-action
94 delete-action select-all-action
95 left-action right-action up-action down-action
96 zoom-in-action zoom-out-action
97 new-action open-action save-action save-as-action
98 revert-action close-action ;
101 undo-action redo-action
102 cut-action copy-action paste-action
103 delete-action select-all-action
104 left-action right-action up-action down-action
105 zoom-in-action zoom-out-action
106 new-action open-action save-action save-as-action
107 revert-action close-action ;
109 CONSTANT: action-gestures
116 { "a" select-all-action }
120 { "S" save-as-action }
125 SYMBOLS: C+ A+ M+ S+ ;
127 TUPLE: key-gesture mods sym ;
129 TUPLE: key-down < key-gesture ;
131 : new-key-gesture ( mods sym action? class -- mods' sym' )
132 [ [ [ S+ swap remove f like ] dip ] unless ] dip boa ; inline
134 : <key-down> ( mods sym action? -- key-down )
135 key-down new-key-gesture ;
137 TUPLE: key-up < key-gesture ;
139 : <key-up> ( mods sym action? -- key-up )
140 key-up new-key-gesture ;
144 ! Note that these are only really useful inside an event
145 ! handler, and that the locations hand-loc and hand-click-loc
146 ! are in the co-ordinate system of the world which contains
147 ! the gadget in question.
151 { 0 0 } hand-loc set-global
154 SYMBOL: hand-click-loc
156 SYMBOL: hand-last-button
157 SYMBOL: hand-last-time
158 0 hand-last-button set-global
159 0 hand-last-time set-global
162 V{ } clone hand-buttons set-global
164 SYMBOL: scroll-direction
165 { 0 0 } scroll-direction set-global
167 SYMBOL: double-click-timeout
168 300 milliseconds double-click-timeout set-global
170 : hand-moved? ( -- ? )
171 hand-loc get-global hand-click-loc get-global = not ;
173 : button-gesture ( gesture -- )
174 hand-clicked get-global propagate-gesture ;
176 : drag-gesture ( -- )
177 hand-buttons get-global
178 [ first <drag> button-gesture ] unless-empty ;
182 <box> drag-timer set-global
184 : start-drag-timer ( -- )
185 hand-buttons get-global empty? [
190 [ drag-timer get-global >box ]
194 : stop-drag-timer ( -- )
195 hand-buttons get-global empty? [
196 drag-timer get-global ?box
197 [ stop-timer ] [ drop ] if
201 hand-buttons get-global empty? [
202 motion hand-gadget get-global propagate-gesture
207 : hand-gestures ( new old -- )
208 drop-prefix <reversed>
209 mouse-leave swap each-gesture
210 mouse-enter swap each-gesture ;
212 : forget-rollover ( -- )
213 f hand-world set-global
214 hand-gadget get-global
215 [ f hand-gadget set-global f ] dip
216 parents hand-gestures ;
218 : send-lose-focus ( gadget -- )
219 lose-focus swap send-gesture ;
221 : send-gain-focus ( gadget -- )
222 gain-focus swap send-gesture ;
224 : focus-child ( child gadget ? -- )
237 : modifier ( mod modifiers -- seq )
238 [ second swap bitand 0 > ] with filter
239 0 <column> members [ f ] [ >array ] if-empty ;
241 : drag-loc ( -- loc )
242 hand-loc get-global hand-click-loc get-global v- ;
244 : hand-rel ( gadget -- loc )
245 hand-loc get-global swap screen-loc v- ;
247 : hand-click-rel ( gadget -- loc )
248 hand-click-loc get-global swap screen-loc v- ;
250 : multi-click-timeout? ( -- ? )
251 nano-count hand-last-time get - nanoseconds
252 double-click-timeout get before=? ;
254 : multi-click-button? ( button -- button ? )
255 dup hand-last-button get = ;
257 : multi-click-position? ( -- ? )
258 hand-loc get-global hand-click-loc get-global distance 10 <= ;
260 : multi-click? ( button -- ? )
262 [ multi-click-timeout? ]
263 [ multi-click-button? ]
264 [ multi-click-position? ]
267 : update-click# ( button -- )
275 nano-count hand-last-time set
278 : update-clicked ( -- )
279 hand-gadget get-global hand-clicked set-global
280 hand-loc get-global hand-click-loc set-global ;
282 : under-hand ( -- seq )
283 hand-gadget get-global parents <reversed> ;
285 : move-hand ( loc world -- )
286 dup hand-world set-global
288 over hand-loc set-global
289 pick-up hand-gadget set-global
291 ] dip hand-gestures ;
293 : send-button-down ( gesture loc world -- )
297 dup update-click# hand-buttons get-global push
301 : send-button-up ( gesture loc world -- )
303 dup #>> hand-buttons get-global remove! drop
307 : send-scroll ( direction loc world -- )
309 scroll-direction set-global
310 mouse-scroll hand-gadget get-global propagate-gesture ;
312 : send-action ( world gesture -- )
313 swap world-focus propagate-gesture ;
315 GENERIC: gesture>string ( gesture -- string/f )
317 HOOK: modifiers>string os ( modifiers -- string )
319 M: macosx modifiers>string
322 { A+ [ "\u002318" ] }
323 { M+ [ "\u002325" ] }
324 { S+ [ "\u0021e7" ] }
325 { C+ [ "\u002303" ] }
329 M: object modifiers>string
330 [ name>> ] map "" concat-as ;
332 HOOK: keysym>string os ( keysym -- string )
334 M: macosx keysym>string >upper ;
336 M: object keysym>string dup length 1 = [ >lower ] when ;
338 M: key-down gesture>string
339 [ mods>> ] [ sym>> ] bi
341 { [ dup { [ length 1 = ] [ first LETTER? ] } 1&& ] [ [ S+ prefix ] dip ] }
342 { [ dup " " = ] [ drop "SPACE" ] }
345 [ modifiers>string ] [ keysym>string ] bi* append ;
347 M: button-up gesture>string
349 dup mods>> modifiers>string %
351 #>> [ " " % # ] when*
354 M: button-down gesture>string
356 dup mods>> modifiers>string %
358 #>> [ " " % # ] when*
361 M: left-action gesture>string drop "Swipe left" ;
363 M: right-action gesture>string drop "Swipe right" ;
365 M: up-action gesture>string drop "Swipe up" ;
367 M: down-action gesture>string drop "Swipe down" ;
369 M: zoom-in-action gesture>string drop "Zoom in" ;
371 M: zoom-out-action gesture>string drop "Zoom out (pinch)" ;
373 HOOK: action-modifier os ( -- mod )
375 M: object action-modifier C+ ;
376 M: macosx action-modifier A+ ;
378 M: action gesture>string
379 action-gestures value-at
380 action-modifier 1array
381 swap f <key-down> gesture>string ;
383 M: object gesture>string drop f ;