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

win32: canvas autoscroll

Browse Source
This commit is contained in:
Matthew Flatt 2010-10-10 08:54:19 -06:00
parent 682355def4
commit b459fcf91c
3 changed files with 104 additions and 59 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -193,7 +193,6 @@
set-auto-size set-auto-size
adjust-client-delta infer-client-delta adjust-client-delta infer-client-delta
is-auto-scroll? get-virtual-width get-virtual-height is-auto-scroll? get-virtual-width get-virtual-height
reset-auto-scroll
refresh-for-autoscroll) refresh-for-autoscroll)
(define is-combo? (memq 'combo style)) (define is-combo? (memq 'combo style))

92
collects/mred/private/wx/win32/canvas.rkt
View File

@ -37,6 +37,9 @@
(define ETS_NORMAL 1) (define ETS_NORMAL 1)
(define ETS_DISABLE 4) (define ETS_DISABLE 4)
(define HTHSCROLL 6)
(define HTVSCROLL 7)
(define-cstruct _SCROLLINFO (define-cstruct _SCROLLINFO
([cbSize _UINT] ([cbSize _UINT]
[fMask _UINT] [fMask _UINT]
@ -61,7 +64,7 @@
(define canvas% (define canvas%
(canvas-mixin (canvas-mixin
(class (item-mixin window%) (class (canvas-autoscroll-mixin (item-mixin window%))
(init parent (init parent
x y w h x y w h
style style
@ -72,7 +75,10 @@
get-client-size get-client-size
get-eventspace get-eventspace
set-control-font set-control-font
subclass-control) subclass-control
is-auto-scroll? get-virtual-width get-virtual-height
reset-auto-scroll
refresh-for-autoscroll)
(define hscroll? (memq 'hscroll style)) (define hscroll? (memq 'hscroll style))
(define vscroll? (memq 'vscroll style)) (define vscroll? (memq 'vscroll style))
@ -182,7 +188,17 @@
(define/public (get-dc) dc) (define/public (get-dc) dc)
(define/override (on-resized) (define/override (on-resized)
(send dc reset-backing-retained)) (reset-dc))
(define/private (reset-dc)
(send dc reset-backing-retained)
(send dc set-auto-scroll
(if (get-virtual-width)
(get-virtual-h-pos)
0)
(if (get-virtual-height)
(get-virtual-v-pos)
0)))
(define/override (get-client-hwnd) (define/override (get-client-hwnd)
canvas-hwnd) canvas-hwnd)
@ -232,9 +248,6 @@
(unless (zero? paint-suspended) (unless (zero? paint-suspended)
(set! paint-suspended (sub1 paint-suspended))))) (set! paint-suspended (sub1 paint-suspended)))))
(define/public (get-virtual-size w h)
(get-client-size w h))
(define transparent? (memq 'transparent style)) (define transparent? (memq 'transparent style))
(define bg-col (make-object color% "white")) (define bg-col (make-object color% "white"))
(define/public (get-canvas-background) (if transparent? (define/public (get-canvas-background) (if transparent?
@ -254,11 +267,10 @@
(set! v-scroll-visible? (and v? #t)) (set! v-scroll-visible? (and v? #t))
(ShowScrollBar canvas-hwnd SB_VERT v?)))) (ShowScrollBar canvas-hwnd SB_VERT v?))))
(define/public (set-scrollbars h-step v-step (define/override (do-set-scrollbars h-step v-step
h-len v-len h-len v-len
h-page v-page h-page v-page
h-pos v-pos h-pos v-pos)
auto?)
(define (make-info len page pos vis?) (define (make-info len page pos vis?)
(make-SCROLLINFO (ctype-sizeof _SCROLLINFO) (make-SCROLLINFO (ctype-sizeof _SCROLLINFO)
(bitwise-ior (if vis? SIF_DISABLENOSCROLL 0) (bitwise-ior (if vis? SIF_DISABLENOSCROLL 0)
@ -271,6 +283,15 @@
(when vscroll? (when vscroll?
(SetScrollInfo canvas-hwnd SB_VERT (make-info v-len v-page v-pos v-scroll-visible?) #t))) (SetScrollInfo canvas-hwnd SB_VERT (make-info v-len v-page v-pos v-scroll-visible?) #t)))
(define/override (reset-dc-for-autoscroll)
(reset-dc)
(refresh))
(define/override (get-virtual-h-pos)
(GetScrollPos canvas-hwnd SB_HORZ))
(define/override (get-virtual-v-pos)
(GetScrollPos canvas-hwnd SB_VERT))
(def/public-unimplemented set-background-to-gray) (def/public-unimplemented set-background-to-gray)
(define/public (get-scroll-pos which) (define/public (get-scroll-pos which)
@ -326,21 +347,41 @@
(set-SCROLLINFO-nPos! i new-pos) (set-SCROLLINFO-nPos! i new-pos)
(set-SCROLLINFO-fMask! i SIF_POS) (set-SCROLLINFO-fMask! i SIF_POS)
(SetScrollInfo canvas-hwnd dir i #t) (SetScrollInfo canvas-hwnd dir i #t)
(queue-window-event (if (is-auto-scroll?)
this (refresh-for-autoscroll)
(lambda () (queue-window-event
(on-scroll (new scroll-event% this
[event-type 'thumb] (lambda ()
[direction (if (= dir SB_HORZ) 'horizontal 'vertical)] (on-scroll (new scroll-event%
[position new-pos])))) [event-type 'thumb]
[direction (if (= dir SB_HORZ) 'horizontal 'vertical)]
[position new-pos])))))
(constrained-reply (get-eventspace) (constrained-reply (get-eventspace)
(lambda () (lambda ()
(let loop () (pre-event-sync #t) (when (yield) (loop)))) (let loop () (pre-event-sync #t) (when (yield) (loop))))
(void)))))) (void))))))
(define/override (definitely-wants-event? w e) (define/override (definitely-wants-event? w msg wParam e)
(or (e . is-a? . key-event%) (cond
(ptr-equal? w canvas-hwnd))) [(e . is-a? . key-event%)
;; All key events to canvas, event for combo:
#t]
[(and (or (= wParam HTVSCROLL)
(= wParam HTHSCROLL))
(or (= msg WM_NCLBUTTONDOWN)
(= msg WM_NCRBUTTONDOWN)
(= msg WM_NCMBUTTONDOWN)
(= msg WM_NCLBUTTONDBLCLK)
(= msg WM_NCRBUTTONDBLCLK)
(= msg WM_NCMBUTTONDBLCLK)
(= msg WM_NCLBUTTONUP)
(= msg WM_NCRBUTTONUP)
(= msg WM_NCMBUTTONUP)))
;; let scrollbar handle event:
#f]
[else
;; otherwise, just handle events to canvas:
(ptr-equal? w canvas-hwnd)]))
(define/public (on-combo-select i) (void)) (define/public (on-combo-select i) (void))
(define/public (set-combo-text s) (void)) (define/public (set-combo-text s) (void))
@ -359,9 +400,14 @@
(ptr-equal? canvas-hwnd a-hwnd) (ptr-equal? canvas-hwnd a-hwnd)
(ptr-equal? combo-hwnd a-hwnd))) (ptr-equal? combo-hwnd a-hwnd)))
(def/public-unimplemented scroll) (define/public (scroll x y)
(when (x . > . 0)
(set-scroll-pos 'horizontal (->long (* x (get-scroll-range 'horizontal)))))
(when (y . > . 0)
(set-scroll-pos 'vertical (->long (* y (get-scroll-range 'vertical)))))
(when (is-auto-scroll?) (refresh-for-autoscroll)))
(def/public-unimplemented warp-pointer) (def/public-unimplemented warp-pointer)
(def/public-unimplemented view-start)
(define/public (set-resize-corner on?) (define/public (set-resize-corner on?)
(void))))) (void)))))

70
collects/mred/private/wx/win32/window.rkt
View File

@ -129,21 +129,21 @@
(unhide-cursor) (unhide-cursor)
(begin0 (begin0
(default w msg wParam lParam) (default w msg wParam lParam)
(do-key w wParam lParam #f #f))] (do-key w msg wParam lParam #f #f))]
[(= msg WM_KEYDOWN) [(= msg WM_KEYDOWN)
(do-key w wParam lParam #f #f) (do-key w msg wParam lParam #f #f)
0] 0]
[(= msg WM_KEYUP) [(= msg WM_KEYUP)
(do-key w wParam lParam #f #t) (do-key w msg wParam lParam #f #t)
0] 0]
[(and (= msg WM_SYSCHAR) [(and (= msg WM_SYSCHAR)
(= wParam VK_MENU)) (= wParam VK_MENU))
(unhide-cursor) (unhide-cursor)
(begin0 (begin0
(default w msg wParam lParam) (default w msg wParam lParam)
(do-key w wParam lParam #t #f))] (do-key w msg wParam lParam #t #f))]
[(= msg WM_CHAR) [(= msg WM_CHAR)
(do-key w wParam lParam #t #f) (do-key w msg wParam lParam #t #f)
0] 0]
[(= msg WM_COMMAND) [(= msg WM_COMMAND)
(let* ([control-hwnd (cast lParam _LPARAM _HWND)] (let* ([control-hwnd (cast lParam _LPARAM _HWND)]
@ -391,10 +391,10 @@
(define/public (get-top-frame) (define/public (get-top-frame)
(send parent get-top-frame)) (send parent get-top-frame))
(define/private (do-key w wParam lParam is-char? is-up?) (define/private (do-key w msg wParam lParam is-char? is-up?)
(let ([e (make-key-event #f wParam lParam is-char? is-up? hwnd)]) (let ([e (make-key-event #f wParam lParam is-char? is-up? hwnd)])
(and e (and e
(if (definitely-wants-event? w e) (if (definitely-wants-event? w msg wParam e)
(begin (begin
(queue-window-event this (lambda () (dispatch-on-char/sync e))) (queue-window-event this (lambda () (dispatch-on-char/sync e)))
#t) #t)
@ -406,52 +406,52 @@
(define/public (try-mouse w msg wParam lParam) (define/public (try-mouse w msg wParam lParam)
(cond (cond
[(= msg WM_NCRBUTTONDOWN) [(= msg WM_NCRBUTTONDOWN)
(do-mouse w #t 'right-down wParam lParam)] (do-mouse w msg #t 'right-down wParam lParam)]
[(= msg WM_NCRBUTTONUP) [(= msg WM_NCRBUTTONUP)
(do-mouse w #t 'right-up wParam lParam)] (do-mouse w msg #t 'right-up wParam lParam)]
[(= msg WM_NCRBUTTONDBLCLK) [(= msg WM_NCRBUTTONDBLCLK)
(do-mouse w #t 'right-down wParam lParam)] (do-mouse w msg #t 'right-down wParam lParam)]
[(= msg WM_NCMBUTTONDOWN) [(= msg WM_NCMBUTTONDOWN)
(do-mouse w #t 'middle-down wParam lParam)] (do-mouse w msg #t 'middle-down wParam lParam)]
[(= msg WM_NCMBUTTONUP) [(= msg WM_NCMBUTTONUP)
(do-mouse w #t 'middle-up wParam lParam)] (do-mouse w msg #t 'middle-up wParam lParam)]
[(= msg WM_NCMBUTTONDBLCLK) [(= msg WM_NCMBUTTONDBLCLK)
(do-mouse w #t 'middle-down wParam lParam)] (do-mouse w msg #t 'middle-down wParam lParam)]
[(= msg WM_NCLBUTTONDOWN) [(= msg WM_NCLBUTTONDOWN)
(do-mouse w #t 'left-down wParam lParam)] (do-mouse w msg #t 'left-down wParam lParam)]
[(= msg WM_NCLBUTTONUP) [(= msg WM_NCLBUTTONUP)
(do-mouse w #t 'left-up wParam lParam)] (do-mouse w msg #t 'left-up wParam lParam)]
[(= msg WM_NCLBUTTONDBLCLK) [(= msg WM_NCLBUTTONDBLCLK)
(do-mouse w #t 'left-down wParam lParam)] (do-mouse w msg #t 'left-down wParam lParam)]
[(and (= msg WM_NCMOUSEMOVE) [(and (= msg WM_NCMOUSEMOVE)
(not (= wParam HTVSCROLL)) (not (= wParam HTVSCROLL))
(not (= wParam HTHSCROLL))) (not (= wParam HTHSCROLL)))
(do-mouse w #t 'motion wParam lParam)] (do-mouse w msg #t 'motion wParam lParam)]
[(= msg WM_RBUTTONDOWN) [(= msg WM_RBUTTONDOWN)
(do-mouse w #f 'right-down wParam lParam)] (do-mouse w msg #f 'right-down wParam lParam)]
[(= msg WM_RBUTTONUP) [(= msg WM_RBUTTONUP)
(do-mouse w #f 'right-up wParam lParam)] (do-mouse w msg #f 'right-up wParam lParam)]
[(= msg WM_RBUTTONDBLCLK) [(= msg WM_RBUTTONDBLCLK)
(do-mouse w #f 'right-down wParam lParam)] (do-mouse w msg #f 'right-down wParam lParam)]
[(= msg WM_MBUTTONDOWN) [(= msg WM_MBUTTONDOWN)
(do-mouse w #f 'middle-down wParam lParam)] (do-mouse w msg #f 'middle-down wParam lParam)]
[(= msg WM_MBUTTONUP) [(= msg WM_MBUTTONUP)
(do-mouse w #f 'middle-up wParam lParam)] (do-mouse w msg #f 'middle-up wParam lParam)]
[(= msg WM_MBUTTONDBLCLK) [(= msg WM_MBUTTONDBLCLK)
(do-mouse w #f 'middle-down wParam lParam)] (do-mouse w msg #f 'middle-down wParam lParam)]
[(= msg WM_LBUTTONDOWN) [(= msg WM_LBUTTONDOWN)
(do-mouse w #f 'left-down wParam lParam)] (do-mouse w msg #f 'left-down wParam lParam)]
[(= msg WM_LBUTTONUP) [(= msg WM_LBUTTONUP)
(do-mouse w #f 'left-up wParam lParam)] (do-mouse w msg #f 'left-up wParam lParam)]
[(= msg WM_LBUTTONDBLCLK) [(= msg WM_LBUTTONDBLCLK)
(do-mouse w #f 'left-down wParam lParam)] (do-mouse w msg #f 'left-down wParam lParam)]
[(= msg WM_MOUSEMOVE) [(= msg WM_MOUSEMOVE)
(do-mouse w #f 'motion wParam lParam)] (do-mouse w msg #f 'motion wParam lParam)]
[(= msg WM_MOUSELEAVE) [(= msg WM_MOUSELEAVE)
(do-mouse w #f 'leave wParam lParam)] (do-mouse w msg #f 'leave wParam lParam)]
[else #f])) [else #f]))
(define/private (do-mouse control-hwnd nc? type wParam lParam) (define/private (do-mouse control-hwnd msg nc? type wParam lParam)
(let ([x (LOWORD lParam)] (let ([x (LOWORD lParam)]
[y (HIWORD lParam)] [y (HIWORD lParam)]
[flags (if nc? 0 wParam)] [flags (if nc? 0 wParam)]
@ -495,10 +495,10 @@
c)))))) c))))))
(when (memq type '(left-down right-down middle-down)) (when (memq type '(left-down right-down middle-down))
(set-focus)) (set-focus))
(handle-mouse-event control-hwnd (make-e type))))) (handle-mouse-event control-hwnd msg wParam (make-e type)))))
(define/private (handle-mouse-event w e) (define/private (handle-mouse-event w msg wParam e)
(if (definitely-wants-event? w e) (if (definitely-wants-event? w msg wParam e)
(begin (begin
(queue-window-event this (lambda () (dispatch-on-event/sync e))) (queue-window-event this (lambda () (dispatch-on-event/sync e)))
#t) #t)
@ -513,7 +513,7 @@
(begin (begin
(set! mouse-in? #t) (set! mouse-in? #t)
(let ([parent-cursor (generate-parent-mouse-ins mk)]) (let ([parent-cursor (generate-parent-mouse-ins mk)])
(handle-mouse-event #f (mk 'enter)) (handle-mouse-event (get-client-hwnd) 0 0 (mk 'enter))
(let ([c (or cursor-handle parent-cursor)]) (let ([c (or cursor-handle parent-cursor)])
(set! effective-cursor-handle c) (set! effective-cursor-handle c)
c))))) c)))))
@ -525,14 +525,14 @@
(set! mouse-in? #f) (set! mouse-in? #f)
(let ([e (mk 'leave)]) (let ([e (mk 'leave)])
(if (eq? (current-eventspace) (get-eventspace)) (if (eq? (current-eventspace) (get-eventspace))
(handle-mouse-event #f e) (handle-mouse-event (get-client-hwnd) 0 0 e)
(queue-window-event this (queue-window-event this
(lambda () (dispatch-on-event/sync e)))))) (lambda () (dispatch-on-event/sync e))))))
(define/public (send-child-leaves mk) (define/public (send-child-leaves mk)
#f) #f)
(define/public (definitely-wants-event? w e) (define/public (definitely-wants-event? w msg wParam e)
#f) #f)
(define/public (dispatch-on-char/sync e) (define/public (dispatch-on-char/sync e)