manual tests for refresh behavior

collects/meta/props

@@ -1463,6 +1463,7 @@ path/s is either such a string or a list of them.
 "collects/tests/gracket/dc.rktl" drdr:command-line (gracket "-f" *)
 "collects/tests/gracket/draw.rkt" drdr:command-line (mzc *)
 "collects/tests/gracket/editor.rktl" drdr:command-line (gracket "-f" *)
+"collects/tests/gracket/flush-stress.rkt" drdr:command-line #f
 "collects/tests/gracket/gui-main.rktl" drdr:command-line (gracket "-f" *)
 "collects/tests/gracket/gui.rktl" drdr:command-line (gracket "-f" *)
 "collects/tests/gracket/item.rkt" drdr:command-line (mzc *)
@@ -1473,6 +1474,7 @@ path/s is either such a string or a list of them.
 "collects/tests/gracket/random.rktl" drdr:command-line #f
 "collects/tests/gracket/showkey.rkt" drdr:command-line #f
 "collects/tests/gracket/sixlib.rktl" drdr:command-line #f
+"collects/tests/gracket/unflushed-circle.rkt" drdr:command-line #f
 "collects/tests/gracket/test-editor-admin.rkt" drdr:command-line (gracket-text "-t" *)
 "collects/tests/gracket/testing.rktl" drdr:command-line (gracket "-f" *)
 "collects/tests/gracket/text-scale.rktl" drdr:command-line #f

collects/tests/gracket/flush-stress.rkt

@@ -0,0 +1,50 @@
+#lang racket/gui
+
+(define SIZE 600)
+
+(define f (new frame%
+               [label "Color Bars"]
+               [width SIZE]
+               [height SIZE]))
+
+(define c (new canvas% [parent f]))
+
+(send f show #t)
+
+;; If sync is turned off, then expect the drawing
+;; to flicker horribly:
+(define sync? #t)
+
+;; If flush-on-sync is disabled, the expect refresh
+;; to starve, so that the image moves very rarely, if
+;; at all:
+(define flush-on-sync? #t)
+
+(define (start-drawing dc)
+  (when sync?
+    (send dc suspend-flush)))
+
+(define (end-drawing dc)
+  (when sync?
+    (send dc resume-flush)
+    (when flush-on-sync?
+      (send dc flush))))
+
+(define (go)
+  (let ([dc (send c get-dc)])
+    (for ([d (in-naturals)])
+      (start-drawing dc)
+      (send dc erase)
+      ;; Draw somthing slow that changes with d
+      (for ([n (in-range 0 SIZE)])
+        (send dc set-pen 
+              (make-object color% 
+                           (remainder (+ n d) 256)
+                           (remainder (* 2 (+ n d)) 256)
+                           (remainder (* 3 (+ n d)) 256))
+              1
+              'solid)
+        (send dc draw-line n 0 n SIZE))
+      (end-drawing dc))))
+
+(thread go)

collects/tests/gracket/unflushed-circle.rkt

@@ -0,0 +1,43 @@
+#lang racket/gui
+(require racket/math)
+
+;; This test creates a background that draws a circle in changing
+;; colors. It draws in a background thread --- on in response to
+;; `on-paint', and with no flushing controls --- but it should nevertheless
+;; refresh onscreen frequently through an automatic flush.
+
+(define f (new frame%
+               [label "Snake"]
+               [width 400]
+               [height 400]))
+
+(define c (new canvas% [parent f]))
+
+(send f show #t)
+
+(define prev-count 0)
+(define next-time (+ (current-inexact-milliseconds) 1000))
+
+(define (go)
+  (let loop ([n 0])
+    (when ((current-inexact-milliseconds) . > . next-time)
+      (printf "~s\n" (- n prev-count))
+      (set! prev-count n)
+      (set! next-time (+ (current-inexact-milliseconds) 1000)))
+    (let ([p (make-polar 175 (* pi (/ n 100)))]
+          [dc (send c get-dc)])
+      (send dc set-brush 
+            (make-object color% 
+                         (remainder n 256)
+                         (remainder (* 2 n) 256)
+                         (remainder (* 3 n) 256))
+            'solid)
+      (send dc draw-rectangle
+            (+ 180 (real-part p))
+            (+ 180 (imag-part p))
+            20
+            20)
+      (loop (add1 n)))))
+
+(thread go)
+