basis/ui/gestures/gestures.factor

   1 ! Copyright (C) 2005, 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays assocs kernel math models namespaces
   4 make sequences words strings system hashtables math.parser
   5 math.vectors classes.tuple classes ui.gadgets boxes calendar
   6 alarms symbols combinators sets columns ;
   7 IN: ui.gestures
   8
   9 : set-gestures ( class hash -- ) "gestures" set-word-prop ;
  10
  11 GENERIC: handle-gesture ( gesture gadget -- ? )
  12
  13 M: object handle-gesture
  14     tuck class superclasses
  15     [ "gestures" word-prop ] map
  16     assoc-stack dup [ call f ] [ 2drop t ] if ;
  17
  18 : send-gesture ( gesture gadget -- ? )
  19     [ dupd handle-gesture ] each-parent nip ;
  20
  21 : user-input ( str gadget -- )
  22     over empty?
  23     [ [ dupd user-input* ] each-parent ] unless
  24     2drop ;
  25
  26 ! Gesture objects
  27 TUPLE: motion ;             C: <motion> motion
  28 TUPLE: drag # ;             C: <drag> drag
  29 TUPLE: button-up mods # ;   C: <button-up> button-up
  30 TUPLE: button-down mods # ; C: <button-down> button-down
  31 TUPLE: mouse-scroll ;       C: <mouse-scroll> mouse-scroll
  32 TUPLE: mouse-enter ;        C: <mouse-enter> mouse-enter
  33 TUPLE: mouse-leave ;        C: <mouse-leave> mouse-leave
  34 TUPLE: lose-focus ;         C: <lose-focus> lose-focus
  35 TUPLE: gain-focus ;         C: <gain-focus> gain-focus
  36
  37 ! Higher-level actions
  38 TUPLE: cut-action ;         C: <cut-action> cut-action
  39 TUPLE: copy-action ;        C: <copy-action> copy-action
  40 TUPLE: paste-action ;       C: <paste-action> paste-action
  41 TUPLE: delete-action ;      C: <delete-action> delete-action
  42 TUPLE: select-all-action ;  C: <select-all-action> select-all-action
  43
  44 TUPLE: left-action ;        C: <left-action> left-action
  45 TUPLE: right-action ;       C: <right-action> right-action
  46 TUPLE: up-action ;          C: <up-action> up-action
  47 TUPLE: down-action ;        C: <down-action> down-action
  48
  49 TUPLE: zoom-in-action ;  C: <zoom-in-action> zoom-in-action
  50 TUPLE: zoom-out-action ; C: <zoom-out-action> zoom-out-action
  51
  52 : generalize-gesture ( gesture -- newgesture )
  53     clone f >># ;
  54
  55 ! Modifiers
  56 SYMBOLS: C+ A+ M+ S+ ;
  57
  58 TUPLE: key-down mods sym ;
  59
  60 : <key-gesture> ( mods sym action? class -- mods' sym' )
  61     >r [ S+ rot remove swap ] unless r> boa ; inline
  62
  63 : <key-down> ( mods sym action? -- key-down )
  64     key-down <key-gesture> ;
  65
  66 TUPLE: key-up mods sym ;
  67
  68 : <key-up> ( mods sym action? -- key-up )
  69     key-up <key-gesture> ;
  70
  71 ! Hand state
  72
  73 ! Note that these are only really useful inside an event
  74 ! handler, and that the locations hand-loc and hand-click-loc
  75 ! are in the co-ordinate system of the world which contains
  76 ! the gadget in question.
  77 SYMBOL: hand-gadget
  78 SYMBOL: hand-world
  79 SYMBOL: hand-loc
  80 { 0 0 } hand-loc set-global
  81
  82 SYMBOL: hand-clicked
  83 SYMBOL: hand-click-loc
  84 SYMBOL: hand-click#
  85 SYMBOL: hand-last-button
  86 SYMBOL: hand-last-time
  87 0 hand-last-button set-global
  88 0 hand-last-time set-global
  89
  90 SYMBOL: hand-buttons
  91 V{ } clone hand-buttons set-global
  92
  93 SYMBOL: scroll-direction
  94 { 0 0 } scroll-direction set-global
  95
  96 SYMBOL: double-click-timeout
  97 300 double-click-timeout set-global
  98
  99 : hand-moved? ( -- ? )
 100     hand-loc get hand-click-loc get = not ;
 101
 102 : button-gesture ( gesture -- )
 103     hand-clicked get-global 2dup send-gesture [
 104         >r generalize-gesture r> send-gesture drop
 105     ] [
 106         2drop
 107     ] if ;
 108
 109 : drag-gesture ( -- )
 110     hand-buttons get-global
 111     [ first <drag> button-gesture ] unless-empty ;
 112
 113 SYMBOL: drag-timer
 114
 115 <box> drag-timer set-global
 116
 117 : start-drag-timer ( -- )
 118     hand-buttons get-global empty? [
 119         [ drag-gesture ]
 120         300 milliseconds hence
 121         100 milliseconds
 122         add-alarm drag-timer get-global >box
 123     ] when ;
 124
 125 : stop-drag-timer ( -- )
 126     hand-buttons get-global empty? [
 127         drag-timer get-global ?box
 128         [ cancel-alarm ] [ drop ] if
 129     ] when ;
 130
 131 : fire-motion ( -- )
 132     hand-buttons get-global empty? [
 133         T{ motion } hand-gadget get-global send-gesture drop
 134     ] [
 135         drag-gesture
 136     ] if ;
 137
 138 : each-gesture ( gesture seq -- )
 139     [ handle-gesture drop ] with each ;
 140
 141 : hand-gestures ( new old -- )
 142     drop-prefix <reversed>
 143     T{ mouse-leave } swap each-gesture
 144     T{ mouse-enter } swap each-gesture ;
 145
 146 : forget-rollover ( -- )
 147     f hand-world set-global
 148     hand-gadget get-global >r
 149     f hand-gadget set-global
 150     f r> parents hand-gestures ;
 151
 152 : send-lose-focus ( gadget -- )
 153     T{ lose-focus } swap handle-gesture drop ;
 154
 155 : send-gain-focus ( gadget -- )
 156     T{ gain-focus } swap handle-gesture drop ;
 157
 158 : focus-child ( child gadget ? -- )
 159     [
 160         dup focus>> [
 161             dup send-lose-focus
 162             f swap t focus-child
 163         ] when*
 164         dupd (>>focus) [
 165             send-gain-focus
 166         ] when*
 167     ] [
 168         (>>focus)
 169     ] if ;
 170
 171 : modifier ( mod modifiers -- seq )
 172     [ second swap bitand 0 > ] with filter
 173     0 <column> prune [ f ] [ >array ] if-empty ;
 174
 175 : drag-loc ( -- loc )
 176     hand-loc get-global hand-click-loc get-global v- ;
 177
 178 : hand-rel ( gadget -- loc )
 179     hand-loc get-global swap screen-loc v- ;
 180
 181 : hand-click-rel ( gadget -- loc )
 182     hand-click-loc get-global swap screen-loc v- ;
 183
 184 : multi-click-timeout? ( -- ? )
 185     millis hand-last-time get - double-click-timeout get <= ;
 186
 187 : multi-click-button? ( button -- button ? )
 188     dup hand-last-button get = ;
 189
 190 : multi-click-position? ( -- ? )
 191     hand-loc get hand-click-loc get v- norm-sq 100 <= ;
 192
 193 : multi-click? ( button -- ? )
 194     {
 195         { [ multi-click-timeout?  not ] [ f ] }
 196         { [ multi-click-button?   not ] [ f ] }
 197         { [ multi-click-position? not ] [ f ] }
 198         { [ multi-click-position? not ] [ f ] }
 199         [ t ]
 200     } cond nip ;
 201
 202 : update-click# ( button -- )
 203     global [
 204         dup multi-click? [
 205             hand-click# inc
 206         ] [
 207             1 hand-click# set
 208         ] if
 209         hand-last-button set
 210         millis hand-last-time set
 211     ] bind ;
 212
 213 : update-clicked ( -- )
 214     hand-gadget get-global hand-clicked set-global
 215     hand-loc get-global hand-click-loc set-global ;
 216
 217 : under-hand ( -- seq )
 218     hand-gadget get-global parents <reversed> ;
 219
 220 : move-hand ( loc world -- )
 221     dup hand-world set-global
 222     under-hand >r over hand-loc set-global
 223     pick-up hand-gadget set-global
 224     under-hand r> hand-gestures ;
 225
 226 : send-button-down ( gesture loc world -- )
 227     move-hand
 228     start-drag-timer
 229     dup #>>
 230     dup update-click# hand-buttons get-global push
 231     update-clicked
 232     button-gesture ;
 233
 234 : send-button-up ( gesture loc world -- )
 235     move-hand
 236     dup #>> hand-buttons get-global delete
 237     stop-drag-timer
 238     button-gesture ;
 239
 240 : send-wheel ( direction loc world -- )
 241     move-hand
 242     scroll-direction set-global
 243     T{ mouse-scroll } hand-gadget get-global send-gesture
 244     drop ;
 245
 246 : world-focus ( world -- gadget )
 247     dup focus>> [ world-focus ] [ ] ?if ;
 248
 249 : send-action ( world gesture -- )
 250     swap world-focus send-gesture drop ;
 251
 252 GENERIC: gesture>string ( gesture -- string/f )
 253
 254 : modifiers>string ( modifiers -- string )
 255     [ name>> ] map concat >string ;
 256
 257 M: key-down gesture>string
 258     dup mods>> modifiers>string
 259     swap sym>> append ;
 260
 261 M: button-up gesture>string
 262     [
 263         dup mods>> modifiers>string %
 264         "Click Button" %
 265         #>> [ " " % # ] when*
 266     ] "" make ;
 267
 268 M: button-down gesture>string
 269     [
 270         dup mods>> modifiers>string %
 271         "Press Button" %
 272         #>> [ " " % # ] when*
 273     ] "" make ;
 274
 275 M: left-action gesture>string drop "Swipe left" ;
 276
 277 M: right-action gesture>string drop "Swipe right" ;
 278
 279 M: up-action gesture>string drop "Swipe up" ;
 280
 281 M: down-action gesture>string drop "Swipe down" ;
 282
 283 M: zoom-in-action gesture>string drop "Zoom in" ;
 284
 285 M: zoom-out-action gesture>string drop "Zoom out (pinch)" ;
 286
 287 M: object gesture>string drop f ;