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

gtk: periodic canvas flushing

Browse Source
This commit is contained in:
Matthew Flatt 2010-11-01 07:58:23 -06:00
parent 9fbb7d3a99
commit 72a19d2ab3
6 changed files with 66 additions and 15 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
collects/mred/private/wx/cocoa/canvas.rkt
View File

@ -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)

24
collects/mred/private/wx/common/canvas-mixin.rkt
View File

@ -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)

4
collects/mred/private/wx/common/queue.rkt
View File

@ -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

19
collects/mred/private/wx/gtk/canvas.rkt
View File

@ -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%)

10
collects/mred/private/wx/gtk/queue.rkt
View File

@ -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)))))

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

@ -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))