extra/ui/gestures/gestures.factor

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