win32: collecting-blit

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

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

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

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)

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

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