diff --git a/collects/mred/private/wx/cocoa/canvas.rkt b/collects/mred/private/wx/cocoa/canvas.rkt index 4add0ce9d3..7abf4dea60 100644 --- a/collects/mred/private/wx/cocoa/canvas.rkt +++ b/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) diff --git a/collects/mred/private/wx/common/canvas-mixin.rkt b/collects/mred/private/wx/common/canvas-mixin.rkt index 2822e41ea8..1dbeb28e70 100644 --- a/collects/mred/private/wx/common/canvas-mixin.rkt +++ b/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) diff --git a/collects/mred/private/wx/common/queue.rkt b/collects/mred/private/wx/common/queue.rkt index 2d0e577625..687d512242 100644 --- a/collects/mred/private/wx/common/queue.rkt +++ b/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 diff --git a/collects/mred/private/wx/gtk/canvas.rkt b/collects/mred/private/wx/gtk/canvas.rkt index 2de985baca..94265bb94e 100644 --- a/collects/mred/private/wx/gtk/canvas.rkt +++ b/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%) diff --git a/collects/mred/private/wx/gtk/queue.rkt b/collects/mred/private/wx/gtk/queue.rkt index e42d3100d9..a37d81eb44 100644 --- a/collects/mred/private/wx/gtk/queue.rkt +++ b/collects/mred/private/wx/gtk/queue.rkt @@ -194,10 +194,12 @@ (thread (lambda () (let loop () (unless (let ([any-tasks? (sync/timeout 0 boundary-tasks-ready-evt)]) - (sync queue-evt (if any-tasks? - (wrap-evt (system-idle-evt) - (lambda (v) #f)) - boundary-tasks-ready-evt))) + (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))) (pre-event-sync #t)) (atomically (dispatch-all-ready)) (loop))))) diff --git a/collects/mred/private/wx/win32/canvas.rkt b/collects/mred/private/wx/win32/canvas.rkt index 6bc0803acd..46fa330885 100644 --- a/collects/mred/private/wx/win32/canvas.rkt +++ b/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))