diff --git a/collects/mred/private/wx/win32/canvas.rkt b/collects/mred/private/wx/win32/canvas.rkt index 8f2c5351ea..cd561b59c5 100644 --- a/collects/mred/private/wx/win32/canvas.rkt +++ b/collects/mred/private/wx/win32/canvas.rkt @@ -16,6 +16,8 @@ "window.rkt" "dc.rkt" "item.rkt" + "hbitmap.rkt" + "gcwin.rkt" "theme.rkt") (provide canvas%) @@ -29,12 +31,14 @@ -> (unless r (failed 'ShowScrollbar)))) (define-gdi32 CreateSolidBrush (_wfun _COLORREF -> _HBRUSH)) -(define-gdi32 SelectObject (_wfun _HDC _pointer -> _pointer)) (define-gdi32 DeleteObject (_wfun _pointer -> (r : _BOOL) -> (unless r (failed 'DeleteObject)))) (define-user32 FillRect (_wfun _HDC _RECT-pointer _HBRUSH -> (r : _int) -> (when (zero? r) (failed 'FillRect)))) +(define-user32 DestroyWindow (_wfun _HWND -> (r : _BOOL) + -> (unless r (failed 'DestroyWindow)))) + (define _HRGN _pointer) (define-user32 GetDCEx (_wfun _HWND _HRGN _DWORD -> _HDC)) (define DCX_WINDOW #x00000001) @@ -432,5 +436,31 @@ (def/public-unimplemented warp-pointer) (define/public (set-resize-corner on?) - (void))))) + (void)) + + (define reg-blits null) + + (define/private (register-one-blit x y w h on-hbitmap off-hbitmap) + (atomically + (let ([hwnd (create-gc-window canvas-hwnd x y w h)]) + (let ([r (scheme_add_gc_callback + (make-gc-show-desc hwnd on-hbitmap w h) + (make-gc-hide-desc hwnd off-hbitmap w h))]) + (cons hwnd r))))) + + (define/public (register-collecting-blit x y w h on off on-x on-y off-x off-y) + (let ([on (fix-bitmap-size on w h on-x on-y)] + [off (fix-bitmap-size off w h off-x off-y)]) + (let ([on-hbitmap (bitmap->hbitmap on)] + [off-hbitmap (bitmap->hbitmap off)]) + (atomically + (set! reg-blits (cons (register-one-blit x y w h on-hbitmap off-hbitmap) reg-blits)))))) + + (define/public (unregister-collecting-blits) + (atomically + (for ([r (in-list reg-blits)]) + (DestroyWindow (car r)) + (scheme_remove_gc_callback (cdr r))) + (set! reg-blits null)))))) + diff --git a/collects/mred/private/wx/win32/gcwin.rkt b/collects/mred/private/wx/win32/gcwin.rkt new file mode 100644 index 0000000000..324170cb4c --- /dev/null +++ b/collects/mred/private/wx/win32/gcwin.rkt @@ -0,0 +1,68 @@ +#lang racket/base +(require ffi/unsafe + "utils.rkt" + "types.rkt" + "const.rkt" + "wndclass.rkt") + +(provide scheme_add_gc_callback + scheme_remove_gc_callback + create-gc-window + make-gc-show-desc + make-gc-hide-desc) + +(define-mz scheme_add_gc_callback (_fun _racket _racket -> _racket)) +(define-mz scheme_remove_gc_callback (_fun _racket -> _void)) + +(define-user32 ShowWindow/raw _fpointer + #:c-id ShowWindow) +(define-gdi32 BitBlt/raw _fpointer + #; + (_wfun _HDC _int _int _int _int _HDC _int _int _DWORD -> _BOOL) + #:c-id BitBlt) +(define-gdi32 SelectObject/raw _fpointer + #:c-id SelectObject) + +(define-gdi32 CreateCompatibleDC (_wfun _HDC -> _HDC)) + +(define SRCCOPY #x00CC0020) + +(define blit-hdc (CreateCompatibleDC #f)) + +(define (create-gc-window parent-hwnd x y w h) + (CreateWindowExW 0 + "PLTBlitTarget" + "" + (bitwise-ior WS_CHILD) + x y w h + parent-hwnd + #f + hInstance + #f)) + +(define (make-draw hwnd hbitmap w h) + (let ([hdc (GetDC hwnd)]) + null + (list + (vector 'osapi_ptr_ptr->void SelectObject/raw blit-hdc hbitmap) + (vector 'osapi_ptr_int_int_int_int_ptr_int_int_long->void + BitBlt/raw hdc 0 0 w h blit-hdc 0 0 SRCCOPY) + (vector 'ptr_ptr->void SelectObject/raw blit-hdc #f)))) + +(define (make-gc-show-desc hwnd hbitmap w h) + (list->vector + (append + (list + (vector 'osapi_ptr_int->void ShowWindow/raw hwnd SW_SHOW)) + (make-draw hwnd hbitmap w h)))) + +(define (make-gc-hide-desc hwnd hbitmap w h) + (list->vector + (append + ;; draw the ``off'' bitmap so it changes immediately: + (make-draw hwnd hbitmap w h) + ;; hide the window; it may take a while for the underlying canvas + ;; to refresh: + (list + (vector 'osapi_ptr_int->void ShowWindow/raw hwnd SW_HIDE))))) + diff --git a/collects/mred/private/wx/win32/hbitmap.rkt b/collects/mred/private/wx/win32/hbitmap.rkt index 7458c8dbb2..fe9aea8093 100644 --- a/collects/mred/private/wx/win32/hbitmap.rkt +++ b/collects/mred/private/wx/win32/hbitmap.rkt @@ -14,7 +14,6 @@ (define-gdi32 CreateCompatibleDC (_wfun _HDC -> _HDC)) (define-gdi32 DeleteDC (_wfun _HDC -> (r : _BOOL) -> (unless r (failed 'DeleteDC)))) -(define-gdi32 SelectObject (_wfun _HDC _HBITMAP -> _HBITMAP)) (define (bitmap->hbitmap bm) (let* ([w (send bm get-width)] diff --git a/collects/mred/private/wx/win32/procs.rkt b/collects/mred/private/wx/win32/procs.rkt index 651be34843..6e191c5f29 100644 --- a/collects/mred/private/wx/win32/procs.rkt +++ b/collects/mred/private/wx/win32/procs.rkt @@ -57,8 +57,10 @@ (define (get-panel-background) (make-object color% "gray")) (define-unimplemented play-sound) (define-unimplemented find-graphical-system-path) -(define (register-collecting-blit . args) (void)) -(define (unregister-collecting-blit . args) (void)) +(define (register-collecting-blit canvas x y w h on off on-x on-y off-x off-y) + (send canvas register-collecting-blit x y w h on off on-x on-y off-x off-y)) +(define (unregister-collecting-blit canvas) + (send canvas unregister-collecting-blits)) (define (shortcut-visible-in-label? [? #f]) #t) (define-unimplemented location->window) (define-unimplemented send-event) diff --git a/collects/mred/private/wx/win32/utils.rkt b/collects/mred/private/wx/win32/utils.rkt index 8847b4b5f1..273cca8ac9 100644 --- a/collects/mred/private/wx/win32/utils.rkt +++ b/collects/mred/private/wx/win32/utils.rkt @@ -30,7 +30,8 @@ GetMenuState CheckMenuItem ModifyMenuW - RemoveMenu) + RemoveMenu + SelectObject) (define gdi32-lib (ffi-lib "gdi32.dll")) (define user32-lib (ffi-lib "user32.dll")) @@ -100,3 +101,5 @@ -> (unless r (failed 'ModifyMenuW)))) (define-user32 RemoveMenu (_wfun _HMENU _UINT _UINT -> (r : _BOOL) -> (unless r (failed 'RemoveMenu)))) + +(define-gdi32 SelectObject (_wfun _HDC _pointer -> _pointer)) diff --git a/collects/mred/private/wx/win32/wndclass.rkt b/collects/mred/private/wx/win32/wndclass.rkt index a0b94cce7d..a3ea24faca 100644 --- a/collects/mred/private/wx/win32/wndclass.rkt +++ b/collects/mred/private/wx/win32/wndclass.rkt @@ -114,6 +114,17 @@ #f ; menu "PLTCanvas"))) +(void (RegisterClassW (make-WNDCLASS CS_OWNDC + DefWindowProcW + 0 + 0 + hInstance + #f + #f + #f + #f + "PLTBlitTarget"))) + (void (RegisterClassW (make-WNDCLASS 0 wind-proc 0