extra/ui/gestures/gestures.factor

   1 ! Copyright (C) 2005, 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: arrays assocs kernel math models namespaces
   4 sequences words strings system hashtables math.parser
   5 math.vectors classes.tuple classes ui.gadgets boxes
   6 calendar alarms symbols combinators sets ;
   7 IN: ui.gestures
   8
   9 : set-gestures ( class hash -- ) "gestures" set-word-prop ;
  10
  11 GENERIC: handle-gesture* ( gadget gesture delegate -- ? )
  12
  13 : default-gesture-handler ( gadget gesture delegate -- ? )
  14     class "gestures" word-prop at dup
  15     [ call f ] [ 2drop t ] if ;
  16
  17 M: object handle-gesture* default-gesture-handler ;
  18
  19 : handle-gesture ( gesture gadget -- ? )
  20     tuck delegates [ >r 2dup r> handle-gesture* ] all? 2nip ;
  21
  22 : send-gesture ( gesture gadget -- ? )
  23     [ dupd handle-gesture ] each-parent nip ;
  24
  25 : user-input ( str gadget -- )
  26     over empty?
  27     [ [ dupd user-input* ] each-parent ] unless
  28     2drop ;
  29
  30 ! Gesture objects
  31 TUPLE: motion ;             C: <motion> motion
  32 TUPLE: drag # ;             C: <drag> drag
  33 TUPLE: button-up mods # ;   C: <button-up> button-up
  34 TUPLE: button-down mods # ; C: <button-down> button-down
  35 TUPLE: mouse-scroll ;       C: <mouse-scroll> mouse-scroll
  36 TUPLE: mouse-enter ;        C: <mouse-enter> mouse-enter
  37 TUPLE: mouse-leave ;        C: <mouse-leave> mouse-leave
  38 TUPLE: lose-focus ;         C: <lose-focus> lose-focus
  39 TUPLE: gain-focus ;         C: <gain-focus> gain-focus
  40
  41 ! Higher-level actions
  42 TUPLE: cut-action ;         C: <cut-action> cut-action
  43 TUPLE: copy-action ;        C: <copy-action> copy-action
  44 TUPLE: paste-action ;       C: <paste-action> paste-action
  45 TUPLE: delete-action ;      C: <delete-action> delete-action
  46 TUPLE: select-all-action ;  C: <select-all-action> select-all-action
  47
  48 TUPLE: left-action ;        C: <left-action> left-action
  49 TUPLE: right-action ;       C: <right-action> right-action
  50 TUPLE: up-action ;          C: <up-action> up-action
  51 TUPLE: down-action ;        C: <down-action> down-action
  52
  53 TUPLE: zoom-in-action ;  C: <zoom-in-action> zoom-in-action
  54 TUPLE: zoom-out-action ; C: <zoom-out-action> zoom-out-action
  55
  56 : generalize-gesture ( gesture -- newgesture )
  57     tuple>array 1 head* >tuple ;
  58
  59 ! Modifiers
  60 SYMBOLS: C+ A+ M+ S+ ;
  61
  62 TUPLE: key-down mods sym ;
  63
  64 : <key-gesture> ( mods sym action? class -- mods' sym' )
  65     >r [ S+ rot remove swap ] unless r> boa ; inline
  66
  67 : <key-down> ( mods sym action? -- key-down )
  68     key-down <key-gesture> ;
  69
  70 TUPLE: key-up mods sym ;
  71
  72 : <key-up> ( mods sym action? -- key-up )
  73     key-up <key-gesture> ;
  74
  75 ! Hand state
  76
  77 ! Note that these are only really useful inside an event
  78 ! handler, and that the locations hand-loc and hand-click-loc
  79 ! are in the co-ordinate system of the world which contains
  80 ! the gadget in question.
  81 SYMBOL: hand-gadget
  82 SYMBOL: hand-world
  83 SYMBOL: hand-loc
  84 { 0 0 } hand-loc set-global
  85
  86 SYMBOL: hand-clicked
  87 SYMBOL: hand-click-loc
  88 SYMBOL: hand-click#
  89 SYMBOL: hand-last-button
  90 SYMBOL: hand-last-time
  91 0 hand-last-button set-global
  92 0 hand-last-time set-global
  93
  94 SYMBOL: hand-buttons
  95 V{ } clone hand-buttons set-global
  96
  97 SYMBOL: scroll-direction
  98 { 0 0 } scroll-direction set-global
  99
 100 SYMBOL: double-click-timeout
 101 300 double-click-timeout set-global
 102
 103 : hand-moved? ( -- ? )
 104     hand-loc get hand-click-loc get = not ;
 105
 106 : button-gesture ( gesture -- )
 107     hand-clicked get-global 2dup send-gesture [
 108         >r generalize-gesture r> send-gesture drop
 109     ] [
 110         2drop
 111     ] if ;
 112
 113 : drag-gesture ( -- )
 114     hand-buttons get-global first <drag> button-gesture ;
 115
 116 SYMBOL: drag-timer
 117
 118 <box> drag-timer set-global
 119
 120 : start-drag-timer ( -- )
 121     hand-buttons get-global empty? [
 122         [ drag-gesture ]
 123         300 milliseconds from-now
 124         100 milliseconds
 125         add-alarm drag-timer get-global >box
 126     ] when ;
 127
 128 : stop-drag-timer ( -- )
 129     hand-buttons get-global empty? [
 130         drag-timer get-global ?box
 131         [ cancel-alarm ] [ drop ] if
 132     ] when ;
 133
 134 : fire-motion ( -- )
 135     hand-buttons get-global empty? [
 136         T{ motion } hand-gadget get-global send-gesture drop
 137     ] [
 138         drag-gesture
 139     ] if ;
 140
 141 : each-gesture ( gesture seq -- )
 142     [ handle-gesture drop ] with each ;
 143
 144 : hand-gestures ( new old -- )
 145     drop-prefix <reversed>
 146     T{ mouse-leave } swap each-gesture
 147     T{ mouse-enter } swap each-gesture ;
 148
 149 : forget-rollover ( -- )
 150     f hand-world set-global
 151     hand-gadget get-global >r
 152     f hand-gadget set-global
 153     f r> parents hand-gestures ;
 154
 155 : send-lose-focus ( gadget -- )
 156     T{ lose-focus } swap handle-gesture drop ;
 157
 158 : send-gain-focus ( gadget -- )
 159     T{ gain-focus } swap handle-gesture drop ;
 160
 161 : focus-child ( child gadget ? -- )
 162     [
 163         dup gadget-focus [
 164             dup send-lose-focus
 165             f swap t focus-child
 166         ] when*
 167         dupd set-gadget-focus [
 168             send-gain-focus
 169         ] when*
 170     ] [
 171         set-gadget-focus
 172     ] if ;
 173
 174 : modifier ( mod modifiers -- seq )
 175     [ second swap bitand 0 > ] with subset
 176     0 <column> prune dup empty? [ drop f ] [ >array ] if ;
 177
 178 : drag-loc ( -- loc )
 179     hand-loc get-global hand-click-loc get-global v- ;
 180
 181 : hand-rel ( gadget -- loc )
 182     hand-loc get-global swap screen-loc v- ;
 183
 184 : hand-click-rel ( gadget -- loc )
 185     hand-click-loc get-global swap screen-loc v- ;
 186
 187 : multi-click-timeout? ( -- ? )
 188     millis hand-last-time get - double-click-timeout get <= ;
 189
 190 : multi-click-button? ( button -- button ? )
 191     dup hand-last-button get = ;
 192
 193 : multi-click-position? ( -- ? )
 194     hand-loc get hand-click-loc get v- norm 10 <= ;
 195
 196 : multi-click? ( button -- ? )
 197     {
 198         { [ multi-click-timeout?  not ] [ f ] }
 199         { [ multi-click-button?   not ] [ f ] }
 200         { [ multi-click-position? not ] [ f ] }
 201         { [ multi-click-position? not ] [ f ] }
 202         [ t ]
 203     } cond nip ;
 204
 205 : update-click# ( button -- )
 206     global [
 207         dup multi-click? [
 208             hand-click# inc
 209         ] [
 210             1 hand-click# set
 211         ] if
 212         hand-last-button set
 213         millis hand-last-time set
 214     ] bind ;
 215
 216 : update-clicked ( -- )
 217     hand-gadget get-global hand-clicked set-global
 218     hand-loc get-global hand-click-loc set-global ;
 219
 220 : under-hand ( -- seq )
 221     hand-gadget get-global parents <reversed> ;
 222
 223 : move-hand ( loc world -- )
 224     dup hand-world set-global
 225     under-hand >r over hand-loc set-global
 226     pick-up hand-gadget set-global
 227     under-hand r> hand-gestures ;
 228
 229 : send-button-down ( gesture loc world -- )
 230     move-hand
 231     start-drag-timer
 232     dup button-down-#
 233     dup update-click# hand-buttons get-global push
 234     update-clicked
 235     button-gesture ;
 236
 237 : send-button-up ( gesture loc world -- )
 238     move-hand
 239     dup button-up-# hand-buttons get-global delete
 240     stop-drag-timer
 241     button-gesture ;
 242
 243 : send-wheel ( direction loc world -- )
 244     move-hand
 245     scroll-direction set-global
 246     T{ mouse-scroll } hand-gadget get-global send-gesture
 247     drop ;
 248
 249 : world-focus ( world -- gadget )
 250     dup gadget-focus [ world-focus ] [ ] ?if ;
 251
 252 : send-action ( world gesture -- )
 253     swap world-focus send-gesture drop ;
 254
 255 : resend-button-down ( gesture world -- )
 256     hand-loc get-global swap send-button-down ;
 257
 258 : resend-button-up  ( gesture world -- )
 259     hand-loc get-global swap send-button-up ;
 260
 261 GENERIC: gesture>string ( gesture -- string/f )
 262
 263 : modifiers>string ( modifiers -- string )
 264     [ word-name ] map concat >string ;
 265
 266 M: key-down gesture>string
 267     dup key-down-mods modifiers>string
 268     swap key-down-sym append ;
 269
 270 M: button-up gesture>string
 271     [
 272         dup button-up-mods modifiers>string %
 273         "Click Button" %
 274         button-up-# [ " " % # ] when*
 275     ] "" make ;
 276
 277 M: button-down gesture>string
 278     [
 279         dup button-down-mods modifiers>string %
 280         "Press Button" %
 281         button-down-# [ " " % # ] when*
 282     ] "" make ;
 283
 284 M: left-action gesture>string drop "Swipe left" ;
 285
 286 M: right-action gesture>string drop "Swipe right" ;
 287
 288 M: up-action gesture>string drop "Swipe up" ;
 289
 290 M: down-action gesture>string drop "Swipe down" ;
 291
 292 M: zoom-in-action gesture>string drop "Zoom in" ;
 293
 294 M: zoom-out-action gesture>string drop "Zoom out (pinch)" ;
 295
 296 M: object gesture>string drop f ;