factor/library/ui/gestures.factor

! Copyright (C) 2005, 2006 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: gadgets
USING: arrays generic hashtables kernel math models namespaces
queues sequences words ;

: gestures ( gadget -- seq )
    delegates [ class "gestures" word-prop ] map [ ] subset ;

: set-gestures ( class hash -- ) "gestures" set-word-prop ;

: handle-gesture* ( gesture gadget -- )
    tuck gestures hash-stack [ call f ] [ drop t ] if* ;

: handle-gesture ( gesture gadget -- ? )
    #! If a gadget's handle-gesture* generic returns t, the
    #! event was not consumed and is passed on to the gadget's
    #! parent. This word returns t if no gadget handled the
    #! gesture, otherwise returns f.
    [ dupd handle-gesture* ] each-parent nip ;

: user-input ( str gadget -- )
    [ dupd user-input* ] each-parent 2drop ;

! Gesture objects
TUPLE: motion ;
TUPLE: drag # ;
TUPLE: button-up mods # ;
TUPLE: button-down mods # ;
TUPLE: mouse-scroll ;
TUPLE: mouse-enter ;
TUPLE: mouse-leave ;
TUPLE: lose-focus ;
TUPLE: gain-focus ;

! Higher-level actions
TUPLE: cut-action ;
TUPLE: copy-action ;
TUPLE: paste-action ;
TUPLE: delete-action ;
TUPLE: select-all-action ;

: handle-action ( gadget constructor -- )
    execute swap handle-gesture drop ; inline

: generalize-gesture ( gesture -- gesture )
    #! Strip button number from drag/button-up/button-down.
    tuple>array 1 head* >tuple ;

! Modifiers
SYMBOL: C+
SYMBOL: A+
SYMBOL: M+
SYMBOL: S+

TUPLE: key-down mods sym ;
TUPLE: key-up mods sym ;

! Hand state

! 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
! the gadget in question.
SYMBOL: hand-gadget
SYMBOL: hand-world
SYMBOL: hand-loc
{ 0 0 } hand-loc set-global

SYMBOL: hand-clicked
SYMBOL: hand-click-loc
SYMBOL: hand-click#
SYMBOL: hand-last-button
SYMBOL: hand-last-time
0 hand-last-button set-global
0 hand-last-time set-global

SYMBOL: hand-buttons
V{ } clone hand-buttons set-global

SYMBOL: scroll-direction
{ 0 0 } scroll-direction set-global

SYMBOL: double-click-timeout
300 double-click-timeout set-global

: button-gesture ( gesture -- )
    hand-clicked get-global 2dup handle-gesture [
        >r generalize-gesture r> handle-gesture drop
    ] [
        2drop
    ] if ;

: drag-gesture ( -- )
    hand-buttons get-global first <drag> button-gesture ;

: fire-motion ( -- )
    #! Fire a motion gesture to the gadget underneath the hand,
    #! and if a mouse button is down, fire a drag gesture to the
    #! gadget that was clicked.
    hand-buttons get-global empty? [
        T{ motion } hand-gadget get-global handle-gesture drop
    ] [
        drag-gesture
    ] if ;

: each-gesture ( gesture seq -- )
    [ handle-gesture* drop ] each-with ;

: hand-gestures ( new old -- )
    drop-prefix <reversed>
    T{ mouse-leave } swap each-gesture
    T{ mouse-enter } swap each-gesture ;

: forget-rollover ( -- )
    #! After we restore the UI, send mouse leave events to all
    #! gadgets that were under the mouse at the time of the
    #! save, since the mouse is in a different location now.
    f hand-world set-global
    hand-gadget get-global >r
    f hand-gadget set-global
    f r> parents hand-gestures ;

: focus-gestures ( new old -- )
    drop-prefix <reversed>
    T{ lose-focus } swap each-gesture
    T{ gain-focus } swap each-gesture ;

: focus-receiver ( world -- seq )
    #! If the world is not focused, we want focus-gestures to
    #! only send focus-lost and not focus-gained.
    dup world-focused? [ focused-ancestors ] [ drop f ] if ;

: request-focus* ( gadget world -- )
    dup focused-ancestors >r
    [ set-world-focus ] keep
    focus-receiver r> focus-gestures ;

: request-focus ( gadget -- )
    dup focusable-child swap find-world
    [ request-focus* ] [ drop ] if* ;

: modifier ( mod modifiers -- seq )
    [ second swap bitand 0 > ] subset-with
    [ first ] map prune f like ;

: drag-loc ( -- loc )
    hand-loc get-global hand-click-loc get-global v- ;

: hand-rel ( gadget -- loc )
    hand-loc get-global relative-loc ;

: hand-click-rel ( gadget -- loc )
    hand-click-loc get-global relative-loc ;

: multi-click? ( button -- ? )
    millis hand-last-time get - double-click-timeout get <=
    swap hand-last-button get = and ;

: update-click# ( button -- )
    global [
        multi-click? [
            hand-click# inc
        ] [
            1 hand-click# set
        ] if
    ] bind ;

: update-clicked ( button -- )
    hand-last-button set-global
    hand-gadget get-global hand-clicked set-global
    hand-loc get-global hand-click-loc set-global
    millis hand-last-time set-global ;
 
: under-hand ( -- seq )
    #! A sequence whose first element is the world and last is
    #! the current gadget, with all parents in between.
    hand-gadget get-global parents <reversed> ;

: move-hand ( loc world -- )
    dup hand-world set-global
    under-hand >r over hand-loc set-global
    pick-up hand-gadget set-global
    menu-mode? get-global [ update-clicked ] when
    under-hand r> hand-gestures ;

: send-button-down ( gesture loc world -- )
    move-hand
    dup button-down-#
    dup update-click#
    dup update-clicked
    hand-buttons get-global push
    button-gesture ;

: send-button-up ( gesture loc world -- )
    move-hand
    dup button-up-# hand-buttons get-global delete
    button-gesture ;

: send-wheel ( direction loc world -- )
    move-hand
    scroll-direction set-global
    T{ mouse-scroll } hand-gadget get-global handle-gesture
    drop ;

: send-action ( world gesture -- )
    swap world-focus handle-gesture drop ;

: resend-button-down ( gesture world -- )
    hand-loc get-global swap send-button-down ;

: resend-button-up  ( gesture world -- )
    hand-loc get-global swap send-button-up ;

world H{
    { T{ key-down f { C+ } "x" } [ T{ cut-action } send-action ] }
    { T{ key-down f { C+ } "c" } [ T{ copy-action } send-action ] }
    { T{ key-down f { C+ } "v" } [ T{ paste-action } send-action ] }
    { T{ key-down f { C+ } "a" } [ T{ select-all-action } send-action ] }
    { T{ button-down f { C+ } 1 } [ T{ button-down f f 3 } swap resend-button-down ] }
    { T{ button-down f { A+ } 1 } [ T{ button-down f f 2 } swap resend-button-down ] }
    { T{ button-up f { C+ } 1 } [ T{ button-up f f 3 } swap resend-button-up ] }
    { T{ button-up f { A+ } 1 } [ T{ button-up f f 2 } swap resend-button-up ] }
} set-gestures