gtk: periodic canvas flushing

collects/mred/private/wx/cocoa/canvas.rkt

@@ -279,12 +279,20 @@
        (queue-window-refresh-event this  thunk))
 
      (define/public (paint-or-queue-paint)
-       (or (do-backing-flush this dc (tell NSGraphicsContext currentContext)
-                             (if is-combo? 2 0) (if is-combo? 2 0))
+       (or (do-canvas-backing-flush #f)
            (begin
              (queue-paint)
              #f)))
 
+     (define/public (do-canvas-backing-flush ctx)
+       (do-backing-flush this dc (tell NSGraphicsContext currentContext)
+                         (if is-combo? 2 0) (if is-combo? 2 0)))
+
+     ;; not used, because Cocoa canvas refreshes do not go through
+     ;;  the eventspace queue:
+     (define/public (schedule-periodic-backing-flush)
+       (void))
+
      (define/public (begin-refresh-sequence)
        (send dc suspend-flush))
      (define/public (end-refresh-sequence)

collects/mred/private/wx/common/canvas-mixin.rkt

@@ -1,6 +1,7 @@
 #lang racket/base
 (require racket/class
          racket/draw
+         "../common/queue.rkt"
          "backing-dc.rkt")
 
 (provide 
@@ -162,7 +163,28 @@
     (define/override (paint-children)
       (when (or paint-queued
                 (not (send (get-dc) can-backing-flush?)))
-        (do-on-paint #f #f)))))
+        (do-on-paint #f #f)))
+
+
+    (define flush-box #f)
+    
+    ;; Periodic flush is needed for Windows and Gtk, where
+    ;; updates otherwise happen only via the eventspace's queue
+    (define/override (schedule-periodic-backing-flush)
+      (unless flush-box
+        (set! flush-box (box #t))
+        (add-event-boundary-sometimes-callback! 
+         flush-box
+         (lambda (b)
+           (when (unbox b)
+             (do-canvas-backing-flush #f))))))
+
+     (define/override (do-canvas-backing-flush ctx)
+       ;; cancel scheduled flush, if any:
+       (when flush-box 
+         (set-box! flush-box #f) 
+         (set! flush-box #f))
+       (super do-canvas-backing-flush ctx))))
 
 ;; useful for fixing the size of a collecting blit:
 (define (fix-bitmap-size on w h on-x on-y)

collects/mred/private/wx/common/queue.rkt

@@ -18,6 +18,7 @@
               remove-event-boundary-callback!
               pre-event-sync
               boundary-tasks-ready-evt
+              sometimes-delay-msec
 
               eventspace?
               current-eventspace
@@ -127,11 +128,12 @@
    (alert-tasks-ready)))
 
 (define last-time -inf.0)
+(define sometimes-delay-msec 50)
 
 ;; Call this function only in atomic mode:
 (define (pre-event-sync force?)
   (let ([now (current-inexact-milliseconds)])
-    (when (or (now . > . (+ last-time 200)) 
+    (when (or (now . > . (+ last-time sometimes-delay-msec)) 
               force?)
       (set! last-time now)
       (hash-for-each sometimes-boundary-ht 

collects/mred/private/wx/gtk/canvas.rkt

@@ -352,15 +352,22 @@
        (queue-window-refresh-event this thunk))
 
      (define/public (paint-or-queue-paint)
+       ;; in atomic mode
        (if for-gl?
 	   (queue-paint)
-	   (or (do-backing-flush this dc (if is-combo?
-					     (get-subwindow client-gtk)
-					     (widget-window client-gtk)))
+	   (or (do-canvas-backing-flush #f)
 	       (begin
 		 (queue-paint)
 		 #f))))
 
+     ;; overridden to extend for scheduled periodic flushes:
+     (define/public (schedule-periodic-backing-flush)
+       (void))
+     (define/public (do-canvas-backing-flush ctx)
+       (do-backing-flush this dc (if is-combo?
+                                     (get-subwindow client-gtk)
+                                     (widget-window client-gtk))))
+
      (define/public (on-paint) (void))
 
      (define/public (get-flush-window) client-gtk)
@@ -374,9 +381,11 @@
        (queue-paint))
 
      (define/public (queue-backing-flush)
-       ;; called atomically (not expecting exceptions)
+       ;; called atomically
        (unless for-gl?
-         (gtk_widget_queue_draw client-gtk)))
+         (gtk_widget_queue_draw client-gtk)
+         ;; peridodically flush to the screen:
+         (schedule-periodic-backing-flush)))
      
      (define/override (reset-child-dcs)
        (when (dc . is-a? . dc%)

collects/mred/private/wx/gtk/queue.rkt

@@ -194,7 +194,9 @@
   (thread (lambda ()
             (let loop ()
               (unless (let ([any-tasks? (sync/timeout 0 boundary-tasks-ready-evt)])
-                        (sync queue-evt (if any-tasks?
+                        (sync/timeout (and any-tasks? (* sometimes-delay-msec 0.001))
+                                      queue-evt 
+                                      (if any-tasks?
                                           (wrap-evt (system-idle-evt)
                                                     (lambda (v) #f))
                                           boundary-tasks-ready-evt)))

collects/mred/private/wx/win32/canvas.rkt

@@ -168,7 +168,7 @@
                        (FillRect hdc r hbrush))
                      (unless transparent?
                        (DeleteObject hbrush)))
-                   (unless (do-backing-flush this dc hdc)
+                   (unless (do-canvas-backing-flush hdc)
                      (queue-paint)))))
            (EndPaint hdc ps))
          0]
@@ -257,7 +257,15 @@
 
      (define/public (queue-backing-flush)
        (unless for-gl?
-         (InvalidateRect canvas-hwnd #f #f)))
+         (InvalidateRect canvas-hwnd #f #f)
+         (schedule-periodic-backing-flush)))
+
+     ;; overridden to extend for scheduled periodic flushes:
+     (define/public (schedule-periodic-backing-flush)
+       (void))
+     (define/public (do-canvas-backing-flush hdc)
+       (when hdc
+         (do-backing-flush this dc hdc)))
 
      (define/public (make-compatible-bitmap w h)
        (send dc make-backing-bitmap w h))