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
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)

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

@ -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)))

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

@ -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)]))

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

@ -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)