From 75189fbdee90336e6a8b6f6c99f7d783eede407a Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 22 Jul 2010 09:16:05 -0500 Subject: [PATCH] fix mouse position conversion and canvas moving --- collects/mred/private/wx/cocoa/canvas.rkt | 6 +- collects/mred/private/wx/cocoa/frame.rkt | 2 + collects/mred/private/wx/cocoa/panel.rkt | 23 ++++- collects/mred/private/wx/cocoa/window.rkt | 111 +++++++++++++--------- 4 files changed, 94 insertions(+), 48 deletions(-) diff --git a/collects/mred/private/wx/cocoa/canvas.rkt b/collects/mred/private/wx/cocoa/canvas.rkt index 573080510f..2cc2f000dc 100644 --- a/collects/mred/private/wx/cocoa/canvas.rkt +++ b/collects/mred/private/wx/cocoa/canvas.rkt @@ -66,7 +66,8 @@ get-client-size is-shown-to-root? move get-x get-y - on-size) + on-size + register-as-child) (define vscroll-ok? (and (memq 'vscroll style) #t)) (define vscroll? vscroll-ok?) @@ -120,6 +121,9 @@ (get-client-size xb yb) (send dc reset-bounds (NSPoint-x p) (NSPoint-y p) (unbox xb) (unbox yb)))) + (define/override (maybe-register-as-child parent on?) + (register-as-child parent on?)) + (define/public (on-paint) (void)) (define/override (set-size x y w h) diff --git a/collects/mred/private/wx/cocoa/frame.rkt b/collects/mred/private/wx/cocoa/frame.rkt index 4dc7edf4f4..3901d82db1 100644 --- a/collects/mred/private/wx/cocoa/frame.rkt +++ b/collects/mred/private/wx/cocoa/frame.rkt @@ -145,6 +145,8 @@ (define/override (is-parent-enabled-to-root?) #t) + (define/override (is-view?) #f) + (define/public (flip-screen y) (let ([f (tell #:type _NSRect (tell cocoa screen) frame)]) (- (NSSize-height (NSRect-size f)) y))) diff --git a/collects/mred/private/wx/cocoa/panel.rkt b/collects/mred/private/wx/cocoa/panel.rkt index 097df99f7a..1906ceea9b 100644 --- a/collects/mred/private/wx/cocoa/panel.rkt +++ b/collects/mred/private/wx/cocoa/panel.rkt @@ -31,6 +31,28 @@ x y w h style label) + (inherit register-as-child) + + (define children null) + + (define/public (fix-dc) + (for ([child (in-list children)]) + (send child fix-dc))) + + (define/override (set-size x y w h) + (super set-size x y w h) + (fix-dc)) + + (define/override (maybe-register-as-child parent on?) + (register-as-child parent on?)) + + (define/override (register-child child on?) + (let ([now-on? (and (memq child children) #t)]) + (unless (eq? on? now-on?) + (set! children + (if on? + (cons child children) + (remq child children)))))) (super-new [parent parent] [cocoa @@ -39,4 +61,3 @@ initWithFrame: #:type _NSRect (make-NSRect (make-NSPoint x y) (make-NSSize w h))))] [no-show? (memq 'deleted style)])) - diff --git a/collects/mred/private/wx/cocoa/window.rkt b/collects/mred/private/wx/cocoa/window.rkt index e11beb0591..07802b391d 100644 --- a/collects/mred/private/wx/cocoa/window.rkt +++ b/collects/mred/private/wx/cocoa/window.rkt @@ -89,55 +89,57 @@ (let* ([modifiers (tell #:type _NSUInteger event modifierFlags)] [bit? (lambda (m b) (positive? (bitwise-and m b)))] [pos (tell #:type _NSPoint event locationInWindow)] - [str (tell #:type _NSString event characters)] - [k (new key-event% - [key-code (or - (map-key-code (tell #:type _ushort event keyCode)) - (if (string=? "" str) - #\nul - (string-ref str 0)))] - [shift-down (bit? modifiers NSShiftKeyMask)] - [control-down (bit? modifiers NSControlKeyMask)] - [meta-down (bit? modifiers NSCommandKeyMask)] - [alt-down (bit? modifiers NSAlternateKeyMask)] - [x (NSPoint-x pos)] - [y (NSPoint-y pos)] - [time-stamp (->long (* (tell #:type _double event timestamp) 1000.0))] - [caps-down (bit? modifiers NSAlphaShiftKeyMask)])]) - (if (send wx wants-all-events?) - (begin - (queue-window-event wx (lambda () - (send wx dispatch-on-char k #f))) - #t) - (constrained-reply (send wx get-eventspace) - (lambda () (send wx dispatch-on-char k #t)) - #t)))) + [str (tell #:type _NSString event characters)]) + (let-values ([(x y) (send wx window-point-to-view pos)]) + (let ([k (new key-event% + [key-code (or + (map-key-code (tell #:type _ushort event keyCode)) + (if (string=? "" str) + #\nul + (string-ref str 0)))] + [shift-down (bit? modifiers NSShiftKeyMask)] + [control-down (bit? modifiers NSControlKeyMask)] + [meta-down (bit? modifiers NSCommandKeyMask)] + [alt-down (bit? modifiers NSAlternateKeyMask)] + [x (->long x)] + [y (->long y)] + [time-stamp (->long (* (tell #:type _double event timestamp) 1000.0))] + [caps-down (bit? modifiers NSAlphaShiftKeyMask)])]) + (if (send wx wants-all-events?) + (begin + (queue-window-event wx (lambda () + (send wx dispatch-on-char k #f))) + #t) + (constrained-reply (send wx get-eventspace) + (lambda () (send wx dispatch-on-char k #t)) + #t)))))) (define (do-mouse-event wx event kind l? m? r?) (let* ([modifiers (tell #:type _NSUInteger event modifierFlags)] [bit? (lambda (m b) (positive? (bitwise-and m b)))] - [pos (tell #:type _NSPoint event locationInWindow)] - [m (new mouse-event% - [event-type kind] - [left-down l?] - [middle-down m?] - [right-down r?] - [x (->long (NSPoint-x pos))] - [y (->long (send wx flip-client (NSPoint-y pos)))] - [shift-down (bit? modifiers NSShiftKeyMask)] - [control-down (bit? modifiers NSControlKeyMask)] - [meta-down (bit? modifiers NSCommandKeyMask)] - [alt-down (bit? modifiers NSAlternateKeyMask)] - [time-stamp (->long (* (tell #:type _double event timestamp) 1000.0))] - [caps-down (bit? modifiers NSAlphaShiftKeyMask)])]) - (if (send wx wants-all-events?) - (begin - (queue-window-event wx (lambda () - (send wx dispatch-on-event m #f))) - #t) - (constrained-reply (send wx get-eventspace) - (lambda () (send wx dispatch-on-event m #t)) - #t)))) + [pos (tell #:type _NSPoint event locationInWindow)]) + (let-values ([(x y) (send wx window-point-to-view pos)]) + (let ([m (new mouse-event% + [event-type kind] + [left-down l?] + [middle-down m?] + [right-down r?] + [x (->long x)] + [y (->long y)] + [shift-down (bit? modifiers NSShiftKeyMask)] + [control-down (bit? modifiers NSControlKeyMask)] + [meta-down (bit? modifiers NSCommandKeyMask)] + [alt-down (bit? modifiers NSAlternateKeyMask)] + [time-stamp (->long (* (tell #:type _double event timestamp) 1000.0))] + [caps-down (bit? modifiers NSAlphaShiftKeyMask)])]) + (if (send wx wants-all-events?) + (begin + (queue-window-event wx (lambda () + (send wx dispatch-on-event m #f))) + #t) + (constrained-reply (send wx get-eventspace) + (lambda () (send wx dispatch-on-event m #t)) + #t)))))) (define window% (class object% @@ -173,7 +175,14 @@ (define/public (show on?) (if on? (tellv (send parent get-cocoa-content) addSubview: cocoa) - (tellv cocoa removeFromSuperview))) + (tellv cocoa removeFromSuperview)) + (maybe-register-as-child parent on?)) + (define/public (maybe-register-as-child parent on?) + (void)) + (define/public (register-as-child parent on?) + (send parent register-child this on?)) + (define/public (register-child child on?) + (void)) (define/public (is-shown?) (and (tell cocoa superview) #t)) @@ -210,6 +219,16 @@ (- y (client-y-offset)))))) (define/public (client-y-offset) 0) + (define/public (is-view?) #t) + (define/public (window-point-to-view pos) + (let ([pos (if (is-view?) + (tell #:type _NSPoint (get-cocoa-content) + convertPoint: #:type _NSPoint pos + fromView: #f) + pos)]) + (values (NSPoint-x pos) + (flip-client (NSPoint-y pos))))) + (define/public (get-x) (->long (NSPoint-x (NSRect-origin (get-frame))))) (define/public (get-y)