1 ! Copyright (C) 2005, 2009 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 alarms combinators
6 sets columns fry deques ui.gadgets ui.gadgets.private unicode.case
7 unicode.categories combinators.short-circuit ;
10 GENERIC: handle-gesture ( gesture gadget -- ? )
12 M: object handle-gesture
14 [ class superclasses [ "gestures" word-prop ] map assoc-stack ] 2bi
15 dup [ call( gadget -- ) f ] [ 2drop t ] if ;
17 : set-gestures ( class hash -- ) "gestures" set-word-prop ;
19 : gesture-queue ( -- deque ) \ gesture-queue get ;
21 GENERIC: send-queued-gesture ( request -- )
23 TUPLE: send-gesture gesture gadget ;
25 M: send-gesture send-queued-gesture
26 [ gesture>> ] [ gadget>> ] bi handle-gesture drop ;
28 : queue-gesture ( ... class -- )
29 boa gesture-queue push-front notify-ui-thread ; inline
31 : send-gesture ( gesture gadget -- )
32 \ send-gesture queue-gesture ;
34 : each-gesture ( gesture seq -- ) [ send-gesture ] with each ;
36 TUPLE: propagate-gesture gesture gadget ;
38 : resend-gesture ( gesture gadget -- ? )
39 [ handle-gesture ] with each-parent ;
41 M: propagate-gesture send-queued-gesture
42 [ gesture>> ] [ gadget>> ] bi resend-gesture drop ;
44 : propagate-gesture ( gesture gadget -- )
45 \ propagate-gesture queue-gesture ;
47 TUPLE: propagate-key-gesture gesture world ;
49 : world-focus ( world -- gadget )
50 dup focus>> [ world-focus ] [ ] ?if ;
52 M: propagate-key-gesture send-queued-gesture
53 [ gesture>> ] [ world>> world-focus ] bi
54 [ handle-gesture ] with each-parent drop ;
56 : propagate-key-gesture ( gesture world -- )
57 \ propagate-key-gesture queue-gesture ;
59 TUPLE: user-input string world ;
61 M: user-input send-queued-gesture
62 [ string>> ] [ world>> world-focus ] bi
63 [ user-input* ] with each-parent drop ;
65 : user-input ( string world -- )
66 '[ _ \ user-input queue-gesture ] unless-empty ;
69 TUPLE: drag # ; C: <drag> drag
70 TUPLE: button-up mods # ; C: <button-up> button-up
71 TUPLE: button-down mods # ; C: <button-down> button-down
76 mouse-enter mouse-leave
77 lose-focus gain-focus ;
79 ! Higher-level actions
81 undo-action redo-action
82 cut-action copy-action paste-action
83 delete-action select-all-action
84 left-action right-action up-action down-action
85 zoom-in-action zoom-out-action ;
88 undo-action redo-action
89 cut-action copy-action paste-action
90 delete-action select-all-action
91 left-action right-action up-action down-action
92 zoom-in-action zoom-out-action ;
94 CONSTANT: action-gestures
101 { "a" select-all-action }
105 SYMBOLS: C+ A+ M+ S+ ;
107 TUPLE: key-gesture mods sym ;
109 TUPLE: key-down < key-gesture ;
111 : new-key-gesture ( mods sym action? class -- mods' sym' )
112 [ [ [ S+ swap remove f like ] dip ] unless ] dip boa ; inline
114 : <key-down> ( mods sym action? -- key-down )
115 key-down new-key-gesture ;
117 TUPLE: key-up < key-gesture ;
119 : <key-up> ( mods sym action? -- key-up )
120 key-up new-key-gesture ;
124 ! Note that these are only really useful inside an event
125 ! handler, and that the locations hand-loc and hand-click-loc
126 ! are in the co-ordinate system of the world which contains
127 ! the gadget in question.
131 { 0 0 } hand-loc set-global
134 SYMBOL: hand-click-loc
136 SYMBOL: hand-last-button
137 SYMBOL: hand-last-time
138 0 hand-last-button set-global
139 <zero> hand-last-time set-global
142 V{ } clone hand-buttons set-global
144 SYMBOL: scroll-direction
145 { 0 0 } scroll-direction set-global
147 SYMBOL: double-click-timeout
148 300 milliseconds double-click-timeout set-global
150 : hand-moved? ( -- ? )
151 hand-loc get hand-click-loc get = not ;
153 : button-gesture ( gesture -- )
154 hand-clicked get-global propagate-gesture ;
156 : drag-gesture ( -- )
157 hand-buttons get-global
158 [ first <drag> button-gesture ] unless-empty ;
162 <box> drag-timer set-global
164 : start-drag-timer ( -- )
165 hand-buttons get-global empty? [
167 300 milliseconds hence
169 add-alarm drag-timer get-global >box
172 : stop-drag-timer ( -- )
173 hand-buttons get-global empty? [
174 drag-timer get-global ?box
175 [ cancel-alarm ] [ drop ] if
179 hand-buttons get-global empty? [
180 motion hand-gadget get-global propagate-gesture
185 : hand-gestures ( new old -- )
186 drop-prefix <reversed>
187 mouse-leave swap each-gesture
188 mouse-enter swap each-gesture ;
190 : forget-rollover ( -- )
191 f hand-world set-global
192 hand-gadget get-global
193 [ f hand-gadget set-global f ] dip
194 parents hand-gestures ;
196 : send-lose-focus ( gadget -- )
197 lose-focus swap send-gesture ;
199 : send-gain-focus ( gadget -- )
200 gain-focus swap send-gesture ;
202 : focus-child ( child gadget ? -- )
215 : modifier ( mod modifiers -- seq )
216 [ second swap bitand 0 > ] with filter
217 0 <column> prune [ f ] [ >array ] if-empty ;
219 : drag-loc ( -- loc )
220 hand-loc get-global hand-click-loc get-global v- ;
222 : hand-rel ( gadget -- loc )
223 hand-loc get-global swap screen-loc v- ;
225 : hand-click-rel ( gadget -- loc )
226 hand-click-loc get-global swap screen-loc v- ;
228 : multi-click-timeout? ( -- ? )
229 now hand-last-time get time- double-click-timeout get before=? ;
231 : multi-click-button? ( button -- button ? )
232 dup hand-last-button get = ;
234 : multi-click-position? ( -- ? )
235 hand-loc get hand-click-loc get distance 10 <= ;
237 : multi-click? ( button -- ? )
239 [ multi-click-timeout? ]
240 [ multi-click-button? ]
241 [ multi-click-position? ]
244 : update-click# ( button -- )
252 now hand-last-time set
255 : update-clicked ( -- )
256 hand-gadget get-global hand-clicked set-global
257 hand-loc get-global hand-click-loc set-global ;
259 : under-hand ( -- seq )
260 hand-gadget get-global parents <reversed> ;
262 : move-hand ( loc world -- )
263 dup hand-world set-global
265 over hand-loc set-global
266 pick-up hand-gadget set-global
268 ] dip hand-gestures ;
270 : send-button-down ( gesture loc world -- )
274 dup update-click# hand-buttons get-global push
278 : send-button-up ( gesture loc world -- )
280 dup #>> hand-buttons get-global delete
284 : send-wheel ( direction loc world -- )
286 scroll-direction set-global
287 mouse-scroll hand-gadget get-global propagate-gesture ;
289 : send-action ( world gesture -- )
290 swap world-focus propagate-gesture ;
292 GENERIC: gesture>string ( gesture -- string/f )
294 HOOK: modifiers>string os ( modifiers -- string )
296 M: macosx modifiers>string
299 { A+ [ "\u{place-of-interest-sign}" ] }
300 { M+ [ "\u{option-key}" ] }
301 { S+ [ "\u{upwards-white-arrow}" ] }
302 { C+ [ "\u{up-arrowhead}" ] }
306 M: object modifiers>string
307 [ name>> ] map "" join ;
309 HOOK: keysym>string os ( keysym -- string )
311 M: macosx keysym>string >upper ;
313 M: object keysym>string ;
315 M: key-down gesture>string
316 [ mods>> ] [ sym>> ] bi
318 { [ dup { [ length 1 = ] [ first LETTER? ] } 1&& ] [ [ S+ prefix ] dip ] }
319 { [ dup " " = ] [ drop "SPACE" ] }
322 [ modifiers>string ] dip append ;
324 M: button-up gesture>string
326 dup mods>> modifiers>string %
328 #>> [ " " % # ] when*
331 M: button-down gesture>string
333 dup mods>> modifiers>string %
335 #>> [ " " % # ] when*
338 M: left-action gesture>string drop "Swipe left" ;
340 M: right-action gesture>string drop "Swipe right" ;
342 M: up-action gesture>string drop "Swipe up" ;
344 M: down-action gesture>string drop "Swipe down" ;
346 M: zoom-in-action gesture>string drop "Zoom in" ;
348 M: zoom-out-action gesture>string drop "Zoom out (pinch)" ;
350 HOOK: action-modifier os ( -- mod )
352 M: object action-modifier C+ ;
353 M: macosx action-modifier A+ ;
355 M: action gesture>string
356 action-gestures value-at
357 action-modifier 1array
358 swap f <key-down> gesture>string ;
360 M: object gesture>string drop f ;