1 ! Copyright (C) 2005, 2006 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
4 USING: arrays generic hashtables kernel math models namespaces
5 queues sequences words ;
7 : gestures ( gadget -- seq )
8 delegates [ class "gestures" word-prop ] map [ ] subset ;
10 : set-gestures ( class hash -- ) "gestures" set-word-prop ;
12 : handle-gesture* ( gesture gadget -- )
13 tuck gestures hash-stack [ call f ] [ drop t ] if* ;
15 : handle-gesture ( gesture gadget -- ? )
16 #! If a gadget's handle-gesture* generic returns t, the
17 #! event was not consumed and is passed on to the gadget's
18 #! parent. This word returns t if no gadget handled the
19 #! gesture, otherwise returns f.
20 [ dupd handle-gesture* ] each-parent nip ;
22 : user-input ( str gadget -- )
23 [ dupd user-input* ] each-parent 2drop ;
28 TUPLE: button-up mods # ;
29 TUPLE: button-down mods # ;
36 ! Higher-level actions
40 TUPLE: delete-action ;
41 TUPLE: select-all-action ;
43 : handle-action ( gadget constructor -- )
44 execute swap handle-gesture drop ; inline
46 : generalize-gesture ( gesture -- gesture )
47 #! Strip button number from drag/button-up/button-down.
48 tuple>array 1 head* >tuple ;
56 TUPLE: key-down mods sym ;
57 TUPLE: key-up mods sym ;
61 ! Note that these are only really useful inside an event
62 ! handler, and that the locations hand-loc and hand-click-loc
63 ! are in the co-ordinate system of the world which contains
64 ! the gadget in question.
68 { 0 0 } hand-loc set-global
71 SYMBOL: hand-click-loc
74 V{ } clone hand-buttons set-global
76 SYMBOL: scroll-direction
77 { 0 0 } scroll-direction set-global
79 : button-gesture ( gesture -- )
80 hand-clicked get-global 2dup handle-gesture [
81 >r generalize-gesture r> handle-gesture drop
87 hand-buttons get-global first <drag> button-gesture ;
90 #! Fire a motion gesture to the gadget underneath the hand,
91 #! and if a mouse button is down, fire a drag gesture to the
92 #! gadget that was clicked.
93 hand-buttons get-global empty? [
94 T{ motion } hand-gadget get-global handle-gesture drop
99 : each-gesture ( gesture seq -- )
100 [ handle-gesture* drop ] each-with ;
102 : hand-gestures ( new old -- )
103 drop-prefix <reversed>
104 T{ mouse-leave } swap each-gesture
105 T{ mouse-enter } swap each-gesture ;
107 : forget-rollover ( -- )
108 #! After we restore the UI, send mouse leave events to all
109 #! gadgets that were under the mouse at the time of the
110 #! save, since the mouse is in a different location now.
111 f hand-gadget [ get-global ] 2keep set-global
112 parents hand-gestures ;
114 : focus-gestures ( new old -- )
115 drop-prefix <reversed>
116 T{ lose-focus } swap each-gesture
117 T{ gain-focus } swap each-gesture ;
119 : focus-receiver ( world -- seq )
120 #! If the world is not focused, we want focus-gestures to
121 #! only send focus-lost and not focus-gained.
122 dup world-focused? [ focused-ancestors ] [ drop f ] if ;
124 : request-focus* ( gadget world -- )
125 dup focused-ancestors >r
126 [ set-world-focus ] keep
127 focus-receiver r> focus-gestures ;
129 : request-focus ( gadget -- )
130 dup focusable-child swap find-world
131 [ request-focus* ] [ drop ] if* ;
133 : modifier ( mod modifiers -- seq )
134 [ second swap bitand 0 > ] subset-with
135 [ first ] map prune f like ;
137 : drag-loc ( -- loc )
138 hand-loc get-global hand-click-loc get-global v- ;
140 : hand-rel ( gadget -- loc )
141 hand-loc get-global relative-loc ;
143 : hand-click-rel ( gadget -- loc )
144 hand-click-loc get-global relative-loc ;
146 : under-hand ( -- seq )
147 #! A sequence whose first element is the world and last is
148 #! the current gadget, with all parents in between.
149 hand-gadget get-global parents <reversed> ;
151 : update-clicked ( -- )
152 hand-gadget get-global hand-clicked set-global
153 hand-loc get-global hand-click-loc set-global ;
157 : move-hand ( loc world -- )
158 dup hand-world set-global
159 under-hand >r over hand-loc set-global
160 pick-up hand-gadget set-global
161 menu-mode? get-global [ update-clicked ] when
162 under-hand r> hand-gestures ;
164 : send-button-down ( gesture loc world -- )
167 dup button-down-# hand-buttons get-global push
170 : send-button-up ( gesture loc world -- )
172 dup button-up-# hand-buttons get-global delete
175 : send-wheel ( direction loc world -- )
177 scroll-direction set-global
178 T{ mouse-scroll } hand-gadget get-global handle-gesture
181 : send-action ( world gesture -- )
182 swap world-focus handle-gesture drop ;
184 : resend-button-down ( gesture world -- )
185 hand-loc get-global swap send-button-down ;
187 : resend-button-up ( gesture world -- )
188 hand-loc get-global swap send-button-up ;
191 { T{ key-down f { C+ } "x" } [ T{ cut-action } send-action ] }
192 { T{ key-down f { C+ } "c" } [ T{ copy-action } send-action ] }
193 { T{ key-down f { C+ } "v" } [ T{ paste-action } send-action ] }
194 { T{ key-down f { C+ } "a" } [ T{ select-all-action } send-action ] }
195 { T{ button-down f { C+ } 1 } [ T{ button-down f f 3 } swap resend-button-down ] }
196 { T{ button-down f { A+ } 1 } [ T{ button-down f f 2 } swap resend-button-down ] }
197 { T{ button-up f { C+ } 1 } [ T{ button-up f f 3 } swap resend-button-up ] }
198 { T{ button-up f { A+ } 1 } [ T{ button-up f f 2 } swap resend-button-up ] }