suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

racket/gui: add `get-current-mouse-state'

Browse Source
This commit is contained in:
Matthew Flatt 2012-11-07 14:23:09 -07:00
parent d15059ada7
commit 7b04571fac
12 changed files with 127 additions and 3 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
collects/mred/mred-sig.rkt
View File

@ -78,6 +78,7 @@ frame%
gauge%
get-choices-from-user
get-color-from-user
get-current-mouse-state
get-default-shortcut-prefix
get-directory
get-display-count

1
collects/mred/private/mred.rkt
View File

@ -116,6 +116,7 @@
event-dispatch-handler
eventspace?
flush-display
get-current-mouse-state
get-highlight-background-color
get-highlight-text-color
get-the-editor-data-class-list

1
collects/mred/private/wx/cocoa/platform.rkt
View File

@ -63,6 +63,7 @@
display-origin
display-count
flush-display
get-current-mouse-state
fill-private-color
cancel-quit
get-control-font-face

31
collects/mred/private/wx/cocoa/procs.rkt
View File

@ -6,6 +6,7 @@
ffi/unsafe
ffi/unsafe/objc
"utils.rkt"
"const.rkt"
"types.rkt"
"frame.rkt"
"window.rkt"
@ -63,9 +64,10 @@
file-creator-and-type
file-selector
key-symbol-to-menu-key
needs-grow-box-spacer?)
needs-grow-box-spacer?
get-current-mouse-state)
(import-class NSScreen NSCursor NSMenu)
(import-class NSScreen NSCursor NSMenu NSEvent)
(define (find-graphical-system-path what)
#f)
@ -192,3 +194,28 @@
(define (needs-grow-box-spacer?)
(not (version-10.7-or-later?)))
;; ------------------------------------------------------------
;; Mouse and modifier-key state
(define (get-current-mouse-state)
(define posn (tell #:type _NSPoint NSEvent mouseLocation))
(define buttons (tell #:type _NSUInteger NSEvent pressedMouseButtons))
(define mods (tell #:type _NSUInteger NSEvent modifierFlags))
(define (maybe v mask sym)
(if (zero? (bitwise-and v mask))
null
(list sym)))
(define h (let ([f (tell #:type _NSRect (tell NSScreen mainScreen) frame)])
(NSSize-height (NSRect-size f))))
(values (make-object point%
(->long (NSPoint-x posn))
(->long (- (- h (NSPoint-y posn)) (get-menu-bar-height))))
(append
(maybe buttons #x1 'left)
(maybe buttons #x2 'right)
(maybe mods NSShiftKeyMask 'shift)
(maybe mods NSCommandKeyMask 'meta)
(maybe mods NSAlternateKeyMask 'alt)
(maybe mods NSControlKeyMask 'control)
(maybe mods NSAlphaShiftKeyMask 'caps))))

31
collects/mred/private/wx/gtk/frame.rkt
View File

@ -22,7 +22,8 @@
display-origin
display-size
display-count
location->window))
location->window
get-current-mouse-state))
;; ----------------------------------------
@ -57,6 +58,13 @@
(define-gtk gtk_window_resize (_fun _GtkWidget _int _int -> _void))
(define-gdk gdk_window_set_cursor (_fun _GdkWindow _pointer -> _void))
(define-gdk gdk_screen_get_root_window (_fun _GdkScreen -> _GdkWindow))
(define-gdk gdk_window_get_pointer (_fun _GdkWindow
(x : (_ptr o _int))
(y : (_ptr o _int))
(mods : (_ptr o _uint))
-> _GdkWindow
-> (values x y mods)))
(define-gtk gtk_window_iconify (_fun _GtkWindow -> _void))
(define-gtk gtk_window_deiconify (_fun _GtkWindow -> _void))
@ -543,3 +551,24 @@
[fh (send f get-height)])
(<= fy y (+ fy fh)))
f))))
;; ----------------------------------------
(define (get-current-mouse-state)
(define-values (x y mods) (gdk_window_get_pointer
(gdk_screen_get_root_window
(gdk_screen_get_default))))
(define (maybe mask sym)
(if (zero? (bitwise-and mods mask))
null
(list sym)))
(values (make-object point% x y)
(append
(maybe GDK_BUTTON1_MASK 'left)
(maybe GDK_BUTTON2_MASK 'middle)
(maybe GDK_BUTTON3_MASK 'right)
(maybe GDK_SHIFT_MASK 'shift)
(maybe GDK_LOCK_MASK 'caps)
(maybe GDK_CONTROL_MASK 'control)
(maybe GDK_MOD1_MASK 'alt)
(maybe GDK_META_MASK 'meta))))

1
collects/mred/private/wx/gtk/platform.rkt
View File

@ -64,6 +64,7 @@
display-origin
display-count
flush-display
get-current-mouse-state
fill-private-color
cancel-quit
get-control-font-face

1
collects/mred/private/wx/platform.rkt
View File

@ -50,6 +50,7 @@
display-origin
display-count
flush-display
get-current-mouse-state
fill-private-color
cancel-quit
get-control-font-face

1
collects/mred/private/wx/win32/platform.rkt
View File

@ -64,6 +64,7 @@
display-origin
display-count
flush-display
get-current-mouse-state
fill-private-color
cancel-quit
get-control-font-face

24
collects/mred/private/wx/win32/procs.rkt
View File

@ -43,6 +43,7 @@
get-highlight-text-color
check-for-break)
flush-display
get-current-mouse-state
fill-private-color
play-sound
location->window
@ -116,3 +117,26 @@
(define (check-for-break) #f)
(define (needs-grow-box-spacer?) #f)
(define-user32 GetCursorPos (_wfun (p : (_ptr o _POINT)) -> (r : _BOOL)
-> (if r
p
(failed 'GetCursorPos))))
(define-user32 GetAsyncKeyState (_wfun _int -> _SHORT))
(define-user32 GetSystemMetrics (_wfun _int -> _int))
(define SM_SWAPBUTTON 23)
(define (get-current-mouse-state)
(define p (GetCursorPos))
(define (maybe vk sym)
(if (negative? (GetAsyncKeyState vk))
(list sym)
null))
(define swapped? (not (zero? (GetSystemMetrics SM_SWAPBUTTON))))
(values (make-object point% (POINT-x p) (POINT-y p))
(append
(maybe (if swapped? VK_RBUTTON VK_LBUTTON) 'left)
(maybe (if swapped? VK_LBUTTON VK_RBUTTON) 'right)
(maybe VK_LSHIFT 'shift)
(maybe VK_CONTROL 'control)
(maybe VK_MENU 'alt)
(maybe VK_CAPITAL 'caps))))

9
collects/scribblings/gui/miscwin-funcs.scrbl
View File

@ -194,6 +194,15 @@ break is sent (via @racket[break-thread]) to the created eventspace's
@tech{handler thread}.}
@defproc[(get-current-mouse-state) (values (is-a?/c point%)
(listof (or/c 'left 'middle 'right
'shift 'control 'alt 'meta 'caps)))]{
Returns the current location of the mouse in screen coordinates,
and returns a list of symbols for mouse buttons and modifier keys
that are currently pressed.}
@defproc[(hide-cursor-until-moved) void?]{
Hides the cursor until the user moves the mouse or clicks the mouse

26
collects/tests/gracket/item.rkt
View File

@ -2289,6 +2289,30 @@
'(arrow bullseye cross hand ibeam watch blank size-n/s size-e/w size-ne/sw size-nw/se))
(send f show #t))
;----------------------------------------------------------------------
(define (mouse)
(define f (new frame%
[label "Mouse"]
[width 300]
[height 200]))
(define m (new message%
[parent f]
[label ""]
[stretchable-width #t]))
(send f show #t)
(thread (lambda ()
(let loop ()
(when (send f is-shown?)
(sleep 0.1)
(define-values (pos keys) (get-current-mouse-state))
(queue-callback
(lambda () (send m set-label
(format "~a,~a ~a"
(send pos get-x)
(send pos get-y)
keys))))
(loop))))))
;----------------------------------------------------------------------
@ -2370,6 +2394,8 @@
(make-object vertical-pane% crp) ; filler
(make-object button% "Cursors" crp (lambda (b e) (cursors)))
(make-object vertical-pane% crp) ; filler
(make-object button% "Mouse" crp (lambda (b e) (mouse)))
(make-object vertical-pane% crp) ; filler
(make-object button% "Make Radiobox Frame" crp (lambda (b e) (radiobox-frame)))
(define cp (make-object horizontal-pane% ap))
(send cp stretchable-width #f)

3
doc/release-notes/racket/HISTORY.txt
View File

@ -1,3 +1,6 @@
Version 5.3.1.5
racket/gui: added get-current-mouse-state
Version 5.3.1.2
compiler/zo-structs: added a constantness field to module-variable