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