win32: clearing of transparent canvases

original commit: 54fc1e276673afe6806110fc7c30220c17cc8411

collects/mred/private/wx/win32/canvas.rkt

@@ -28,6 +28,13 @@
 (define-user32 ShowScrollBar (_wfun _HWND _int _BOOL -> (r : _BOOL)
                                     -> (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 _HRGN _pointer)
 (define-user32 GetDCEx (_wfun _HWND _HRGN _DWORD -> _HDC))
 (define DCX_WINDOW           #x00000001)
@@ -149,9 +156,15 @@
          (let* ([ps (malloc 128)]
                 [hdc (BeginPaint w ps)])
            (unless (positive? paint-suspended)
-             (unless (do-backing-flush this dc hdc)
-               (queue-paint))
-             (do-backing-flush this dc hdc))
+             (let* ([hbrush (if transparent?
+                                background-hbrush
+                                (CreateSolidBrush bg-colorref))])
+               (let ([r (GetClientRect canvas-hwnd)])
+                 (FillRect hdc r hbrush))
+               (unless transparent?
+                 (DeleteObject hbrush))
+               (unless (do-backing-flush this dc hdc)
+                 (queue-paint))))
            (EndPaint hdc ps))
          0]
         [(= msg WM_NCPAINT)
@@ -250,10 +263,16 @@
 
      (define transparent? (memq 'transparent style))
      (define bg-col (make-object color% "white"))
+     (define bg-colorref #xFFFFFF)
      (define/public (get-canvas-background) (if transparent?
                                                 #f
                                                 bg-col))
-     (define/public (set-canvas-background col) (set! bg-col col))
+     (define/public (set-canvas-background col)
+       (atomically
+        (set! bg-col col)
+        (set! bg-colorref (make-COLORREF (send col red)
+                                         (send col green)
+                                         (send col blue)))))
 
      (define h-scroll-visible? hscroll?)
      (define v-scroll-visible? vscroll?)

collects/mred/private/wx/win32/cursor.rkt

@@ -107,7 +107,7 @@
                           16 16
                           ai xi))))
 
+  (define/public (ok?) (and handle #t))
   (define/public (get-handle) handle)
 
-  (def/public-unimplemented ok?)
   (super-new))

collects/mred/private/wx/win32/procs.rkt

@@ -58,7 +58,7 @@
 (define-unimplemented play-sound)
 (define-unimplemented find-graphical-system-path)
 (define (register-collecting-blit . args) (void))
-(define-unimplemented unregister-collecting-blit)
+(define (unregister-collecting-blit . args) (void))
 (define (shortcut-visible-in-label? [? #f]) #t)
 (define-unimplemented location->window)
 (define-unimplemented send-event)

collects/mred/private/wx/win32/utils.rkt

@@ -15,7 +15,7 @@
          GetWindowLongW
          SetWindowLongW
          SendMessageW SendMessageW/str
-         GetSysColor GetRValue GetGValue GetBValue
+         GetSysColor GetRValue GetGValue GetBValue make-COLORREF
          MoveWindow
          ShowWindow
          EnableWindow
@@ -59,6 +59,10 @@
 (define (GetRValue v) (bitwise-and v #xFF))
 (define (GetGValue v) (bitwise-and (arithmetic-shift v -8) #xFF))
 (define (GetBValue v) (bitwise-and (arithmetic-shift v -16) #xFF))
+(define (make-COLORREF r g b) (bitwise-ior
+                               r
+                               (arithmetic-shift g 8)
+                               (arithmetic-shift b 16)))
 
 (define-user32 MoveWindow(_wfun _HWND _int _int _int _int _BOOL -> (r : _BOOL)
                                 -> (unless r (failed 'MoveWindow))))

collects/mred/private/wx/win32/window.rkt

@@ -22,7 +22,8 @@
 	 queue-window-refresh-event
 	 
 	 CreateWindowExW
-	 GetWindowRect)
+	 GetWindowRect
+         GetClientRect)
 
 (define (unhide-cursor) (void))
 

collects/mred/private/wx/win32/wndclass.rkt

@@ -9,6 +9,7 @@
 
 (provide hInstance
 	 DefWindowProcW
+         background-hbrush
 	 hwnd->wx
 	 any-hwnd->wx
 	 set-hwnd-wx!
@@ -87,6 +88,10 @@
 
 (define hInstance (GetModuleHandleW #f))
 
+(define background-hbrush (let ([p (ptr-add #f (+ COLOR_BTNFACE 1))])
+                            (cpointer-push-tag! p 'HBRUSH)
+                            p))
+ 
 (void (RegisterClassW (make-WNDCLASS CS_OWNDC
 				     wind-proc
 				     0
@@ -94,9 +99,7 @@
 				     hInstance
 				     (LoadIconW #f IDI_APPLICATION)
                                      #f
-                                     (let ([p (ptr-add #f (+ COLOR_BTNFACE 1))])
-                                       (cpointer-push-tag! p 'HBRUSH)
-                                       p)
+                                     background-hbrush
 				     #f ; menu
 				     "PLTFrame")))
 
@@ -118,9 +121,7 @@
 				     hInstance
 				     #f
 				     #f
-                                     (let ([p (ptr-add #f (+ COLOR_BTNFACE 1))])
-                                       (cpointer-push-tag! p 'HBRUSH)
-                                       p)
+                                     background-hbrush
 				     #f ; menu
 				     "PLTPanel")))