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