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: mouse-scroll ;
  31 TUPLE: mouse-enter ;
  32 TUPLE: mouse-leave ;
  33 TUPLE: lose-focus ;
  34 TUPLE: gain-focus ;
  35
  36 ! Higher-level actions
  37 TUPLE: cut-action ;
  38 TUPLE: copy-action ;
  39 TUPLE: paste-action ;
  40 TUPLE: delete-action ;
  41 TUPLE: select-all-action ;
  42
  43 : handle-action ( gadget constructor -- )
  44     execute swap handle-gesture drop ; inline
  45
  46 : generalize-gesture ( gesture -- gesture )
  47     #! Strip button number from drag/button-up/button-down.
  48     tuple>array 1 head* >tuple ;
  49
  50 ! Modifiers
  51 SYMBOL: C+
  52 SYMBOL: A+
  53 SYMBOL: M+
  54 SYMBOL: S+
  55
  56 TUPLE: key-down mods sym ;
  57 TUPLE: key-up mods sym ;
  58
  59 ! Hand state
  60
  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.
  65 SYMBOL: hand-gadget
  66 SYMBOL: hand-world
  67 SYMBOL: hand-loc
  68 { 0 0 } hand-loc set-global
  69
  70 SYMBOL: hand-clicked
  71 SYMBOL: hand-click-loc
  72
  73 SYMBOL: hand-buttons
  74 V{ } clone hand-buttons set-global
  75
  76 SYMBOL: scroll-direction
  77 { 0 0 } scroll-direction set-global
  78
  79 : button-gesture ( gesture -- )
  80     hand-clicked get-global 2dup handle-gesture [
  81         >r generalize-gesture r> handle-gesture drop
  82     ] [
  83         2drop
  84     ] if ;
  85
  86 : drag-gesture ( -- )
  87     hand-buttons get-global first <drag> button-gesture ;
  88
  89 : fire-motion ( -- )
  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
  95     ] [
  96         drag-gesture
  97     ] if ;
  98
  99 : each-gesture ( gesture seq -- )
 100     [ handle-gesture* drop ] each-with ;
 101
 102 : hand-gestures ( new old -- )
 103     drop-prefix <reversed>
 104     T{ mouse-leave } swap each-gesture
 105     T{ mouse-enter } swap each-gesture ;
 106
 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 ;
 113
 114 : focus-gestures ( new old -- )
 115     drop-prefix <reversed>
 116     T{ lose-focus } swap each-gesture
 117     T{ gain-focus } swap each-gesture ;
 118
 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 ;
 123
 124 : request-focus* ( gadget world -- )
 125     dup focused-ancestors >r
 126     [ set-world-focus ] keep
 127     focus-receiver r> focus-gestures ;
 128
 129 : request-focus ( gadget -- )
 130     dup focusable-child swap find-world
 131     [ request-focus* ] [ drop ] if* ;
 132
 133 : modifier ( mod modifiers -- seq )
 134     [ second swap bitand 0 > ] subset-with
 135     [ first ] map prune f like ;
 136
 137 : drag-loc ( -- loc )
 138     hand-loc get-global hand-click-loc get-global v- ;
 139
 140 : hand-rel ( gadget -- loc )
 141     hand-loc get-global relative-loc ;
 142
 143 : hand-click-rel ( gadget -- loc )
 144     hand-click-loc get-global relative-loc ;
 145
 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> ;
 150
 151 : update-clicked ( -- )
 152     hand-gadget get-global hand-clicked set-global
 153     hand-loc get-global hand-click-loc set-global ;
 154
 155 SYMBOL: menu-mode?
 156
 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 ;
 163
 164 : send-button-down ( gesture loc world -- )
 165     move-hand
 166     update-clicked
 167     dup button-down-# hand-buttons get-global push
 168     button-gesture ;
 169
 170 : send-button-up ( gesture loc world -- )
 171     move-hand
 172     dup button-up-# hand-buttons get-global delete
 173     button-gesture ;
 174
 175 : send-wheel ( direction loc world -- )
 176     move-hand
 177     scroll-direction set-global
 178     T{ mouse-scroll } hand-gadget get-global handle-gesture
 179     drop ;
 180
 181 : send-action ( world gesture -- )
 182     swap world-focus handle-gesture drop ;
 183
 184 : resend-button-down ( gesture world -- )
 185     hand-loc get-global swap send-button-down ;
 186
 187 : resend-button-up  ( gesture world -- )
 188     hand-loc get-global swap send-button-up ;
 189
 190 world H{
 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 ] }
 199 } set-gestures