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