From 95048b2dca1925903f66b07f27d8a781a39d9912 Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Sat, 13 Nov 2010 09:54:14 -0700
Subject: [PATCH] win32: canvas refresh repair

original commit: d2fe39da339c06c3f7edfe57ea53e5543101957b
---
 .../mred/private/wx/common/canvas-mixin.rkt   |  2 +-
 collects/mred/private/wx/win32/canvas.rkt     | 53 ++++++++++++-------
 2 files changed, 36 insertions(+), 19 deletions(-)

diff --git a/collects/mred/private/wx/common/canvas-mixin.rkt b/collects/mred/private/wx/common/canvas-mixin.rkt
index 1dbeb28e..07c4364f 100644
--- a/collects/mred/private/wx/common/canvas-mixin.rkt
+++ b/collects/mred/private/wx/common/canvas-mixin.rkt
@@ -168,7 +168,7 @@
 
     (define flush-box #f)
     
-    ;; Periodic flush is needed for Windows and Gtk, where
+    ;; Periodic flush is needed for Windows, where
     ;; updates otherwise happen only via the eventspace's queue
     (define/override (schedule-periodic-backing-flush)
       (unless flush-box
diff --git a/collects/mred/private/wx/win32/canvas.rkt b/collects/mred/private/wx/win32/canvas.rkt
index e871aeb2..cfaf727a 100644
--- a/collects/mred/private/wx/win32/canvas.rkt
+++ b/collects/mred/private/wx/win32/canvas.rkt
@@ -157,19 +157,20 @@
                 [hdc (BeginPaint w ps)])
            (if for-gl?
                (queue-paint)
-               (unless (positive? paint-suspended)
-                 (let* ([hbrush (if no-autoclear?
-                                    #f
-                                    (if transparent?
-                                        background-hbrush
-                                        (CreateSolidBrush bg-colorref)))])
-                   (when hbrush
-                     (let ([r (GetClientRect canvas-hwnd)])
-                       (FillRect hdc r hbrush))
-                     (unless transparent?
-                       (DeleteObject hbrush)))
-                   (unless (do-canvas-backing-flush hdc)
-                     (queue-paint)))))
+               (if (positive? paint-suspended)
+                   (set! suspended-refresh? #t)
+                   (let* ([hbrush (if no-autoclear?
+                                      #f
+                                      (if transparent?
+                                          background-hbrush
+                                          (CreateSolidBrush bg-colorref)))])
+                     (when hbrush
+                       (let ([r (GetClientRect canvas-hwnd)])
+                         (FillRect hdc r hbrush))
+                       (unless transparent?
+                         (DeleteObject hbrush)))
+                     (unless (do-canvas-backing-flush hdc)
+                       (queue-paint)))))
            (EndPaint hdc ps))
          0]
         [(= msg WM_NCPAINT)
@@ -271,22 +272,38 @@
      (define/public (do-canvas-backing-flush hdc)
        (if hdc
            (do-backing-flush this dc hdc)
-           (let ([hdc (GetDC canvas-hwnd)])
-             (do-backing-flush this dc hdc)
-             (ReleaseDC canvas-hwnd hdc)
-             (ValidateRect canvas-hwnd #f))))
+           (if (positive? paint-suspended)
+               ;; suspended => try again later
+               (schedule-periodic-backing-flush)
+               ;; not suspended
+               (let ([hdc (GetDC canvas-hwnd)])
+                 (do-backing-flush this dc hdc)
+                 (ReleaseDC canvas-hwnd hdc)
+                 ;; We'd like to validate the region that
+                 ;; we just updated, so we can potentially
+                 ;; avoid a redundant refresh. For some reason,
+                 ;; vadilation can cancel an update that hasn't
+                 ;; happened, yet; this problem needs further
+                 ;; invesitigation.
+                 #;
+                 (ValidateRect canvas-hwnd #f)))))
 
      (define/public (make-compatible-bitmap w h)
        (send dc make-backing-bitmap w h))
 
      (define paint-suspended 0)
+     (define suspended-refresh? #f)
      (define/public (suspend-paint-handling)
        (atomically
         (set! paint-suspended (add1 paint-suspended))))
      (define/public (resume-paint-handling)
        (atomically
         (unless (zero? paint-suspended)
-          (set! paint-suspended (sub1 paint-suspended)))))
+          (set! paint-suspended (sub1 paint-suspended))
+          (when (and (zero? paint-suspended)
+                     suspended-refresh?)
+            (set! suspended-refresh? #f)
+            (InvalidateRect canvas-hwnd #f #f)))))
 
      (define no-autoclear? (memq 'no-autoclear style))
      (define transparent? (memq 'transparent style))