From b459fcf91cee9470fbe5de9332b09940d0c6b95b Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 10 Oct 2010 08:54:19 -0600 Subject: [PATCH] win32: canvas autoscroll --- collects/mred/private/wx/gtk/canvas.rkt | 1 - collects/mred/private/wx/win32/canvas.rkt | 92 +++++++++++++++++------ collects/mred/private/wx/win32/window.rkt | 70 ++++++++--------- 3 files changed, 104 insertions(+), 59 deletions(-) diff --git a/collects/mred/private/wx/gtk/canvas.rkt b/collects/mred/private/wx/gtk/canvas.rkt index 53c883a849..6fadee0148 100644 --- a/collects/mred/private/wx/gtk/canvas.rkt +++ b/collects/mred/private/wx/gtk/canvas.rkt @@ -193,7 +193,6 @@ set-auto-size adjust-client-delta infer-client-delta is-auto-scroll? get-virtual-width get-virtual-height - reset-auto-scroll refresh-for-autoscroll) (define is-combo? (memq 'combo style)) diff --git a/collects/mred/private/wx/win32/canvas.rkt b/collects/mred/private/wx/win32/canvas.rkt index 95a79c7968..5be59d27c0 100644 --- a/collects/mred/private/wx/win32/canvas.rkt +++ b/collects/mred/private/wx/win32/canvas.rkt @@ -37,6 +37,9 @@ (define ETS_NORMAL 1) (define ETS_DISABLE 4) +(define HTHSCROLL 6) +(define HTVSCROLL 7) + (define-cstruct _SCROLLINFO ([cbSize _UINT] [fMask _UINT] @@ -61,7 +64,7 @@ (define canvas% (canvas-mixin - (class (item-mixin window%) + (class (canvas-autoscroll-mixin (item-mixin window%)) (init parent x y w h style @@ -72,7 +75,10 @@ get-client-size get-eventspace 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 vscroll? (memq 'vscroll style)) @@ -182,7 +188,17 @@ (define/public (get-dc) dc) (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) canvas-hwnd) @@ -232,9 +248,6 @@ (unless (zero? 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 bg-col (make-object color% "white")) (define/public (get-canvas-background) (if transparent? @@ -254,11 +267,10 @@ (set! v-scroll-visible? (and v? #t)) (ShowScrollBar canvas-hwnd SB_VERT v?)))) - (define/public (set-scrollbars h-step v-step - h-len v-len - h-page v-page - h-pos v-pos - auto?) + (define/override (do-set-scrollbars h-step v-step + h-len v-len + h-page v-page + h-pos v-pos) (define (make-info len page pos vis?) (make-SCROLLINFO (ctype-sizeof _SCROLLINFO) (bitwise-ior (if vis? SIF_DISABLENOSCROLL 0) @@ -271,6 +283,15 @@ (when vscroll? (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) (define/public (get-scroll-pos which) @@ -326,21 +347,41 @@ (set-SCROLLINFO-nPos! i new-pos) (set-SCROLLINFO-fMask! i SIF_POS) (SetScrollInfo canvas-hwnd dir i #t) - (queue-window-event - this - (lambda () - (on-scroll (new scroll-event% - [event-type 'thumb] - [direction (if (= dir SB_HORZ) 'horizontal 'vertical)] - [position new-pos])))) + (if (is-auto-scroll?) + (refresh-for-autoscroll) + (queue-window-event + this + (lambda () + (on-scroll (new scroll-event% + [event-type 'thumb] + [direction (if (= dir SB_HORZ) 'horizontal 'vertical)] + [position new-pos]))))) (constrained-reply (get-eventspace) (lambda () (let loop () (pre-event-sync #t) (when (yield) (loop)))) (void)))))) - (define/override (definitely-wants-event? w e) - (or (e . is-a? . key-event%) - (ptr-equal? w canvas-hwnd))) + (define/override (definitely-wants-event? w msg wParam e) + (cond + [(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 (set-combo-text s) (void)) @@ -359,9 +400,14 @@ (ptr-equal? canvas-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 view-start) (define/public (set-resize-corner on?) (void))))) diff --git a/collects/mred/private/wx/win32/window.rkt b/collects/mred/private/wx/win32/window.rkt index f6582a4c62..8d51968186 100644 --- a/collects/mred/private/wx/win32/window.rkt +++ b/collects/mred/private/wx/win32/window.rkt @@ -129,21 +129,21 @@ (unhide-cursor) (begin0 (default w msg wParam lParam) - (do-key w wParam lParam #f #f))] + (do-key w msg wParam lParam #f #f))] [(= msg WM_KEYDOWN) - (do-key w wParam lParam #f #f) + (do-key w msg wParam lParam #f #f) 0] [(= msg WM_KEYUP) - (do-key w wParam lParam #f #t) + (do-key w msg wParam lParam #f #t) 0] [(and (= msg WM_SYSCHAR) (= wParam VK_MENU)) (unhide-cursor) (begin0 (default w msg wParam lParam) - (do-key w wParam lParam #t #f))] + (do-key w msg wParam lParam #t #f))] [(= msg WM_CHAR) - (do-key w wParam lParam #t #f) + (do-key w msg wParam lParam #t #f) 0] [(= msg WM_COMMAND) (let* ([control-hwnd (cast lParam _LPARAM _HWND)] @@ -391,10 +391,10 @@ (define/public (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)]) (and e - (if (definitely-wants-event? w e) + (if (definitely-wants-event? w msg wParam e) (begin (queue-window-event this (lambda () (dispatch-on-char/sync e))) #t) @@ -406,52 +406,52 @@ (define/public (try-mouse w msg wParam lParam) (cond [(= msg WM_NCRBUTTONDOWN) - (do-mouse w #t 'right-down wParam lParam)] + (do-mouse w msg #t 'right-down wParam lParam)] [(= msg WM_NCRBUTTONUP) - (do-mouse w #t 'right-up wParam lParam)] + (do-mouse w msg #t 'right-up wParam lParam)] [(= msg WM_NCRBUTTONDBLCLK) - (do-mouse w #t 'right-down wParam lParam)] + (do-mouse w msg #t 'right-down wParam lParam)] [(= msg WM_NCMBUTTONDOWN) - (do-mouse w #t 'middle-down wParam lParam)] + (do-mouse w msg #t 'middle-down wParam lParam)] [(= msg WM_NCMBUTTONUP) - (do-mouse w #t 'middle-up wParam lParam)] + (do-mouse w msg #t 'middle-up wParam lParam)] [(= msg WM_NCMBUTTONDBLCLK) - (do-mouse w #t 'middle-down wParam lParam)] + (do-mouse w msg #t 'middle-down wParam lParam)] [(= msg WM_NCLBUTTONDOWN) - (do-mouse w #t 'left-down wParam lParam)] + (do-mouse w msg #t 'left-down wParam lParam)] [(= msg WM_NCLBUTTONUP) - (do-mouse w #t 'left-up wParam lParam)] + (do-mouse w msg #t 'left-up wParam lParam)] [(= msg WM_NCLBUTTONDBLCLK) - (do-mouse w #t 'left-down wParam lParam)] + (do-mouse w msg #t 'left-down wParam lParam)] [(and (= msg WM_NCMOUSEMOVE) (not (= wParam HTVSCROLL)) (not (= wParam HTHSCROLL))) - (do-mouse w #t 'motion wParam lParam)] + (do-mouse w msg #t 'motion wParam lParam)] [(= msg WM_RBUTTONDOWN) - (do-mouse w #f 'right-down wParam lParam)] + (do-mouse w msg #f 'right-down wParam lParam)] [(= msg WM_RBUTTONUP) - (do-mouse w #f 'right-up wParam lParam)] + (do-mouse w msg #f 'right-up wParam lParam)] [(= msg WM_RBUTTONDBLCLK) - (do-mouse w #f 'right-down wParam lParam)] + (do-mouse w msg #f 'right-down wParam lParam)] [(= msg WM_MBUTTONDOWN) - (do-mouse w #f 'middle-down wParam lParam)] + (do-mouse w msg #f 'middle-down wParam lParam)] [(= msg WM_MBUTTONUP) - (do-mouse w #f 'middle-up wParam lParam)] + (do-mouse w msg #f 'middle-up wParam lParam)] [(= msg WM_MBUTTONDBLCLK) - (do-mouse w #f 'middle-down wParam lParam)] + (do-mouse w msg #f 'middle-down wParam lParam)] [(= msg WM_LBUTTONDOWN) - (do-mouse w #f 'left-down wParam lParam)] + (do-mouse w msg #f 'left-down wParam lParam)] [(= msg WM_LBUTTONUP) - (do-mouse w #f 'left-up wParam lParam)] + (do-mouse w msg #f 'left-up wParam lParam)] [(= msg WM_LBUTTONDBLCLK) - (do-mouse w #f 'left-down wParam lParam)] + (do-mouse w msg #f 'left-down wParam lParam)] [(= msg WM_MOUSEMOVE) - (do-mouse w #f 'motion wParam lParam)] + (do-mouse w msg #f 'motion wParam lParam)] [(= msg WM_MOUSELEAVE) - (do-mouse w #f 'leave wParam lParam)] + (do-mouse w msg #f 'leave wParam lParam)] [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)] [y (HIWORD lParam)] [flags (if nc? 0 wParam)] @@ -495,10 +495,10 @@ c)))))) (when (memq type '(left-down right-down middle-down)) (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) - (if (definitely-wants-event? w e) + (define/private (handle-mouse-event w msg wParam e) + (if (definitely-wants-event? w msg wParam e) (begin (queue-window-event this (lambda () (dispatch-on-event/sync e))) #t) @@ -513,7 +513,7 @@ (begin (set! mouse-in? #t) (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)]) (set! effective-cursor-handle c) c))))) @@ -525,14 +525,14 @@ (set! mouse-in? #f) (let ([e (mk 'leave)]) (if (eq? (current-eventspace) (get-eventspace)) - (handle-mouse-event #f e) + (handle-mouse-event (get-client-hwnd) 0 0 e) (queue-window-event this (lambda () (dispatch-on-event/sync e)))))) (define/public (send-child-leaves mk) #f) - (define/public (definitely-wants-event? w e) + (define/public (definitely-wants-event? w msg wParam e) #f) (define/public (dispatch-on-char/sync e)