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