-! Copyright (C) 2005, 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays assocs kernel math math.order models
-namespaces make sequences words strings system hashtables math.parser
-math.vectors classes.tuple classes boxes calendar alarms combinators
-sets columns fry deques ui.gadgets ui.gadgets.private ascii
-combinators.short-circuit ;
+! Copyright (C) 2005, 2010 Slava Pestov.
+! See https://factorcode.org/license.txt for BSD license.
+USING: accessors arrays ascii assocs boxes calendar classes columns
+combinators combinators.short-circuit deques kernel make math
+math.order math.parser math.vectors namespaces sequences sets system
+timers ui.gadgets ui.gadgets.private words ;
IN: ui.gestures
+: get-gesture-handler ( gesture gadget -- quot )
+ class-of superclasses-of [ "gestures" word-prop ] map assoc-stack ;
+
GENERIC: handle-gesture ( gesture gadget -- ? )
M: object handle-gesture
[ nip ]
- [ class superclasses [ "gestures" word-prop ] map assoc-stack ] 2bi
+ [ get-gesture-handler ] 2bi
dup [ call( gadget -- ) f ] [ 2drop t ] if ;
+GENERIC: handles-gesture? ( gesture gadget -- ? )
+
+M: object handles-gesture?
+ get-gesture-handler >boolean ;
+
+: parents-handle-gesture? ( gesture gadget -- ? )
+ [ handles-gesture? not ] with each-parent not ;
+
: set-gestures ( class hash -- ) "gestures" set-word-prop ;
: gesture-queue ( -- deque ) \ gesture-queue get ;
GENERIC: send-queued-gesture ( request -- )
-TUPLE: send-gesture gesture gadget ;
+TUPLE: send-gesture-tuple gesture gadget ;
-M: send-gesture send-queued-gesture
+M: send-gesture-tuple send-queued-gesture
[ gesture>> ] [ gadget>> ] bi handle-gesture drop ;
: queue-gesture ( ... class -- )
boa gesture-queue push-front notify-ui-thread ; inline
: send-gesture ( gesture gadget -- )
- \ send-gesture queue-gesture ;
+ \ send-gesture-tuple queue-gesture ;
: each-gesture ( gesture seq -- ) [ send-gesture ] with each ;
-TUPLE: propagate-gesture gesture gadget ;
+TUPLE: propagate-gesture-tuple gesture gadget ;
: resend-gesture ( gesture gadget -- ? )
[ handle-gesture ] with each-parent ;
-M: propagate-gesture send-queued-gesture
+M: propagate-gesture-tuple send-queued-gesture
[ gesture>> ] [ gadget>> ] bi resend-gesture drop ;
: propagate-gesture ( gesture gadget -- )
- \ propagate-gesture queue-gesture ;
+ \ propagate-gesture-tuple queue-gesture ;
-TUPLE: propagate-key-gesture gesture world ;
+TUPLE: propagate-key-gesture-tuple gesture world ;
: world-focus ( world -- gadget )
- dup focus>> [ world-focus ] [ ] ?if ;
+ [ focus>> ] [ world-focus ] ?when ;
-M: propagate-key-gesture send-queued-gesture
+M: propagate-key-gesture-tuple send-queued-gesture
[ gesture>> ] [ world>> world-focus ] bi
[ handle-gesture ] with each-parent drop ;
-: propagate-key-gesture ( gesture world -- )
- \ propagate-key-gesture queue-gesture ;
+:: propagate-key-gesture ( gesture world -- )
+ world world-focus preedit? [
+ gesture world \ propagate-key-gesture-tuple queue-gesture
+ ] unless ;
-TUPLE: user-input string world ;
+TUPLE: user-input-tuple string world ;
-M: user-input send-queued-gesture
+M: user-input-tuple send-queued-gesture
[ string>> ] [ world>> world-focus ] bi
[ user-input* ] with each-parent drop ;
: user-input ( string world -- )
- '[ _ \ user-input queue-gesture ] unless-empty ;
+ '[ _ \ user-input-tuple queue-gesture ] unless-empty ;
! Gesture objects
TUPLE: drag # ; C: <drag> drag
TUPLE: button-up mods # ; C: <button-up> button-up
TUPLE: button-down mods # ; C: <button-down> button-down
+TUPLE: file-drop mods ; C: <file-drop> file-drop
+
+SYMBOL: dropped-files
SINGLETONS:
-motion
-mouse-scroll
-mouse-enter mouse-leave
-lose-focus gain-focus ;
+ motion
+ mouse-scroll
+ mouse-enter mouse-leave
+ lose-focus gain-focus ;
! Higher-level actions
SINGLETONS:
-undo-action redo-action
-cut-action copy-action paste-action
-delete-action select-all-action
-left-action right-action up-action down-action
-zoom-in-action zoom-out-action ;
+ undo-action redo-action
+ cut-action copy-action paste-action
+ delete-action select-all-action
+ left-action right-action up-action down-action
+ zoom-in-action zoom-out-action
+ new-action open-action save-action save-as-action
+ revert-action close-action ;
UNION: action
-undo-action redo-action
-cut-action copy-action paste-action
-delete-action select-all-action
-left-action right-action up-action down-action
-zoom-in-action zoom-out-action ;
+ undo-action redo-action
+ cut-action copy-action paste-action
+ delete-action select-all-action
+ left-action right-action up-action down-action
+ zoom-in-action zoom-out-action
+ new-action open-action save-action save-as-action
+ revert-action close-action ;
CONSTANT: action-gestures
{
{ "z" undo-action }
- { "Z" redo-action }
+ { "y" redo-action }
{ "x" cut-action }
{ "c" copy-action }
{ "v" paste-action }
{ "a" select-all-action }
+ { "n" new-action }
+ { "o" open-action }
+ { "s" save-action }
+ { "S" save-as-action }
+ { "w" close-action }
}
! Modifiers
TUPLE: key-down < key-gesture ;
-: new-key-gesture ( mods sym action? class -- mods' sym' )
+: new-key-gesture ( mods sym action? class -- key-gesture )
[ [ [ S+ swap remove f like ] dip ] unless ] dip boa ; inline
: <key-down> ( mods sym action? -- key-down )
! Note that these are only really useful inside an event
! handler, and that the locations hand-loc and hand-click-loc
-! are in the co-ordinate system of the world which contains
+! are in the coordinate system of the world which contains
! the gadget in question.
SYMBOL: hand-gadget
SYMBOL: hand-world
SYMBOL: hand-last-button
SYMBOL: hand-last-time
0 hand-last-button set-global
-<zero> hand-last-time set-global
+0 hand-last-time set-global
SYMBOL: hand-buttons
V{ } clone hand-buttons set-global
300 milliseconds double-click-timeout set-global
: hand-moved? ( -- ? )
- hand-loc get hand-click-loc get = not ;
+ hand-loc get-global hand-click-loc get-global = not ;
: button-gesture ( gesture -- )
hand-clicked get-global propagate-gesture ;
: start-drag-timer ( -- )
hand-buttons get-global empty? [
[ drag-gesture ]
- 300 milliseconds hence
+ 300 milliseconds
100 milliseconds
- add-alarm drag-timer get-global >box
+ <timer>
+ [ drag-timer get-global >box ]
+ [ start-timer ] bi
] when ;
: stop-drag-timer ( -- )
hand-buttons get-global empty? [
drag-timer get-global ?box
- [ cancel-alarm ] [ drop ] if
+ [ stop-timer ] [ drop ] if
] when ;
: fire-motion ( -- )
dup send-lose-focus
f swap t focus-child
] when*
- dupd (>>focus) [
+ dupd focus<< [
send-gain-focus
] when*
] [
- (>>focus)
+ focus<<
] if ;
: modifier ( mod modifiers -- seq )
[ second swap bitand 0 > ] with filter
- 0 <column> prune [ f ] [ >array ] if-empty ;
+ 0 <column> members [ f ] [ >array ] if-empty ;
: drag-loc ( -- loc )
hand-loc get-global hand-click-loc get-global v- ;
hand-click-loc get-global swap screen-loc v- ;
: multi-click-timeout? ( -- ? )
- now hand-last-time get time- double-click-timeout get before=? ;
+ nano-count hand-last-time get - nanoseconds
+ double-click-timeout get before=? ;
: multi-click-button? ( button -- button ? )
dup hand-last-button get = ;
: multi-click-position? ( -- ? )
- hand-loc get hand-click-loc get distance 10 <= ;
+ hand-loc get-global hand-click-loc get-global distance 10 <= ;
: multi-click? ( button -- ? )
{
} 0&& nip ;
: update-click# ( button -- )
- global [
+ [
dup multi-click? [
hand-click# inc
] [
- 1 hand-click# set
+ 1 hand-click# namespaces:set
] if
- hand-last-button set
- now hand-last-time set
- ] bind ;
+ hand-last-button namespaces:set
+ nano-count hand-last-time namespaces:set
+ ] with-global ;
: update-clicked ( -- )
hand-gadget get-global hand-clicked set-global
: send-button-up ( gesture loc world -- )
move-hand
- dup #>> hand-buttons get-global delete
+ dup #>> hand-buttons get-global remove! drop
stop-drag-timer
button-gesture ;
-: send-wheel ( direction loc world -- )
+: send-scroll ( direction loc world -- )
move-hand
scroll-direction set-global
mouse-scroll hand-gadget get-global propagate-gesture ;
M: macosx modifiers>string
[
{
- { A+ [ "\u002318" ] }
- { M+ [ "\u002325" ] }
+ { M+ [ "\u002318" ] }
+ { A+ [ "\u002325" ] }
{ S+ [ "\u0021e7" ] }
{ C+ [ "\u002303" ] }
} case
- ] map "" join ;
+ ] map "" concat-as ;
M: object modifiers>string
- [ name>> ] map "" join ;
+ [ name>> ] map "" concat-as ;
HOOK: keysym>string os ( keysym -- string )
#>> [ " " % # ] when*
] "" make ;
+M: file-drop gesture>string drop "Drop files" ;
+
M: left-action gesture>string drop "Swipe left" ;
M: right-action gesture>string drop "Swipe right" ;
HOOK: action-modifier os ( -- mod )
M: object action-modifier C+ ;
-M: macosx action-modifier A+ ;
+M: macosx action-modifier M+ ;
M: action gesture>string
action-gestures value-at
projects / factor.git / blobdiff