suzanne.soy/gui
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

win32: canvas refresh repair

Browse Source 
original commit: d2fe39da339c06c3f7edfe57ea53e5543101957b
This commit is contained in:
Matthew Flatt 2010-11-13 09:54:14 -07:00
parent f7297e95fe
commit 95048b2dca
2 changed files with 36 additions and 19 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/mred/private/wx/common/canvas-mixin.rkt
View File

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

53
collects/mred/private/wx/win32/canvas.rkt
View File

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