library/ui/gestures.factor

   1 ! Copyright (C) 2005, 2006 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 IN: gadgets
   4 USING: arrays generic hashtables kernel math models namespaces
   5 queues sequences words ;
   6
   7 : gestures ( gadget -- seq )
   8     delegates [ class "gestures" word-prop ] map [ ] subset ;
   9
  10 : set-gestures ( class hash -- ) "gestures" set-word-prop ;
  11
  12 : handle-gesture* ( gesture gadget -- )
  13     tuck gestures hash-stack [ call f ] [ drop t ] if* ;
  14
  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 ;
  21
  22 : user-input ( str gadget -- )
  23     [ dupd user-input* ] each-parent 2drop ;
  24
  25 ! Gesture objects
  26 TUPLE: motion ;
  27 TUPLE: drag # ;
  28 TUPLE: button-up mods # ;
  29 TUPLE: button-down mods # ;
  30 TUPLE: wheel-up ;
  31 TUPLE: wheel-down ;
  32 TUPLE: mouse-enter ;
  33 TUPLE: mouse-leave ;
  34 TUPLE: lose-focus ;
  35 TUPLE: gain-focus ;
  36
  37 ! Higher-level actions
  38 TUPLE: cut-action ;
  39 TUPLE: copy-action ;
  40 TUPLE: paste-action ;
  41 TUPLE: delete-action ;
  42 TUPLE: select-all-action ;
  43
  44 : handle-action ( gadget constructor -- )
  45     execute swap handle-gesture drop ; inline
  46
  47 : generalize-gesture ( gesture -- gesture )
  48     #! Strip button number from drag/button-up/button-down.
  49     tuple>array 1 head* >tuple ;
  50
  51 ! Modifiers
  52 SYMBOL: C+
  53 SYMBOL: A+
  54 SYMBOL: M+
  55 SYMBOL: S+
  56
  57 TUPLE: key-down mods sym ;
  58 TUPLE: key-up mods sym ;
  59
  60 ! Hand state
  61
  62 ! Note that these are only really useful inside an event
  63 ! handler, and that the locations hand-loc and hand-click-loc
  64 ! are in the co-ordinate system of the world which contains
  65 ! the gadget in question.
  66 SYMBOL: hand-gadget
  67 SYMBOL: hand-world
  68 SYMBOL: hand-loc
  69 { 0 0 } hand-loc set-global
  70
  71 SYMBOL: hand-clicked
  72 SYMBOL: hand-click-loc
  73
  74 SYMBOL: hand-buttons
  75 V{ } clone hand-buttons set-global
  76
  77 : button-gesture ( gesture -- )
  78     hand-clicked get-global 2dup handle-gesture [
  79         >r generalize-gesture r> handle-gesture drop
  80     ] [
  81         2drop
  82     ] if ;
  83
  84 : drag-gesture ( -- )
  85     hand-buttons get-global first <drag> button-gesture ;
  86
  87 : fire-motion ( -- )
  88     #! Fire a motion gesture to the gadget underneath the hand,
  89     #! and if a mouse button is down, fire a drag gesture to the
  90     #! gadget that was clicked.
  91     hand-buttons get-global empty? [
  92         T{ motion } hand-gadget get-global handle-gesture drop
  93     ] [
  94         drag-gesture
  95     ] if ;
  96
  97 : each-gesture ( gesture seq -- )
  98     [ handle-gesture* drop ] each-with ;
  99
 100 : hand-gestures ( new old -- )
 101     drop-prefix <reversed>
 102     T{ mouse-leave } swap each-gesture
 103     T{ mouse-enter } swap each-gesture ;
 104
 105 : forget-rollover ( -- )
 106     #! After we restore the UI, send mouse leave events to all
 107     #! gadgets that were under the mouse at the time of the
 108     #! save, since the mouse is in a different location now.
 109     f hand-gadget [ get-global ] 2keep set-global
 110     parents hand-gestures ;
 111
 112 : focus-gestures ( new old -- )
 113     drop-prefix <reversed>
 114     T{ lose-focus } swap each-gesture
 115     T{ gain-focus } swap each-gesture ;
 116
 117 : focus-receiver ( world -- seq )
 118     #! If the world is not focused, we want focus-gestures to
 119     #! only send focus-lost and not focus-gained.
 120     dup world-focused? [ focused-ancestors ] [ drop f ] if ;
 121
 122 : request-focus* ( gadget world -- )
 123     dup focused-ancestors >r
 124     [ set-world-focus ] keep
 125     focus-receiver r> focus-gestures ;
 126
 127 : request-focus ( gadget -- )
 128     dup focusable-child swap find-world
 129     [ request-focus* ] [ drop ] if* ;
 130
 131 : modifier ( mod modifiers -- seq )
 132     [ second swap bitand 0 > ] subset-with
 133     [ first ] map prune f like ;
 134
 135 : drag-loc ( -- loc )
 136     hand-loc get-global hand-click-loc get-global v- ;
 137
 138 : hand-rel ( gadget -- loc )
 139     hand-loc get-global relative-loc ;
 140
 141 : hand-click-rel ( gadget -- loc )
 142     hand-click-loc get-global relative-loc ;
 143
 144 : under-hand ( -- seq )
 145     #! A sequence whose first element is the world and last is
 146     #! the current gadget, with all parents in between.
 147     hand-gadget get-global parents <reversed> ;
 148
 149 : update-clicked ( -- )
 150     hand-gadget get-global hand-clicked set-global
 151     hand-loc get-global hand-click-loc set-global ;
 152
 153 SYMBOL: menu-mode?
 154
 155 : move-hand ( loc world -- )
 156     dup hand-world set-global
 157     under-hand >r over hand-loc set-global
 158     pick-up hand-gadget set-global
 159     menu-mode? get-global [ update-clicked ] when
 160     under-hand r> hand-gestures ;
 161
 162 : send-button-down ( gesture loc world -- )
 163     move-hand
 164     update-clicked
 165     dup button-down-# hand-buttons get-global push
 166     button-gesture ;
 167
 168 : send-button-up ( gesture loc world -- )
 169     move-hand
 170     dup button-up-# hand-buttons get-global delete
 171     button-gesture ;
 172
 173 : send-wheel ( up/down loc world -- )
 174     move-hand
 175     T{ wheel-up } T{ wheel-down } ?
 176     hand-gadget get-global handle-gesture drop ;
 177
 178 : send-action ( world gesture -- )
 179     swap world-focus handle-gesture drop ;
 180
 181 : resend-button-down ( gesture world -- )
 182     hand-loc get-global swap send-button-down ;
 183
 184 : resend-button-up  ( gesture world -- )
 185     hand-loc get-global swap send-button-up ;
 186
 187 world H{
 188     { T{ key-down f { C+ } "x" } [ T{ cut-action } send-action ] }
 189     { T{ key-down f { C+ } "c" } [ T{ copy-action } send-action ] }
 190     { T{ key-down f { C+ } "v" } [ T{ paste-action } send-action ] }
 191     { T{ key-down f { C+ } "a" } [ T{ select-all-action } send-action ] }
 192     { T{ button-down f { C+ } 1 } [ T{ button-down f f 3 } swap resend-button-down ] }
 193     { T{ button-down f { A+ } 1 } [ T{ button-down f f 2 } swap resend-button-down ] }
 194     { T{ button-up f { C+ } 1 } [ T{ button-up f f 3 } swap resend-button-up ] }
 195     { T{ button-up f { A+ } 1 } [ T{ button-up f f 2 } swap resend-button-up ] }
 196 } set-gestures