basis/ui/gestures/gestures.factor

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