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

win32: fix canvas flicker

Browse Source
This commit is contained in:
Matthew Flatt 2011-01-04 13:29:28 -07:00
parent 553723627c
commit d2f16ee36e
2 changed files with 45 additions and 22 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

35
collects/games/same/same.rkt
View File

@ -144,13 +144,24 @@
[font (make-object font% 24 'decorative 'normal 'normal #f)] [font (make-object font% 24 'decorative 'normal 'normal #f)]
[turned null]) [turned null])
[define/public (call-with-dc proc)
;; Since we're not in `on-paint', need to manually
;; suspend and resume flushing, so that intermediate
;; states are not flushed to the screen.
(let ([dc (get-dc)])
(send dc suspend-flush)
(proc dc)
(send dc resume-flush))]
[define/private recalc/draw-turned [define/private recalc/draw-turned
(lambda (i j) (lambda (i j)
(set! turned (map (lambda (xx) (list (second xx) (third xx))) (find-same-colors i j))) (set! turned (map (lambda (xx) (list (second xx) (third xx))) (find-same-colors i j)))
(cond (cond
[(> (length turned) 1) [(> (length turned) 1)
(send this-message set-label (number->string (calc-score (length turned)))) (send this-message set-label (number->string (calc-score (length turned))))
(for-each (lambda (p) (draw-cell (get-dc) #t (first p) (second p))) turned)] (call-with-dc
(lambda (dc)
(for-each (lambda (p) (draw-cell dc #t (first p) (second p))) turned)))]
[else [else
(send this-message set-label "")]))] (send this-message set-label "")]))]
@ -169,18 +180,24 @@
(<= 0 j) (< j board-height)) (<= 0 j) (< j board-height))
(unless (member (list i j) turned) (unless (member (list i j) turned)
(when (> (length turned) 1) (when (> (length turned) 1)
(for-each (lambda (p) (draw-cell (get-dc) #f (first p) (second p))) turned)) (call-with-dc
(lambda (dc)
(for-each (lambda (p) (draw-cell dc #f (first p) (second p))) turned))))
(recalc/draw-turned i j))] (recalc/draw-turned i j))]
[else [else
(when (> (length turned) 1) (when (> (length turned) 1)
(for-each (lambda (p) (draw-cell (get-dc) #f (first p) (second p))) turned)) (call-with-dc
(lambda (dc)
(for-each (lambda (p) (draw-cell dc #f (first p) (second p))) turned))))
(set! turned null) (set! turned null)
(send this-message set-label "")])] (send this-message set-label "")])]
[(send evt button-up?) [(send evt button-up?)
(when (and (<= 0 i) (< i board-width) (when (and (<= 0 i) (< i board-width)
(<= 0 j) (< j board-height)) (<= 0 j) (< j board-height))
(when (> (length turned) 1) (when (> (length turned) 1)
(for-each (lambda (p) (draw-cell (get-dc) #f (first p) (second p))) turned)) (call-with-dc
(lambda (dc)
(for-each (lambda (p) (draw-cell dc #f (first p) (second p))) turned))))
(set! turned null) (set! turned null)
(send this-message set-label "") (send this-message set-label "")
(let ([same-colors (find-same-colors i j)]) (let ([same-colors (find-same-colors i j)])
@ -234,13 +251,15 @@
empty-is) empty-is)
;; draw changed lines ;; draw changed lines
(for-each (lambda (i) (draw-line (get-dc) i)) is) (call-with-dc
(lambda (dc)
(for-each (lambda (i) (draw-line dc i)) is)
(unless (null? empty-is) (unless (null? empty-is)
(let loop ([i (car (last-pair empty-is))]) (let loop ([i (car (last-pair empty-is))])
(cond (cond
[(= i board-width) (void)] [(= i board-width) (void)]
[else (draw-line (get-dc) i) [else (draw-line dc i)
(loop (+ i 1))]))) (loop (+ i 1))])))))
;; update `small' balls ;; update `small' balls
(recalc/draw-turned i j) (recalc/draw-turned i j)
@ -266,7 +285,7 @@
(sub1 j) (sub1 j)
(> (length (find-same-colors (sub1 i) (sub1 j))) 1)))]))))])))) (> (length (find-same-colors (sub1 i) (sub1 j))) 1)))]))))]))))
(when game-over? (when game-over?
(paint-game-over (get-dc))))))] (call-with-dc (lambda (dc) (paint-game-over dc)))))))]
[else (void)])))] [else (void)])))]

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

@ -162,6 +162,8 @@
(queue-paint) (queue-paint)
(if (positive? paint-suspended) (if (positive? paint-suspended)
(set! suspended-refresh? #t) (set! suspended-refresh? #t)
(let ([erase
(lambda ()
(let* ([hbrush (if no-autoclear? (let* ([hbrush (if no-autoclear?
#f #f
(if transparent? (if transparent?
@ -171,8 +173,10 @@
(let ([r (GetClientRect canvas-hwnd)]) (let ([r (GetClientRect canvas-hwnd)])
(FillRect hdc r hbrush)) (FillRect hdc r hbrush))
(unless transparent? (unless transparent?
(DeleteObject hbrush))) (DeleteObject hbrush)))))])
(when transparent? (erase))
(unless (do-canvas-backing-flush hdc) (unless (do-canvas-backing-flush hdc)
(unless transparent? (erase))
(queue-paint))))) (queue-paint)))))
(EndPaint w ps))) (EndPaint w ps)))
0] 0]