diff --git a/collects/mred/private/wx/common/queue.rkt b/collects/mred/private/wx/common/queue.rkt index e05b24238a..e7d5bd630b 100644 --- a/collects/mred/private/wx/common/queue.rkt +++ b/collects/mred/private/wx/common/queue.rkt @@ -93,6 +93,8 @@ (define (add-event-boundary-callback! v proc) (hash-set! boundary-ht v proc)) (define (add-event-boundary-sometimes-callback! v proc) + (when (zero? (hash-count sometimes-boundary-ht)) + (set! last-time (current-inexact-milliseconds))) (hash-set! sometimes-boundary-ht v proc)) (define (remove-event-boundary-callback! v) diff --git a/collects/mred/private/wx/gtk/canvas.rkt b/collects/mred/private/wx/gtk/canvas.rkt index 36061022c6..ec3011a152 100644 --- a/collects/mred/private/wx/gtk/canvas.rkt +++ b/collects/mred/private/wx/gtk/canvas.rkt @@ -4,6 +4,8 @@ racket/draw ffi/unsafe/alloc racket/draw/color + racket/draw/local + "../common/backing-dc.rkt" "../../syntax.rkt" "../common/event.rkt" "utils.rkt" @@ -86,11 +88,11 @@ (_fun _GtkWidget _GdkEventExpose-pointer -> _gboolean) (lambda (gtk event) (let ([wx (gtk->wx gtk)]) - (let ([gc (send wx get-canvas-background-for-clearing)]) - (when gc - (gdk_draw_rectangle (g_object_get_window gtk) gc #t - 0 0 32000 32000))) - (send wx queue-paint)) + (unless (send wx paint-or-queue-paint) + (let ([gc (send wx get-canvas-background-for-clearing)]) + (when gc + (gdk_draw_rectangle (g_object_get_window gtk) gc #t + 0 0 32000 32000))))) #t)) (define-signal-handler connect-expose-border "expose-event" @@ -220,18 +222,7 @@ (set-size x y w h) - (define dc (new dc% - [gtk client-gtk] - [get-client-size (lambda () - (let ([w (box 0)] - [h (box 0)]) - (get-virtual-size w h) - (values (unbox w) (unbox h))))] - [window-lock (send (get-top-win) get-dc-lock)] - [get-window (lambda (client-gtk) - (if is-combo? - (get-subwindow client-gtk) - (g_object_get_window client-gtk)))])) + (define dc (new dc% [canvas this])) (gtk_widget_realize gtk) (gtk_widget_realize client-gtk) @@ -287,15 +278,27 @@ (queue-window-event this (lambda () (set! paint-queued? #f) (set! now-drawing? #t) + (send dc reset-backing-retained) ; clean slate (on-paint) (set! now-drawing? #f) (when refresh-after-drawing? (set! refresh-after-drawing? #f) (refresh)))))) + (define/public (paint-or-queue-paint) + (or (do-backing-flush this dc (if is-combo? + (get-subwindow client-gtk) + (g_object_get_window client-gtk))) + (begin + (queue-paint) + #f))) + (define/public (on-paint) (void)) (define/override (refresh) + (queue-paint)) + + (define/public (queue-backing-flush) (gtk_widget_queue_draw client-gtk)) (define/public (reset-child-dcs) @@ -305,7 +308,10 @@ (register-as-child parent on?) (when on? (reset-child-dcs))) + (send dc start-backing-retained) + (define/private (reset-dc) + (send dc reset-backing-retained) (if auto-scroll? (send dc reset-dc (if virtual-width @@ -314,7 +320,7 @@ (if virtual-height (gtk_adjustment_get_value vscroll-adj) 0)) - (send dc reset-dc 0 0))) + (void))) (define/override (internal-on-client-size w h) (reset-dc)) diff --git a/collects/mred/private/wx/gtk/dc.rkt b/collects/mred/private/wx/gtk/dc.rkt index 5beaf40d55..2836b8f64f 100644 --- a/collects/mred/private/wx/gtk/dc.rkt +++ b/collects/mred/private/wx/gtk/dc.rkt @@ -4,64 +4,72 @@ "utils.rkt" "types.rkt" "../../lock.rkt" + "../common/backing-dc.rkt" racket/draw/cairo racket/draw/dc racket/draw/local ffi/unsafe/alloc) -(provide dc% reset-dc) +(provide dc% + do-backing-flush) (define-gdk gdk_cairo_create (_fun _pointer -> _cairo_t) #:wrap (allocator cairo_destroy)) -(define-local-member-name - reset-dc) +(define dc% + (class backing-dc% + (init [(cnvs canvas)]) + (define canvas cnvs) -(define dc-backend% - (class default-dc-backend% - (init-field gtk - get-client-size - window-lock - [get-window g_object_get_window]) - (inherit reset-cr set-auto-scroll) + (super-new) - (define c #f) - - (define/override (get-cr) - (or c - (let ([w (get-window gtk)]) - (and w - (begin - ;; Under Windows, creating a Cairo context within - ;; a frame inteferes with any other Cairo context - ;; within the same frame. So we use a lock to - ;; serialize drawing to different contexts. - (when window-lock (semaphore-wait window-lock)) - (set! c (gdk_cairo_create w)) - (reset-cr c) - c))))) - - (define/override (release-cr cr) - (when window-lock - (cairo_destroy c) - (set! c #f) - (semaphore-post window-lock))) - - (define/public (reset-dc scroll-dx scroll-dy) - ;; FIXME: ensure that the dc is not in use - (as-entry - (lambda () - (when c - (cairo_destroy c) - (set! c #f)) - (set-auto-scroll scroll-dx scroll-dy)))) + (define/override (get-backing-size xb yb) + (send canvas get-client-size xb yb)) (define/override (get-size) - (let-values ([(w h) (get-client-size)]) - (values (exact->inexact w) - (exact->inexact h)))) - - (super-new))) + (let ([xb (box 0)] + [yb (box 0)]) + (send canvas get-virtual-size xb yb) + (values (unbox xb) (unbox yb)))) -(define dc% - (dc-mixin dc-backend%)) + (define/override (queue-backing-flush) + (send canvas queue-backing-flush)) + + (define suspend-count 0) + (define req #f) + + (define/override (suspend-flush) + (as-entry + (lambda () + #; + (when (zero? suspend-count) + (set! req (request-flush-delay (send canvas get-cocoa-window)))) + (set! suspend-count (add1 suspend-count)) + (super suspend-flush)))) + + (define/override (resume-flush) + (as-entry + (lambda () + (set! suspend-count (sub1 suspend-count)) + #; + (when (and (zero? suspend-count) req) + (cancel-flush-delay req) + (set! req #f)) + (super resume-flush)))))) + +(define (do-backing-flush canvas dc win) + (send dc on-backing-flush + (lambda (bm) + (let ([w (box 0)] + [h (box 0)]) + (send canvas get-client-size w h) + (let ([cr (gdk_cairo_create win)]) + (let ([s (cairo_get_source cr)]) + (cairo_pattern_reference s) + (cairo_set_source_surface cr (send bm get-cairo-surface) 0 0) + (cairo_new_path cr) + (cairo_rectangle cr 0 0 (unbox w) (unbox h)) + (cairo_fill cr) + (cairo_set_source cr s) + (cairo_pattern_destroy s)) + (cairo_destroy cr)))))) diff --git a/collects/mred/private/wxme/editor.rkt b/collects/mred/private/wxme/editor.rkt index bf99cab2cb..4c88b64cd2 100644 --- a/collects/mred/private/wxme/editor.rkt +++ b/collects/mred/private/wxme/editor.rkt @@ -63,7 +63,8 @@ (define/public (set-last-used v) (set! last-used v)) (define/public (ready-offscreen width height) - (if (or (width . > . RIDICULOUS-SIZE) + (if (or #t ; disable on all platforms + (width . > . RIDICULOUS-SIZE) (height . > . RIDICULOUS-SIZE) (eq? (system-type) 'macosx)) #f