extra/ui/gestures/gestures.factor

   1 ! Copyright (C) 2005, 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors 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 columns ;
   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 but-last >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
 115     dup empty? [ drop ] [ first <drag> button-gesture ] if ;
 116
 117 SYMBOL: drag-timer
 118
 119 <box> drag-timer set-global
 120
 121 : start-drag-timer ( -- )
 122     hand-buttons get-global empty? [
 123         [ drag-gesture ]
 124         300 milliseconds from-now
 125         100 milliseconds
 126         add-alarm drag-timer get-global >box
 127     ] when ;
 128
 129 : stop-drag-timer ( -- )
 130     hand-buttons get-global empty? [
 131         drag-timer get-global ?box
 132         [ cancel-alarm ] [ drop ] if
 133     ] when ;
 134
 135 : fire-motion ( -- )
 136     hand-buttons get-global empty? [
 137         T{ motion } hand-gadget get-global send-gesture drop
 138     ] [
 139         drag-gesture
 140     ] if ;
 141
 142 : each-gesture ( gesture seq -- )
 143     [ handle-gesture drop ] with each ;
 144
 145 : hand-gestures ( new old -- )
 146     drop-prefix <reversed>
 147     T{ mouse-leave } swap each-gesture
 148     T{ mouse-enter } swap each-gesture ;
 149
 150 : forget-rollover ( -- )
 151     f hand-world set-global
 152     hand-gadget get-global >r
 153     f hand-gadget set-global
 154     f r> parents hand-gestures ;
 155
 156 : send-lose-focus ( gadget -- )
 157     T{ lose-focus } swap handle-gesture drop ;
 158
 159 : send-gain-focus ( gadget -- )
 160     T{ gain-focus } swap handle-gesture drop ;
 161
 162 : focus-child ( child gadget ? -- )
 163     [
 164         dup gadget-focus [
 165             dup send-lose-focus
 166             f swap t focus-child
 167         ] when*
 168         dupd set-gadget-focus [
 169             send-gain-focus
 170         ] when*
 171     ] [
 172         set-gadget-focus
 173     ] if ;
 174
 175 : modifier ( mod modifiers -- seq )
 176     [ second swap bitand 0 > ] with filter
 177     0 <column> prune dup empty? [ drop f ] [ >array ] if ;
 178
 179 : drag-loc ( -- loc )
 180     hand-loc get-global hand-click-loc get-global v- ;
 181
 182 : hand-rel ( gadget -- loc )
 183     hand-loc get-global swap screen-loc v- ;
 184
 185 : hand-click-rel ( gadget -- loc )
 186     hand-click-loc get-global swap screen-loc v- ;
 187
 188 : multi-click-timeout? ( -- ? )
 189     millis hand-last-time get - double-click-timeout get <= ;
 190
 191 : multi-click-button? ( button -- button ? )
 192     dup hand-last-button get = ;
 193
 194 : multi-click-position? ( -- ? )
 195     hand-loc get hand-click-loc get v- norm 10 <= ;
 196
 197 : multi-click? ( button -- ? )
 198     {
 199         { [ multi-click-timeout?  not ] [ f ] }
 200         { [ multi-click-button?   not ] [ f ] }
 201         { [ multi-click-position? not ] [ f ] }
 202         { [ multi-click-position? not ] [ f ] }
 203         [ t ]
 204     } cond nip ;
 205
 206 : update-click# ( button -- )
 207     global [
 208         dup multi-click? [
 209             hand-click# inc
 210         ] [
 211             1 hand-click# set
 212         ] if
 213         hand-last-button set
 214         millis hand-last-time set
 215     ] bind ;
 216
 217 : update-clicked ( -- )
 218     hand-gadget get-global hand-clicked set-global
 219     hand-loc get-global hand-click-loc set-global ;
 220
 221 : under-hand ( -- seq )
 222     hand-gadget get-global parents <reversed> ;
 223
 224 : move-hand ( loc world -- )
 225     dup hand-world set-global
 226     under-hand >r over hand-loc set-global
 227     pick-up hand-gadget set-global
 228     under-hand r> hand-gestures ;
 229
 230 : send-button-down ( gesture loc world -- )
 231     move-hand
 232     start-drag-timer
 233     dup button-down-#
 234     dup update-click# hand-buttons get-global push
 235     update-clicked
 236     button-gesture ;
 237
 238 : send-button-up ( gesture loc world -- )
 239     move-hand
 240     dup button-up-# hand-buttons get-global delete
 241     stop-drag-timer
 242     button-gesture ;
 243
 244 : send-wheel ( direction loc world -- )
 245     move-hand
 246     scroll-direction set-global
 247     T{ mouse-scroll } hand-gadget get-global send-gesture
 248     drop ;
 249
 250 : world-focus ( world -- gadget )
 251     dup gadget-focus [ world-focus ] [ ] ?if ;
 252
 253 : send-action ( world gesture -- )
 254     swap world-focus send-gesture drop ;
 255
 256 : resend-button-down ( gesture world -- )
 257     hand-loc get-global swap send-button-down ;
 258
 259 : resend-button-up  ( gesture world -- )
 260     hand-loc get-global swap send-button-up ;
 261
 262 GENERIC: gesture>string ( gesture -- string/f )
 263
 264 : modifiers>string ( modifiers -- string )
 265     [ name>> ] map concat >string ;
 266
 267 M: key-down gesture>string
 268     dup key-down-mods modifiers>string
 269     swap key-down-sym append ;
 270
 271 M: button-up gesture>string
 272     [
 273         dup button-up-mods modifiers>string %
 274         "Click Button" %
 275         button-up-# [ " " % # ] when*
 276     ] "" make ;
 277
 278 M: button-down gesture>string
 279     [
 280         dup button-down-mods modifiers>string %
 281         "Press Button" %
 282         button-down-# [ " " % # ] when*
 283     ] "" make ;
 284
 285 M: left-action gesture>string drop "Swipe left" ;
 286
 287 M: right-action gesture>string drop "Swipe right" ;
 288
 289 M: up-action gesture>string drop "Swipe up" ;
 290
 291 M: down-action gesture>string drop "Swipe down" ;
 292
 293 M: zoom-in-action gesture>string drop "Zoom in" ;
 294
 295 M: zoom-out-action gesture>string drop "Zoom out (pinch)" ;
 296
 297 M: object gesture>string drop f ;