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 ascii
7 combinators.short-circuit ;
8 FROM: namespaces => set ;
11 : get-gesture-handler ( gesture gadget -- quot )
12 class superclasses [ "gestures" word-prop ] map assoc-stack ;
14 GENERIC: handle-gesture ( gesture gadget -- ? )
16 M: object handle-gesture
18 [ get-gesture-handler ] 2bi
19 dup [ call( gadget -- ) f ] [ 2drop t ] if ;
21 GENERIC: handles-gesture? ( gesture gadget -- ? )
23 M: object handles-gesture? ( gesture gadget -- ? )
24 get-gesture-handler >boolean ;
26 : parents-handle-gesture? ( gesture gadget -- ? )
27 [ handles-gesture? not ] with each-parent not ;
29 : set-gestures ( class hash -- ) "gestures" set-word-prop ;
31 : gesture-queue ( -- deque ) \ gesture-queue get ;
33 GENERIC: send-queued-gesture ( request -- )
35 TUPLE: send-gesture gesture gadget ;
37 M: send-gesture send-queued-gesture
38 [ gesture>> ] [ gadget>> ] bi handle-gesture drop ;
40 : queue-gesture ( ... class -- )
41 boa gesture-queue push-front notify-ui-thread ; inline
43 : send-gesture ( gesture gadget -- )
44 \ send-gesture queue-gesture ;
46 : each-gesture ( gesture seq -- ) [ send-gesture ] with each ;
48 TUPLE: propagate-gesture gesture gadget ;
50 : resend-gesture ( gesture gadget -- ? )
51 [ handle-gesture ] with each-parent ;
53 M: propagate-gesture send-queued-gesture
54 [ gesture>> ] [ gadget>> ] bi resend-gesture drop ;
56 : propagate-gesture ( gesture gadget -- )
57 \ propagate-gesture queue-gesture ;
59 TUPLE: propagate-key-gesture gesture world ;
61 : world-focus ( world -- gadget )
62 dup focus>> [ world-focus ] [ ] ?if ;
64 M: propagate-key-gesture send-queued-gesture
65 [ gesture>> ] [ world>> world-focus ] bi
66 [ handle-gesture ] with each-parent drop ;
68 : propagate-key-gesture ( gesture world -- )
69 \ propagate-key-gesture queue-gesture ;
71 TUPLE: user-input string world ;
73 M: user-input send-queued-gesture
74 [ string>> ] [ world>> world-focus ] bi
75 [ user-input* ] with each-parent drop ;
77 : user-input ( string world -- )
78 '[ _ \ user-input queue-gesture ] unless-empty ;
81 TUPLE: drag # ; C: <drag> drag
82 TUPLE: button-up mods # ; C: <button-up> button-up
83 TUPLE: button-down mods # ; C: <button-down> button-down
88 mouse-enter mouse-leave
89 lose-focus gain-focus ;
91 ! Higher-level actions
93 undo-action redo-action
94 cut-action copy-action paste-action
95 delete-action select-all-action
96 left-action right-action up-action down-action
97 zoom-in-action zoom-out-action
98 new-action open-action save-action save-as-action
99 revert-action close-action ;
102 undo-action redo-action
103 cut-action copy-action paste-action
104 delete-action select-all-action
105 left-action right-action up-action down-action
106 zoom-in-action zoom-out-action
107 new-action open-action save-action save-as-action
108 revert-action close-action ;
110 CONSTANT: action-gestures
117 { "a" select-all-action }
121 { "S" save-as-action }
126 SYMBOLS: C+ A+ M+ S+ ;
128 TUPLE: key-gesture mods sym ;
130 TUPLE: key-down < key-gesture ;
132 : new-key-gesture ( mods sym action? class -- mods' sym' )
133 [ [ [ S+ swap remove f like ] dip ] unless ] dip boa ; inline
135 : <key-down> ( mods sym action? -- key-down )
136 key-down new-key-gesture ;
138 TUPLE: key-up < key-gesture ;
140 : <key-up> ( mods sym action? -- key-up )
141 key-up new-key-gesture ;
145 ! Note that these are only really useful inside an event
146 ! handler, and that the locations hand-loc and hand-click-loc
147 ! are in the co-ordinate system of the world which contains
148 ! the gadget in question.
152 { 0 0 } hand-loc set-global
155 SYMBOL: hand-click-loc
157 SYMBOL: hand-last-button
158 SYMBOL: hand-last-time
159 0 hand-last-button set-global
160 0 hand-last-time set-global
163 V{ } clone hand-buttons set-global
165 SYMBOL: scroll-direction
166 { 0 0 } scroll-direction set-global
168 SYMBOL: double-click-timeout
169 300 milliseconds double-click-timeout set-global
171 : hand-moved? ( -- ? )
172 hand-loc get hand-click-loc get = not ;
174 : button-gesture ( gesture -- )
175 hand-clicked get-global propagate-gesture ;
177 : drag-gesture ( -- )
178 hand-buttons get-global
179 [ first <drag> button-gesture ] unless-empty ;
183 <box> drag-timer set-global
185 : start-drag-timer ( -- )
186 hand-buttons get-global empty? [
190 add-alarm drag-timer get-global >box
193 : stop-drag-timer ( -- )
194 hand-buttons get-global empty? [
195 drag-timer get-global ?box
196 [ cancel-alarm ] [ drop ] if
200 hand-buttons get-global empty? [
201 motion hand-gadget get-global propagate-gesture
206 : hand-gestures ( new old -- )
207 drop-prefix <reversed>
208 mouse-leave swap each-gesture
209 mouse-enter swap each-gesture ;
211 : forget-rollover ( -- )
212 f hand-world set-global
213 hand-gadget get-global
214 [ f hand-gadget set-global f ] dip
215 parents hand-gestures ;
217 : send-lose-focus ( gadget -- )
218 lose-focus swap send-gesture ;
220 : send-gain-focus ( gadget -- )
221 gain-focus swap send-gesture ;
223 : focus-child ( child gadget ? -- )
236 : modifier ( mod modifiers -- seq )
237 [ second swap bitand 0 > ] with filter
238 0 <column> prune [ f ] [ >array ] if-empty ;
240 : drag-loc ( -- loc )
241 hand-loc get-global hand-click-loc get-global v- ;
243 : hand-rel ( gadget -- loc )
244 hand-loc get-global swap screen-loc v- ;
246 : hand-click-rel ( gadget -- loc )
247 hand-click-loc get-global swap screen-loc v- ;
249 : multi-click-timeout? ( -- ? )
250 nano-count hand-last-time get - nanoseconds
251 double-click-timeout get before=? ;
253 : multi-click-button? ( button -- button ? )
254 dup hand-last-button get = ;
256 : multi-click-position? ( -- ? )
257 hand-loc get hand-click-loc get distance 10 <= ;
259 : multi-click? ( button -- ? )
261 [ multi-click-timeout? ]
262 [ multi-click-button? ]
263 [ multi-click-position? ]
266 : update-click# ( button -- )
274 nano-count hand-last-time set
277 : update-clicked ( -- )
278 hand-gadget get-global hand-clicked set-global
279 hand-loc get-global hand-click-loc set-global ;
281 : under-hand ( -- seq )
282 hand-gadget get-global parents <reversed> ;
284 : move-hand ( loc world -- )
285 dup hand-world set-global
287 over hand-loc set-global
288 pick-up hand-gadget set-global
290 ] dip hand-gestures ;
292 : send-button-down ( gesture loc world -- )
296 dup update-click# hand-buttons get-global push
300 : send-button-up ( gesture loc world -- )
302 dup #>> hand-buttons get-global remove! drop
306 : send-wheel ( direction loc world -- )
308 scroll-direction set-global
309 mouse-scroll hand-gadget get-global propagate-gesture ;
311 : send-action ( world gesture -- )
312 swap world-focus propagate-gesture ;
314 GENERIC: gesture>string ( gesture -- string/f )
316 HOOK: modifiers>string os ( modifiers -- string )
318 M: macosx modifiers>string
321 { A+ [ "\u002318" ] }
322 { M+ [ "\u002325" ] }
323 { S+ [ "\u0021e7" ] }
324 { C+ [ "\u002303" ] }
328 M: object modifiers>string
329 [ name>> ] map "" join ;
331 HOOK: keysym>string os ( keysym -- string )
333 M: macosx keysym>string >upper ;
335 M: object keysym>string dup length 1 = [ >lower ] when ;
337 M: key-down gesture>string
338 [ mods>> ] [ sym>> ] bi
340 { [ dup { [ length 1 = ] [ first LETTER? ] } 1&& ] [ [ S+ prefix ] dip ] }
341 { [ dup " " = ] [ drop "SPACE" ] }
344 [ modifiers>string ] [ keysym>string ] bi* append ;
346 M: button-up gesture>string
348 dup mods>> modifiers>string %
350 #>> [ " " % # ] when*
353 M: button-down gesture>string
355 dup mods>> modifiers>string %
357 #>> [ " " % # ] when*
360 M: left-action gesture>string drop "Swipe left" ;
362 M: right-action gesture>string drop "Swipe right" ;
364 M: up-action gesture>string drop "Swipe up" ;
366 M: down-action gesture>string drop "Swipe down" ;
368 M: zoom-in-action gesture>string drop "Zoom in" ;
370 M: zoom-out-action gesture>string drop "Zoom out (pinch)" ;
372 HOOK: action-modifier os ( -- mod )
374 M: object action-modifier C+ ;
375 M: macosx action-modifier A+ ;
377 M: action gesture>string
378 action-gestures value-at
379 action-modifier 1array
380 swap f <key-down> gesture>string ;
382 M: object gesture>string drop f ;