From 929595edaf93b80e23695c9b22d3bd7e0d743bd3 Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Mon, 1 Nov 2010 16:01:15 -0600
Subject: [PATCH] win32: fix flush and periodic canvas flush

original commit: 64d9a391cfe480fd599910026294cff62cd75ca3
---
 collects/mred/private/wx/win32/canvas.rkt | 8 +++++++-
 collects/mred/private/wx/win32/procs.rkt  | 3 +--
 collects/mred/private/wx/win32/utils.rkt  | 3 +++
 collects/mred/private/wx/win32/window.rkt | 7 ++++++-
 4 files changed, 17 insertions(+), 4 deletions(-)

diff --git a/collects/mred/private/wx/win32/canvas.rkt b/collects/mred/private/wx/win32/canvas.rkt
index 2dc6d0a1..3b9316a4 100644
--- a/collects/mred/private/wx/win32/canvas.rkt
+++ b/collects/mred/private/wx/win32/canvas.rkt
@@ -252,6 +252,11 @@
      (define/public (end-refresh-sequence)
        (send dc resume-flush))
 
+     ;; Improve this method to flush locally
+     ;; instead of globally:
+     (define/public (flush)
+       (flush-display))
+
      (define/public (on-paint) (void))
      (define/override (refresh) (queue-paint))
 
@@ -268,7 +273,8 @@
            (do-backing-flush this dc hdc)
            (let ([hdc (GetDC canvas-hwnd)])
              (do-backing-flush this dc hdc)
-             (ReleaseDC canvas-hwnd hdc))))
+             (ReleaseDC canvas-hwnd hdc)
+             (ValidateRect canvas-hwnd #f))))
 
      (define/public (make-compatible-bitmap w h)
        (send dc make-backing-bitmap w h))
diff --git a/collects/mred/private/wx/win32/procs.rkt b/collects/mred/private/wx/win32/procs.rkt
index 331b9dbf..8ec87a93 100644
--- a/collects/mred/private/wx/win32/procs.rkt
+++ b/collects/mred/private/wx/win32/procs.rkt
@@ -35,7 +35,6 @@
   get-control-font-size
   get-control-font-size-in-pixels?
   cancel-quit
-  flush-display
   bell
   hide-cursor
   get-display-depth
@@ -44,6 +43,7 @@
   get-highlight-background-color
   get-highlight-text-color
   check-for-break)
+ flush-display
  fill-private-color
  play-sound
  location->window
@@ -84,7 +84,6 @@
 (define (get-control-font-face) (get-theme-font-face))
 (define (get-control-font-size) (get-theme-font-size))
 (define (get-control-font-size-in-pixels?) #t)
-(define (flush-display) (void))
 
 (define-user32 MessageBeep (_wfun _UINT -> _BOOL))
 (define (bell)
diff --git a/collects/mred/private/wx/win32/utils.rkt b/collects/mred/private/wx/win32/utils.rkt
index cc519e19..f100116b 100644
--- a/collects/mred/private/wx/win32/utils.rkt
+++ b/collects/mred/private/wx/win32/utils.rkt
@@ -36,6 +36,7 @@
               GetDC
               ReleaseDC
               InvalidateRect
+              ValidateRect
               GetMenuState
               CheckMenuItem
               ModifyMenuW
@@ -121,6 +122,8 @@
 
 (define-user32 InvalidateRect (_wfun _HWND (_or-null _RECT-pointer) _BOOL -> (r : _BOOL)
                                      -> (unless r (failed 'InvalidateRect))))
+(define-user32 ValidateRect (_wfun _HWND (_or-null _RECT-pointer) -> (r : _BOOL)
+                                   -> (unless r (failed 'ValidateRect))))
 
 (define-user32 GetMenuState (_wfun _HMENU _UINT _UINT -> _UINT))
 (define-user32 CheckMenuItem (_wfun _HMENU _UINT _UINT -> _DWORD))
diff --git a/collects/mred/private/wx/win32/window.rkt b/collects/mred/private/wx/win32/window.rkt
index bcd94f97..caca412b 100644
--- a/collects/mred/private/wx/win32/window.rkt
+++ b/collects/mred/private/wx/win32/window.rkt
@@ -24,6 +24,7 @@
               queue-window-event
               queue-window-refresh-event
               location->window
+              flush-display
 
               GetWindowRect
               GetClientRect))
@@ -700,4 +701,8 @@
       (and hwnd
            (or (let ([wx (any-hwnd->wx hwnd)])
                  (and wx (send wx get-top-frame)))
-               (loop (GetParent hwnd)))))))
\ No newline at end of file
+               (loop (GetParent hwnd)))))))
+
+(define (flush-display)
+  (atomically
+   (pre-event-sync #t)))