basis/ui/gestures/gestures.factor

   1 ! Copyright (C) 2005, 2010 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 math.parser
   5 math.vectors classes.tuple classes boxes calendar timers combinators
   6 sets columns fry deques ui.gadgets ui.gadgets.private ascii
   7 combinators.short-circuit ;
   8 FROM: namespaces => set ;
   9 IN: ui.gestures
  10
  11 : get-gesture-handler ( gesture gadget -- quot )
  12     class-of superclasses [ "gestures" word-prop ] map assoc-stack ;
  13
  14 GENERIC: handle-gesture ( gesture gadget -- ? )
  15
  16 M: object handle-gesture
  17     [ nip ]
  18     [ get-gesture-handler ] 2bi
  19     dup [ call( gadget -- ) f ] [ 2drop t ] if ;
  20
  21 GENERIC: handles-gesture? ( gesture gadget -- ? )
  22
  23 M: object handles-gesture? ( gesture gadget -- ? )
  24     get-gesture-handler >boolean ;
  25
  26 : parents-handle-gesture? ( gesture gadget -- ? )
  27     [ handles-gesture? not ] with each-parent not ;
  28
  29 : set-gestures ( class hash -- ) "gestures" set-word-prop ;
  30
  31 : gesture-queue ( -- deque ) \ gesture-queue get ;
  32
  33 GENERIC: send-queued-gesture ( request -- )
  34
  35 TUPLE: send-gesture-tuple gesture gadget ;
  36
  37 M: send-gesture-tuple send-queued-gesture
  38     [ gesture>> ] [ gadget>> ] bi handle-gesture drop ;
  39
  40 : queue-gesture ( ... class -- )
  41     boa gesture-queue push-front notify-ui-thread ; inline
  42
  43 : send-gesture ( gesture gadget -- )
  44     \ send-gesture-tuple queue-gesture ;
  45
  46 : each-gesture ( gesture seq -- ) [ send-gesture ] with each ;
  47
  48 TUPLE: propagate-gesture-tuple gesture gadget ;
  49
  50 : resend-gesture ( gesture gadget -- ? )
  51     [ handle-gesture ] with each-parent ;
  52
  53 M: propagate-gesture-tuple send-queued-gesture
  54     [ gesture>> ] [ gadget>> ] bi resend-gesture drop ;
  55
  56 : propagate-gesture ( gesture gadget -- )
  57     \ propagate-gesture-tuple queue-gesture ;
  58
  59 TUPLE: propagate-key-gesture-tuple gesture world ;
  60
  61 : world-focus ( world -- gadget )
  62     dup focus>> [ world-focus ] [ ] ?if ;
  63
  64 M: propagate-key-gesture-tuple send-queued-gesture
  65     [ gesture>> ] [ world>> world-focus ] bi
  66     [ handle-gesture ] with each-parent drop ;
  67
  68 : propagate-key-gesture ( gesture world -- )
  69     \ propagate-key-gesture-tuple queue-gesture ;
  70
  71 TUPLE: user-input-tuple string world ;
  72
  73 M: user-input-tuple send-queued-gesture
  74     [ string>> ] [ world>> world-focus ] bi
  75     [ user-input* ] with each-parent drop ;
  76
  77 : user-input ( string world -- )
  78     '[ _ \ user-input-tuple queue-gesture ] unless-empty ;
  79
  80 ! Gesture objects
  81 TUPLE: drag # ;             C: <drag> drag
  82 TUPLE: button-up mods # ;   C: <button-up> button-up
  83 TUPLE: button-down mods # ; C: <button-down> button-down
  84
  85 SINGLETONS:
  86 motion
  87 mouse-scroll
  88 mouse-enter mouse-leave
  89 lose-focus gain-focus ;
  90
  91 ! Higher-level actions
  92 SINGLETONS:
  93 undo-action redo-action
  94 cut-action copy-action paste-action
  95 delete-action select-all-action
  96 left-action right-action up-action down-action
  97 zoom-in-action zoom-out-action
  98 new-action open-action save-action save-as-action
  99 revert-action close-action ;
 100
 101 UNION: action
 102 undo-action redo-action
 103 cut-action copy-action paste-action
 104 delete-action select-all-action
 105 left-action right-action up-action down-action
 106 zoom-in-action zoom-out-action
 107 new-action open-action save-action save-as-action
 108 revert-action close-action ;
 109
 110 CONSTANT: action-gestures
 111     {
 112         { "z" undo-action }
 113         { "y" redo-action }
 114         { "x" cut-action }
 115         { "c" copy-action }
 116         { "v" paste-action }
 117         { "a" select-all-action }
 118         { "n" new-action }
 119         { "o" open-action }
 120         { "s" save-action }
 121         { "S" save-as-action }
 122         { "w" close-action }
 123     }
 124
 125 ! Modifiers
 126 SYMBOLS: C+ A+ M+ S+ ;
 127
 128 TUPLE: key-gesture mods sym ;
 129
 130 TUPLE: key-down < key-gesture ;
 131
 132 : new-key-gesture ( mods sym action? class -- mods' sym' )
 133     [ [ [ S+ swap remove f like ] dip ] unless ] dip boa ; inline
 134
 135 : <key-down> ( mods sym action? -- key-down )
 136     key-down new-key-gesture ;
 137
 138 TUPLE: key-up < key-gesture ;
 139
 140 : <key-up> ( mods sym action? -- key-up )
 141     key-up new-key-gesture ;
 142
 143 ! Hand state
 144
 145 ! Note that these are only really useful inside an event
 146 ! handler, and that the locations hand-loc and hand-click-loc
 147 ! are in the co-ordinate system of the world which contains
 148 ! the gadget in question.
 149 SYMBOL: hand-gadget
 150 SYMBOL: hand-world
 151 SYMBOL: hand-loc
 152 { 0 0 } hand-loc set-global
 153
 154 SYMBOL: hand-clicked
 155 SYMBOL: hand-click-loc
 156 SYMBOL: hand-click#
 157 SYMBOL: hand-last-button
 158 SYMBOL: hand-last-time
 159 0 hand-last-button set-global
 160 0 hand-last-time set-global
 161
 162 SYMBOL: hand-buttons
 163 V{ } clone hand-buttons set-global
 164
 165 SYMBOL: scroll-direction
 166 { 0 0 } scroll-direction set-global
 167
 168 SYMBOL: double-click-timeout
 169 300 milliseconds double-click-timeout set-global
 170
 171 : hand-moved? ( -- ? )
 172     hand-loc get-global hand-click-loc get-global = not ;
 173
 174 : button-gesture ( gesture -- )
 175     hand-clicked get-global propagate-gesture ;
 176
 177 : drag-gesture ( -- )
 178     hand-buttons get-global
 179     [ first <drag> button-gesture ] unless-empty ;
 180
 181 SYMBOL: drag-timer
 182
 183 <box> drag-timer set-global
 184
 185 : start-drag-timer ( -- )
 186     hand-buttons get-global empty? [
 187         [ drag-gesture ]
 188         300 milliseconds
 189         100 milliseconds
 190         <timer>
 191         [ drag-timer get-global >box ]
 192         [ start-timer ] bi
 193     ] when ;
 194
 195 : stop-drag-timer ( -- )
 196     hand-buttons get-global empty? [
 197         drag-timer get-global ?box
 198         [ stop-timer ] [ drop ] if
 199     ] when ;
 200
 201 : fire-motion ( -- )
 202     hand-buttons get-global empty? [
 203         motion hand-gadget get-global propagate-gesture
 204     ] [
 205         drag-gesture
 206     ] if ;
 207
 208 : hand-gestures ( new old -- )
 209     drop-prefix <reversed>
 210     mouse-leave swap each-gesture
 211     mouse-enter swap each-gesture ;
 212
 213 : forget-rollover ( -- )
 214     f hand-world set-global
 215     hand-gadget get-global
 216     [ f hand-gadget set-global f ] dip
 217     parents hand-gestures ;
 218
 219 : send-lose-focus ( gadget -- )
 220     lose-focus swap send-gesture ;
 221
 222 : send-gain-focus ( gadget -- )
 223     gain-focus swap send-gesture ;
 224
 225 : focus-child ( child gadget ? -- )
 226     [
 227         dup focus>> [
 228             dup send-lose-focus
 229             f swap t focus-child
 230         ] when*
 231         dupd focus<< [
 232             send-gain-focus
 233         ] when*
 234     ] [
 235         focus<<
 236     ] if ;
 237
 238 : modifier ( mod modifiers -- seq )
 239     [ second swap bitand 0 > ] with filter
 240     0 <column> members [ f ] [ >array ] if-empty ;
 241
 242 : drag-loc ( -- loc )
 243     hand-loc get-global hand-click-loc get-global v- ;
 244
 245 : hand-rel ( gadget -- loc )
 246     hand-loc get-global swap screen-loc v- ;
 247
 248 : hand-click-rel ( gadget -- loc )
 249     hand-click-loc get-global swap screen-loc v- ;
 250
 251 : multi-click-timeout? ( -- ? )
 252     nano-count hand-last-time get - nanoseconds
 253     double-click-timeout get before=? ;
 254
 255 : multi-click-button? ( button -- button ? )
 256     dup hand-last-button get = ;
 257
 258 : multi-click-position? ( -- ? )
 259     hand-loc get-global hand-click-loc get-global distance 10 <= ;
 260
 261 : multi-click? ( button -- ? )
 262     {
 263         [ multi-click-timeout? ]
 264         [ multi-click-button? ]
 265         [ multi-click-position? ]
 266     } 0&& nip ;
 267
 268 : update-click# ( button -- )
 269     [
 270         dup multi-click? [
 271             hand-click# inc
 272         ] [
 273             1 hand-click# set
 274         ] if
 275         hand-last-button set
 276         nano-count hand-last-time set
 277     ] with-global ;
 278
 279 : update-clicked ( -- )
 280     hand-gadget get-global hand-clicked set-global
 281     hand-loc get-global hand-click-loc set-global ;
 282
 283 : under-hand ( -- seq )
 284     hand-gadget get-global parents <reversed> ;
 285
 286 : move-hand ( loc world -- )
 287     dup hand-world set-global
 288     under-hand [
 289         over hand-loc set-global
 290         pick-up hand-gadget set-global
 291         under-hand
 292     ] dip hand-gestures ;
 293
 294 : send-button-down ( gesture loc world -- )
 295     move-hand
 296     start-drag-timer
 297     dup #>>
 298     dup update-click# hand-buttons get-global push
 299     update-clicked
 300     button-gesture ;
 301
 302 : send-button-up ( gesture loc world -- )
 303     move-hand
 304     dup #>> hand-buttons get-global remove! drop
 305     stop-drag-timer
 306     button-gesture ;
 307
 308 : send-scroll ( direction loc world -- )
 309     move-hand
 310     scroll-direction set-global
 311     mouse-scroll hand-gadget get-global propagate-gesture ;
 312
 313 : send-action ( world gesture -- )
 314     swap world-focus propagate-gesture ;
 315
 316 GENERIC: gesture>string ( gesture -- string/f )
 317
 318 HOOK: modifiers>string os ( modifiers -- string )
 319
 320 M: macosx modifiers>string
 321     [
 322         {
 323             { A+ [ "\u002318" ] }
 324             { M+ [ "\u002325" ] }
 325             { S+ [ "\u0021e7" ] }
 326             { C+ [ "\u002303" ] }
 327         } case
 328     ] map "" concat-as ;
 329
 330 M: object modifiers>string
 331     [ name>> ] map "" concat-as ;
 332
 333 HOOK: keysym>string os ( keysym -- string )
 334
 335 M: macosx keysym>string >upper ;
 336
 337 M: object keysym>string dup length 1 = [ >lower ] when ;
 338
 339 M: key-down gesture>string
 340     [ mods>> ] [ sym>> ] bi
 341     {
 342         { [ dup { [ length 1 = ] [ first LETTER? ] } 1&& ] [ [ S+ prefix ] dip ] }
 343         { [ dup " " = ] [ drop "SPACE" ] }
 344         [ ]
 345     } cond
 346     [ modifiers>string ] [ keysym>string ] bi* append ;
 347
 348 M: button-up gesture>string
 349     [
 350         dup mods>> modifiers>string %
 351         "Click Button" %
 352         #>> [ " " % # ] when*
 353     ] "" make ;
 354
 355 M: button-down gesture>string
 356     [
 357         dup mods>> modifiers>string %
 358         "Press Button" %
 359         #>> [ " " % # ] when*
 360     ] "" make ;
 361
 362 M: left-action gesture>string drop "Swipe left" ;
 363
 364 M: right-action gesture>string drop "Swipe right" ;
 365
 366 M: up-action gesture>string drop "Swipe up" ;
 367
 368 M: down-action gesture>string drop "Swipe down" ;
 369
 370 M: zoom-in-action gesture>string drop "Zoom in" ;
 371
 372 M: zoom-out-action gesture>string drop "Zoom out (pinch)" ;
 373
 374 HOOK: action-modifier os ( -- mod )
 375
 376 M: object action-modifier C+ ;
 377 M: macosx action-modifier A+ ;
 378
 379 M: action gesture>string
 380     action-gestures value-at
 381     action-modifier 1array
 382     swap f <key-down> gesture>string ;
 383
 384 M: object gesture>string drop f ;