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

fix mouse position conversion and canvas moving

Browse Source
This commit is contained in:
Matthew Flatt 2010-07-22 09:16:05 -05:00
parent 3b1b989ccc
commit 75189fbdee
4 changed files with 94 additions and 48 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
collects/mred/private/wx/cocoa/canvas.rkt
View File

@ -66,7 +66,8 @@
get-client-size get-client-size
is-shown-to-root? is-shown-to-root?
move get-x get-y move get-x get-y
on-size) on-size
register-as-child)
(define vscroll-ok? (and (memq 'vscroll style) #t)) (define vscroll-ok? (and (memq 'vscroll style) #t))
(define vscroll? vscroll-ok?) (define vscroll? vscroll-ok?)
@ -120,6 +121,9 @@
(get-client-size xb yb) (get-client-size xb yb)
(send dc reset-bounds (NSPoint-x p) (NSPoint-y p) (unbox xb) (unbox 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/public (on-paint) (void))
(define/override (set-size x y w h) (define/override (set-size x y w h)

2
collects/mred/private/wx/cocoa/frame.rkt
View File

@ -145,6 +145,8 @@
(define/override (is-parent-enabled-to-root?) (define/override (is-parent-enabled-to-root?)
#t) #t)
(define/override (is-view?) #f)
(define/public (flip-screen y) (define/public (flip-screen y)
(let ([f (tell #:type _NSRect (tell cocoa screen) frame)]) (let ([f (tell #:type _NSRect (tell cocoa screen) frame)])
(- (NSSize-height (NSRect-size f)) y))) (- (NSSize-height (NSRect-size f)) y)))

23
collects/mred/private/wx/cocoa/panel.rkt
View File

@ -31,6 +31,28 @@
x y w h x y w h
style style
label) 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] (super-new [parent parent]
[cocoa [cocoa
@ -39,4 +61,3 @@
initWithFrame: #:type _NSRect (make-NSRect (make-NSPoint x y) initWithFrame: #:type _NSRect (make-NSRect (make-NSPoint x y)
(make-NSSize w h))))] (make-NSSize w h))))]
[no-show? (memq 'deleted style)])) [no-show? (memq 'deleted style)]))

111
collects/mred/private/wx/cocoa/window.rkt
View File

@ -89,55 +89,57 @@
(let* ([modifiers (tell #:type _NSUInteger event modifierFlags)] (let* ([modifiers (tell #:type _NSUInteger event modifierFlags)]
[bit? (lambda (m b) (positive? (bitwise-and m b)))] [bit? (lambda (m b) (positive? (bitwise-and m b)))]
[pos (tell #:type _NSPoint event locationInWindow)] [pos (tell #:type _NSPoint event locationInWindow)]
[str (tell #:type _NSString event characters)] [str (tell #:type _NSString event characters)])
[k (new key-event% (let-values ([(x y) (send wx window-point-to-view pos)])
[key-code (or (let ([k (new key-event%
(map-key-code (tell #:type _ushort event keyCode)) [key-code (or
(if (string=? "" str) (map-key-code (tell #:type _ushort event keyCode))
#\nul (if (string=? "" str)
(string-ref str 0)))] #\nul
[shift-down (bit? modifiers NSShiftKeyMask)] (string-ref str 0)))]
[control-down (bit? modifiers NSControlKeyMask)] [shift-down (bit? modifiers NSShiftKeyMask)]
[meta-down (bit? modifiers NSCommandKeyMask)] [control-down (bit? modifiers NSControlKeyMask)]
[alt-down (bit? modifiers NSAlternateKeyMask)] [meta-down (bit? modifiers NSCommandKeyMask)]
[x (NSPoint-x pos)] [alt-down (bit? modifiers NSAlternateKeyMask)]
[y (NSPoint-y pos)] [x (->long x)]
[time-stamp (->long (* (tell #:type _double event timestamp) 1000.0))] [y (->long y)]
[caps-down (bit? modifiers NSAlphaShiftKeyMask)])]) [time-stamp (->long (* (tell #:type _double event timestamp) 1000.0))]
(if (send wx wants-all-events?) [caps-down (bit? modifiers NSAlphaShiftKeyMask)])])
(begin (if (send wx wants-all-events?)
(queue-window-event wx (lambda () (begin
(send wx dispatch-on-char k #f))) (queue-window-event wx (lambda ()
#t) (send wx dispatch-on-char k #f)))
(constrained-reply (send wx get-eventspace) #t)
(lambda () (send wx dispatch-on-char k #t)) (constrained-reply (send wx get-eventspace)
#t)))) (lambda () (send wx dispatch-on-char k #t))
#t))))))
(define (do-mouse-event wx event kind l? m? r?) (define (do-mouse-event wx event kind l? m? r?)
(let* ([modifiers (tell #:type _NSUInteger event modifierFlags)] (let* ([modifiers (tell #:type _NSUInteger event modifierFlags)]
[bit? (lambda (m b) (positive? (bitwise-and m b)))] [bit? (lambda (m b) (positive? (bitwise-and m b)))]
[pos (tell #:type _NSPoint event locationInWindow)] [pos (tell #:type _NSPoint event locationInWindow)])
[m (new mouse-event% (let-values ([(x y) (send wx window-point-to-view pos)])
[event-type kind] (let ([m (new mouse-event%
[left-down l?] [event-type kind]
[middle-down m?] [left-down l?]
[right-down r?] [middle-down m?]
[x (->long (NSPoint-x pos))] [right-down r?]
[y (->long (send wx flip-client (NSPoint-y pos)))] [x (->long x)]
[shift-down (bit? modifiers NSShiftKeyMask)] [y (->long y)]
[control-down (bit? modifiers NSControlKeyMask)] [shift-down (bit? modifiers NSShiftKeyMask)]
[meta-down (bit? modifiers NSCommandKeyMask)] [control-down (bit? modifiers NSControlKeyMask)]
[alt-down (bit? modifiers NSAlternateKeyMask)] [meta-down (bit? modifiers NSCommandKeyMask)]
[time-stamp (->long (* (tell #:type _double event timestamp) 1000.0))] [alt-down (bit? modifiers NSAlternateKeyMask)]
[caps-down (bit? modifiers NSAlphaShiftKeyMask)])]) [time-stamp (->long (* (tell #:type _double event timestamp) 1000.0))]
(if (send wx wants-all-events?) [caps-down (bit? modifiers NSAlphaShiftKeyMask)])])
(begin (if (send wx wants-all-events?)
(queue-window-event wx (lambda () (begin
(send wx dispatch-on-event m #f))) (queue-window-event wx (lambda ()
#t) (send wx dispatch-on-event m #f)))
(constrained-reply (send wx get-eventspace) #t)
(lambda () (send wx dispatch-on-event m #t)) (constrained-reply (send wx get-eventspace)
#t)))) (lambda () (send wx dispatch-on-event m #t))
#t))))))
(define window% (define window%
(class object% (class object%
@ -173,7 +175,14 @@
(define/public (show on?) (define/public (show on?)
(if on? (if on?
(tellv (send parent get-cocoa-content) addSubview: cocoa) (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?) (define/public (is-shown?)
(and (tell cocoa superview) #t)) (and (tell cocoa superview) #t))
@ -210,6 +219,16 @@
(- y (client-y-offset)))))) (- y (client-y-offset))))))
(define/public (client-y-offset) 0) (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) (define/public (get-x)
(->long (NSPoint-x (NSRect-origin (get-frame))))) (->long (NSPoint-x (NSRect-origin (get-frame)))))
(define/public (get-y) (define/public (get-y)