add 'wheel-left and 'wheel-right events
This commit is contained in:
Matthew Flatt
parent
cd9eb5a75c
commit
b0115ee360
|
|
@ -158,9 +158,19 @@
|
|||
(super-tell #:type _void otherMouseDragged: event))]
|
||||
|
||||
[-a _void (scrollWheel: [_id event])
|
||||
(unless (and (not (zero? (tell #:type _CGFloat event deltaY)))
|
||||
(do-key-event wxb event self #f #t))
|
||||
(super-tell #:type _void scrollWheel: event))]
|
||||
(let ([delta-y (tell #:type _CGFloat event deltaY)]
|
||||
[delta-x (tell #:type _CGFloat event deltaX)])
|
||||
(let ([evts (append (cond
|
||||
[(zero? delta-y) '()]
|
||||
[(positive? delta-y) '(wheel-up)]
|
||||
[else '(wheel-down)])
|
||||
(cond
|
||||
[(zero? delta-x) '()]
|
||||
[(positive? delta-x) '(wheel-left)]
|
||||
[else '(wheel-right)]))])
|
||||
(unless (and (pair? evts)
|
||||
(do-key-event wxb event self #f evts))
|
||||
(super-tell #:type _void scrollWheel: event))))]
|
||||
|
||||
[-a _void (keyDown: [_id event])
|
||||
(unless (do-key-event wxb event self #t #f)
|
||||
|
|
@ -281,7 +291,7 @@
|
|||
(when wx
|
||||
(send wx reset-cursor-rects)))])
|
||||
|
||||
(define (do-key-event wxb event self down? wheel?)
|
||||
(define (do-key-event wxb event self down? wheel)
|
||||
(let ([wx (->wx wxb)])
|
||||
(and
|
||||
wx
|
||||
|
|
@ -307,7 +317,7 @@
|
|||
[bit? (lambda (m b) (positive? (bitwise-and m b)))]
|
||||
[pos (tell #:type _NSPoint event locationInWindow)]
|
||||
[str (cond
|
||||
[wheel? #f]
|
||||
[wheel #f]
|
||||
[(unbox set-mark) ""] ; => dead key for composing characters
|
||||
[(unbox inserted-text)]
|
||||
[else
|
||||
|
|
@ -315,12 +325,8 @@
|
|||
[dead-key? (unbox set-mark)]
|
||||
[control? (bit? modifiers NSControlKeyMask)]
|
||||
[option? (bit? modifiers NSAlternateKeyMask)]
|
||||
[delta-y (and wheel?
|
||||
(tell #:type _CGFloat event deltaY))]
|
||||
[codes (cond
|
||||
[wheel? (if (positive? delta-y)
|
||||
'(wheel-up)
|
||||
'(wheel-down))]
|
||||
[wheel wheel]
|
||||
[had-saved-text? str]
|
||||
[(map-key-code (tell #:type _ushort event keyCode))
|
||||
=> list]
|
||||
|
|
@ -349,7 +355,7 @@
|
|||
[y (->long y)]
|
||||
[time-stamp (->long (* (tell #:type _double event timestamp) 1000.0))]
|
||||
[caps-down (bit? modifiers NSAlphaShiftKeyMask)])])
|
||||
(unless wheel?
|
||||
(unless wheel
|
||||
(let ([alt-str (tell #:type _NSString event charactersIgnoringModifiers)])
|
||||
(when (and (string? alt-str)
|
||||
(= 1 (string-length alt-str)))
|
||||
|
|
|
|||
|
|
@ -178,10 +178,7 @@
|
|||
(define-signal-handler connect-scroll "scroll-event"
|
||||
(_fun _GtkWidget _GdkEventScroll-pointer -> _gboolean)
|
||||
(lambda (gtk event)
|
||||
(and (member (GdkEventScroll-direction event)
|
||||
(list GDK_SCROLL_UP
|
||||
GDK_SCROLL_DOWN))
|
||||
(do-key-event gtk event #f #t))))
|
||||
(do-key-event gtk event #f #t)))
|
||||
|
||||
(define (do-key-event gtk event down? scroll?)
|
||||
(let ([wx (gtk->wx gtk)])
|
||||
|
|
@ -204,10 +201,12 @@
|
|||
(map-key-code kv)
|
||||
(integer->char (gdk_keyval_to_unicode kv))))]
|
||||
[key-code (if scroll?
|
||||
(if (= (GdkEventScroll-direction event)
|
||||
GDK_SCROLL_UP)
|
||||
'wheel-up
|
||||
'wheel-down)
|
||||
(let ([dir (GdkEventScroll-direction event)])
|
||||
(cond
|
||||
[(= dir GDK_SCROLL_UP) 'wheel-up]
|
||||
[(= dir GDK_SCROLL_DOWN) 'wheel-down]
|
||||
[(= dir GDK_SCROLL_LEFT) 'wheel-left]
|
||||
[(= dir GDK_SCROLL_RIGHT) 'wheel-right]))
|
||||
(keyval->code (GdkEventKey-keyval event)))]
|
||||
[k (new key-event%
|
||||
[key-code (if (and (string? im-str)
|
||||
|
|
|
|||
|
|
@ -191,14 +191,18 @@
|
|||
[(= msg WM_CHAR)
|
||||
(do-key w msg wParam lParam #t #f default)]
|
||||
[(= msg WM_MOUSEWHEEL)
|
||||
(let ([orig-delta (quotient (HIWORD wParam) WHEEL_DELTA)])
|
||||
(let loop ([delta (abs orig-delta)])
|
||||
(unless (zero? delta)
|
||||
(do-key w msg (if (negative? orig-delta)
|
||||
'wheel-down
|
||||
'wheel-up)
|
||||
lParam #f #f void)
|
||||
(loop (sub1 delta)))))
|
||||
(let ([gen-wheels
|
||||
(lambda (val down up)
|
||||
(let ([orig-delta (quotient val WHEEL_DELTA)])
|
||||
(let loop ([delta (abs orig-delta)])
|
||||
(unless (zero? delta)
|
||||
(do-key w msg (if (negative? orig-delta)
|
||||
down
|
||||
up)
|
||||
lParam #f #f void)
|
||||
(loop (sub1 delta))))))])
|
||||
(gen-wheels (HIWORD wParam) 'wheel-down 'wheel-up)
|
||||
(gen-wheels (LOWORD wParam) 'wheel-left 'wheel-right))
|
||||
0]
|
||||
[(= msg WM_COMMAND)
|
||||
(let* ([control-hwnd (cast lParam _LPARAM _HWND)]
|
||||
|
|
|
|||
|
|
@ -458,6 +458,20 @@
|
|||
1)))
|
||||
0)])
|
||||
(do-scroll x y #t x old-y))))]
|
||||
[(wheel-left wheel-right)
|
||||
(when (and allow-x-scroll?
|
||||
(not fake-x-scroll?))
|
||||
(let-boxes ([x 0]
|
||||
[y 0])
|
||||
(get-scroll x y)
|
||||
(let ([old-x x]
|
||||
[x (max (+ x
|
||||
(* wheel-amt
|
||||
(if (eq? code 'wheel-left)
|
||||
-1
|
||||
1)))
|
||||
0)])
|
||||
(do-scroll x y #t old-x y))))]
|
||||
[else
|
||||
(when (and media (not (send media get-printing)))
|
||||
(using-admin
|
||||
|
|
|
|||
|
|
@ -38,6 +38,8 @@
|
|||
("middlebuttonseq" . mouse-middle)
|
||||
("wheelup" . wheel-up)
|
||||
("wheeldown" . wheel-down)
|
||||
("wheelleft" . wheel-left)
|
||||
("wheelright" . wheel-right)
|
||||
("esc" . escape)
|
||||
("delete" . #\rubout)
|
||||
("del" . #\rubout)
|
||||
|
|
|
|||
|
|
@ -136,6 +136,8 @@ Gets the virtual key code for the key event. The virtual key code is
|
|||
@item{@indexed-scheme['scroll]}
|
||||
@item{@indexed-scheme['wheel-up] --- @index["wheel on mouse"]{mouse} wheel up one notch}
|
||||
@item{@indexed-scheme['wheel-down] --- mouse wheel down one notch}
|
||||
@item{@indexed-scheme['wheel-left] --- mouse wheel left one notch}
|
||||
@item{@indexed-scheme['wheel-right] --- mouse wheel right one notch}
|
||||
@item{@indexed-scheme['release] --- indicates a key-release event}
|
||||
@item{@indexed-scheme['press] --- indicates a key-press event; usually only from @scheme[get-key-release-code]}
|
||||
]
|
||||
|
|
@ -164,10 +166,11 @@ The special key symbols attempt to capture useful keys that have no
|
|||
If a suitable special key symbol or ASCII representation is not
|
||||
available, @scheme[#\nul] (the NUL character) is reported.
|
||||
|
||||
A @scheme['wheel-up] or @scheme['wheel-down] event may be sent to a
|
||||
window other than the one with the keyboard focus, because some
|
||||
platforms generate wheel events based on the location of the mouse
|
||||
pointer instead of the keyboard focus.
|
||||
A @scheme['wheel-up], @scheme['wheel-down], @scheme['wheel-left], or
|
||||
@scheme['wheel-right] event may be sent to a window other than the
|
||||
one with the keyboard focus, because some platforms generate wheel
|
||||
events based on the location of the mouse pointer instead of the
|
||||
keyboard focus.
|
||||
|
||||
Under Windows, when the Control key is pressed without Alt, the key
|
||||
code for ASCII characters is downcased, roughly cancelling the effect
|
||||
|
|
|
|||
|
|
@ -210,6 +210,8 @@ A key identifier can be either a character on the keyboard (e.g.,
|
|||
@item{@litchar{middlebuttonseq}}
|
||||
@item{@litchar{wheelup}}
|
||||
@item{@litchar{wheeldown}}
|
||||
@item{@litchar{wheelleft}}
|
||||
@item{@litchar{wheelright}}
|
||||
@item{@litchar{esc}}
|
||||
@item{@litchar{delete}}
|
||||
@item{@litchar{del} (same as @litchar{delete})}
|
||||
|
|
|
|||
|
|
@ -1,3 +1,6 @@
|
|||
Version 5.1.0.5
|
||||
racket/gui: added 'wheel-left and 'wheel-right events
|
||||
|
||||
Version 5.1.0.4
|
||||
Change file-or-directory-permission to add 'bits mode
|
||||
and permission-setting mode
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user