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

win32: canvas refresh repair

Browse Source
This commit is contained in:
Matthew Flatt 2010-11-13 09:54:14 -07:00
parent 4d2e0e4486
commit d2fe39da33
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) (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 ;; updates otherwise happen only via the eventspace's queue
(define/override (schedule-periodic-backing-flush) (define/override (schedule-periodic-backing-flush)
(unless flush-box (unless flush-box

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

@ -157,19 +157,20 @@
[hdc (BeginPaint w ps)]) [hdc (BeginPaint w ps)])
(if for-gl? (if for-gl?
(queue-paint) (queue-paint)
(unless (positive? paint-suspended) (if (positive? paint-suspended)
(let* ([hbrush (if no-autoclear? (set! suspended-refresh? #t)
#f (let* ([hbrush (if no-autoclear?
(if transparent? #f
background-hbrush (if transparent?
(CreateSolidBrush bg-colorref)))]) background-hbrush
(when hbrush (CreateSolidBrush bg-colorref)))])
(let ([r (GetClientRect canvas-hwnd)]) (when hbrush
(FillRect hdc r hbrush)) (let ([r (GetClientRect canvas-hwnd)])
(unless transparent? (FillRect hdc r hbrush))
(DeleteObject hbrush))) (unless transparent?
(unless (do-canvas-backing-flush hdc) (DeleteObject hbrush)))
(queue-paint))))) (unless (do-canvas-backing-flush hdc)
(queue-paint)))))
(EndPaint hdc ps)) (EndPaint hdc ps))
0] 0]
[(= msg WM_NCPAINT) [(= msg WM_NCPAINT)
@ -271,22 +272,38 @@
(define/public (do-canvas-backing-flush hdc) (define/public (do-canvas-backing-flush hdc)
(if hdc (if hdc
(do-backing-flush this dc hdc) (do-backing-flush this dc hdc)
(let ([hdc (GetDC canvas-hwnd)]) (if (positive? paint-suspended)
(do-backing-flush this dc hdc) ;; suspended => try again later
(ReleaseDC canvas-hwnd hdc) (schedule-periodic-backing-flush)
(ValidateRect canvas-hwnd #f)))) ;; 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) (define/public (make-compatible-bitmap w h)
(send dc make-backing-bitmap w h)) (send dc make-backing-bitmap w h))
(define paint-suspended 0) (define paint-suspended 0)
(define suspended-refresh? #f)
(define/public (suspend-paint-handling) (define/public (suspend-paint-handling)
(atomically (atomically
(set! paint-suspended (add1 paint-suspended)))) (set! paint-suspended (add1 paint-suspended))))
(define/public (resume-paint-handling) (define/public (resume-paint-handling)
(atomically (atomically
(unless (zero? paint-suspended) (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 no-autoclear? (memq 'no-autoclear style))
(define transparent? (memq 'transparent style)) (define transparent? (memq 'transparent style))