diff --git a/collects/mred/private/wx/cocoa/dc.rkt b/collects/mred/private/wx/cocoa/dc.rkt index b739fa88bd..2984ec5fda 100644 --- a/collects/mred/private/wx/cocoa/dc.rkt +++ b/collects/mred/private/wx/cocoa/dc.rkt @@ -27,7 +27,7 @@ (define canvas cnvs) (inherit end-delay) - (super-new) + (super-new [transparent? (not (send canvas get-canvas-background))]) (define gl #f) (define/override (get-gl-context) @@ -89,13 +89,6 @@ (let* ([surface (cairo_quartz_surface_create_for_cg_context cg (unbox w) (unbox h))] [cr (cairo_create surface)]) (cairo_surface_destroy surface) - (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)) + (backing-draw-bm bm cr (unbox w) (unbox h)) (cairo_destroy cr)))))) (tellv ctx restoreGraphicsState))) diff --git a/collects/mred/private/wx/common/backing-dc.rkt b/collects/mred/private/wx/common/backing-dc.rkt index f6c9b3b5a8..d095a8818e 100644 --- a/collects/mred/private/wx/common/backing-dc.rkt +++ b/collects/mred/private/wx/common/backing-dc.rkt @@ -4,11 +4,14 @@ racket/draw/private/bitmap-dc racket/draw/private/bitmap racket/draw/private/local + racket/draw/private/record-dc + racket/draw/unsafe/cairo "../../lock.rkt" "queue.rkt") (provide (protect-out backing-dc% + backing-draw-bm ;; scoped method names: get-backing-size @@ -35,13 +38,19 @@ end-delay) (define backing-dc% - (class (dc-mixin bitmap-dc-backend%) + (class (record-dc-mixin (dc-mixin bitmap-dc-backend%)) + (init transparent?) + (inherit internal-get-bitmap internal-set-bitmap - reset-cr) + reset-cr + set-recording-limit + get-recorded-command) (super-new) + (set-recording-limit (if transparent? 1024 -1)) + (define/override (ok?) #t) ;; Override this method to get the right size @@ -67,7 +76,8 @@ [(not retained-cr) #f] [(positive? retained-counter) (unless nada? - (proc (internal-get-bitmap))) + (proc (or (get-recorded-command) + (internal-get-bitmap)))) #t] [else (reset-backing-retained proc) @@ -155,3 +165,43 @@ (define (release-backing-bitmap bm) (send bm release-bitmap-storage)) + +(define cairo-dc + (make-object (dc-mixin + (class default-dc-backend% + (inherit reset-cr) + + (define cr #f) + (define w 0) + (define h 0) + + (super-new) + + (define/public (set-cr new-cr new-w new-h) + (set! cr new-cr) + (set! w new-w) + (set! h new-h) + (when cr + (reset-cr cr))) + + (define/override (get-cr) cr) + + (define/override (reset-clip cr) + (super reset-clip cr) + (cairo_rectangle cr 0 0 w h) + (cairo_clip cr)))))) + +(define (backing-draw-bm bm cr w h) + (if (procedure? bm) + (begin + (send cairo-dc set-cr cr w h) + (bm cairo-dc) + (send cairo-dc set-cr #f 0 0)) + (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 w h) + (cairo_fill cr) + (cairo_set_source cr s) + (cairo_pattern_destroy s)))) diff --git a/collects/mred/private/wx/gtk/dc.rkt b/collects/mred/private/wx/gtk/dc.rkt index ed66511f35..761285924e 100644 --- a/collects/mred/private/wx/gtk/dc.rkt +++ b/collects/mred/private/wx/gtk/dc.rkt @@ -96,7 +96,7 @@ (inherit end-delay) (define canvas cnvs) - (super-new) + (super-new [transparent? (not (send canvas get-canvas-background))]) (define gl #f) (define/override (get-gl-context) @@ -146,12 +146,5 @@ [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)) + (backing-draw-bm bm cr (unbox w) (unbox h)) (cairo_destroy cr)))))) diff --git a/collects/mred/private/wx/win32/dc.rkt b/collects/mred/private/wx/win32/dc.rkt index db260240a8..b561e8f566 100644 --- a/collects/mred/private/wx/win32/dc.rkt +++ b/collects/mred/private/wx/win32/dc.rkt @@ -67,7 +67,7 @@ (inherit end-delay) (define canvas cnvs) - (super-new) + (super-new [transparent? (not (send canvas get-canvas-background))]) (define gl #f) (define/override (get-gl-context) @@ -116,14 +116,7 @@ (let* ([surface (cairo_win32_surface_create hdc)] [cr (cairo_create surface)]) (cairo_surface_destroy surface) - (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)) + (backing-draw-bm cr bm (unbox w) (unbox h)) (cairo_destroy cr)))))) (define (request-flush-delay canvas) diff --git a/collects/racket/draw/private/record-dc.rkt b/collects/racket/draw/private/record-dc.rkt index 80ce418ef2..fa42000784 100644 --- a/collects/racket/draw/private/record-dc.rkt +++ b/collects/racket/draw/private/record-dc.rkt @@ -1,6 +1,7 @@ #lang racket/base (require "syntax.rkt" racket/class + ffi/unsafe/atomic "dc.rkt" "bitmap.rkt" "bitmap-dc.rkt" @@ -14,11 +15,13 @@ (provide record-dc-mixin get-recorded-command - reset-recording) + reset-recording + set-recording-limit) (define-local-member-name get-recorded-command - reset-recording) + reset-recording + set-recording-limit) (define black (send the-color-database find-color "black")) @@ -91,6 +94,14 @@ (class % (super-new) + (define record-limit +inf.0) + (define current-size 0) + + (define/public (set-recording-limit amt) + (set! record-limit amt)) + (define/private (continue-recording?) + (current-size . < . record-limit)) + (define-syntax-rule (define/record (name arg ...)) (define/override (name arg ...) (super name arg ...) @@ -98,16 +109,24 @@ (define procs null) (define/private (record proc) - (set! procs (cons proc procs))) + (when (continue-recording?) + (start-atomic) + (set! current-size (add1 current-size)) + (set! procs (cons proc procs)) + (end-atomic))) (define/public (get-recorded-command) - (let ([procs (reverse procs)]) - (lambda (dc) - (for ([proc (in-list procs)]) - (proc dc))))) + (and (continue-recording?) + (let ([procs (reverse procs)]) + (lambda (dc) + (for ([proc (in-list procs)]) + (proc dc)))))) (define/public (reset-recording) - (set! procs null)) + (start-atomic) + (set! procs null) + (set! current-size 0) + (end-atomic)) (define clones (make-hasheq)) (define/private (clone clone-x x) @@ -127,18 +146,21 @@ (define/override (transform mi) (super transform mi) - (let ([mi (vector->immutable-vector mi)]) - (record (lambda (dc) (send dc transform mi))))) + (when (continue-recording?) + (let ([mi (vector->immutable-vector mi)]) + (record (lambda (dc) (send dc transform mi)))))) (define/override (set-initial-matrix mi) (super set-initial-matrix mi) - (let ([mi (vector->immutable-vector mi)]) - (record (lambda (dc) (send dc set-initial-matrix mi))))) + (when (continue-recording?) + (let ([mi (vector->immutable-vector mi)]) + (record (lambda (dc) (send dc set-initial-matrix mi)))))) (define/override (set-transformation mi) (super set-transformation mi) - (let ([mi (vector->immutable-vector mi)]) - (record (lambda (dc) (send dc set-transformation mi))))) + (when (continue-recording?) + (let ([mi (vector->immutable-vector mi)]) + (record (lambda (dc) (send dc set-transformation mi)))))) (define/record (set-smoothing s)) @@ -153,32 +175,37 @@ (define/override (do-set-brush! b) (super do-set-brush! b) - (let ([b (clone clone-brush b)]) - (record (lambda (dc) (send dc do-set-brush! b))))) + (when (continue-recording?) + (let ([b (clone clone-brush b)]) + (record (lambda (dc) (send dc do-set-brush! b)))))) (define/override (set-text-foreground c) (super set-text-foreground c) - (let ([c (clone clone-color c)]) - (record (lambda (dc) (send dc set-text-foreground c))))) + (when (continue-recording?) + (let ([c (clone clone-color c)]) + (record (lambda (dc) (send dc set-text-foreground c)))))) (define/override (set-text-background c) (super set-text-background c) - (let ([c (clone clone-color c)]) - (record (lambda (dc) (send dc set-text-background c))))) + (when (continue-recording?) + (let ([c (clone clone-color c)]) + (record (lambda (dc) (send dc set-text-background c)))))) (define/override (set-background c) (super set-background c) - (let ([c (clone clone-color c)]) - (record (lambda (dc) (send dc set-background c))))) + (when (continue-recording?) + (let ([c (clone clone-color c)]) + (record (lambda (dc) (send dc set-background c)))))) (define/record (set-text-mode m)) (define/override (set-clipping-region r) (super set-clipping-region r) - (let ([make-r (if r - (region-maker r) - (lambda (dc) #f))]) - (record (lambda (dc) (send dc set-clipping-region (make-r dc)))))) + (when (continue-recording?) + (let ([make-r (if r + (region-maker r) + (lambda (dc) #f))]) + (record (lambda (dc) (send dc set-clipping-region (make-r dc))))))) (define/record (set-clipping-rect x y w h)) @@ -186,7 +213,7 @@ (define/override (erase) (super erase) - (set! procs null)) + (reset-recording)) (define/record (draw-arc x y width height @@ -200,13 +227,15 @@ (define/override (draw-lines pts [x 0.0] [y 0.0]) (super draw-lines pts x y) - (let ([pts (map (lambda (p) (clone clone-point p)) pts)]) - (record (lambda (dc) (send dc draw-lines pts x y))))) + (when (continue-recording?) + (let ([pts (map (lambda (p) (clone clone-point p)) pts)]) + (record (lambda (dc) (send dc draw-lines pts x y)))))) (define/override (draw-polygon pts [x 0.0] [y 0.0] [fill-style 'odd-even]) (super draw-polygon pts x y fill-style) - (let ([pts (map (lambda (p) (clone clone-point p)) pts)]) - (record (lambda (dc) (send dc draw-polygon pts x y fill-style))))) + (when (continue-recording?) + (let ([pts (map (lambda (p) (clone clone-point p)) pts)]) + (record (lambda (dc) (send dc draw-polygon pts x y fill-style)))))) (define/record (draw-rectangle x y w h)) @@ -218,16 +247,26 @@ (define/override (draw-path path [x 0.0] [y 0.0] [fill-style 'odd-even]) (super draw-path path x y fill-style) - (let ([path (clone clone-path path)]) - (record (lambda (dc) (send dc draw-path path x y fill-style))))) + (when (continue-recording?) + (let ([path (clone clone-path path)]) + (record (lambda (dc) (send dc draw-path path x y fill-style)))))) (define/override (draw-text s x y [combine? #f] [offset 0] [angle 0.0]) (super draw-text s x y combine? offset angle) - (let ([s (string->immutable-string s)]) - (record (lambda (dc) (send dc draw-text s x y combine? offset angle))))) + (when (continue-recording?) + (let ([s (string->immutable-string s)]) + (record (lambda (dc) (send dc draw-text s x y combine? offset angle)))))) + + (define/override (draw-bitmap src dx dy [style 'solid] [color black] [mask #f]) + (super draw-bitmap src dx dy style color mask) + (when (continue-recording?) + (let ([src (clone clone-bitmap src)] + [mask (and mask (clone clone-bitmap mask))]) + (record (lambda (dc) (send dc draw-bitmap src dx dy style color mask)))))) (define/override (draw-bitmap-section src dx dy sx sy sw sh [style 'solid] [color black] [mask #f]) (super draw-bitmap-section src dx dy sx sy sw sh style color mask) - (let ([src (clone clone-bitmap src)] - [mask (and mask (clone clone-bitmap mask))]) - (record (lambda (dc) (send dc draw-bitmap-section src dx dy sx sy sw sh style color mask))))))) + (when (continue-recording?) + (let ([src (clone clone-bitmap src)] + [mask (and mask (clone clone-bitmap mask))]) + (record (lambda (dc) (send dc draw-bitmap-section src dx dy sx sy sw sh style color mask)))))))) diff --git a/collects/scribblings/gui/canvas-class.scrbl b/collects/scribblings/gui/canvas-class.scrbl index be13bbe9ad..43d1da291f 100644 --- a/collects/scribblings/gui/canvas-class.scrbl +++ b/collects/scribblings/gui/canvas-class.scrbl @@ -55,8 +55,9 @@ The @scheme[style] argument indicates one or more of the following styles: canvas before calls to @method[canvas% on-paint]} @item{@scheme['transparent] --- the canvas is automatically ``erased'' - before an update using it's parent window's background; the result is - undefined if this flag is combined with @scheme['no-autoclear]} + before an update using it's parent window's background; see @racket[canvas<%>] + for information on the interaction of @racket['transparent] and offscreen buffering; + the result is undefined if this flag is combined with @scheme['no-autoclear]} @item{@scheme['no-focus] --- prevents the canvas from accepting the keyboard focus when the canvas is clicked, or when the diff --git a/collects/scribblings/gui/canvas-intf.scrbl b/collects/scribblings/gui/canvas-intf.scrbl index e802de7772..411d9b8f5d 100644 --- a/collects/scribblings/gui/canvas-intf.scrbl +++ b/collects/scribblings/gui/canvas-intf.scrbl @@ -6,9 +6,6 @@ A canvas is a subwindow onto which graphics and text can be drawn. Canvases also receive mouse and keyboard events. -To draw onto a canvas, get its device context (see -@method[canvas<%> get-dc]). - The @scheme[canvas<%>] interface is implemented by two classes: @itemize[ @@ -20,6 +17,28 @@ The @scheme[canvas<%>] interface is implemented by two classes: ] +To draw onto a canvas, get its device context (see +@method[canvas<%> get-dc]). + +Drawing to a canvas's drawing context actually renders into an +offscreen buffer. The buffer is automatically flushed to the screen by +a background thread, explicitly via the @method[canvas<%> flush] +method, or explicitly via @racket[flush-display]---unless flushing +has been disabled for the canvas. The @method[canvas<%> +suspend-flush] method suspends flushing for a canvas until a matching +@method[canvas<%> resume-flush] calls; calls to @method[canvas<%> +suspend-flush] and @method[canvas<%> resume-flush] can be nested, in +which case flushing is suspended until the outermost @method[canvas<%> +suspend-flush] is balanced by a @method[canvas<%> resume-flush]. + +In the case of a transparent canvas (i.e., one that is created with +@racket['transparent] style), line and text smoothing can depend on +the window that serves as the canvas's background. For example, +smoothing may color pixels differently depending on whether the target +context is white or gray. Background-sensitive smoothing is supported +only if a relatively small number of drawing commands are recorded in +the canvas's offscreen buffer, however. + @defmethod*[([(accept-tab-focus) boolean?] @@ -191,7 +210,7 @@ Does nothing. @defmethod[(resume-flush) void?]{ -See @method[canvas<%> suspend-flush].} +See @racket[canvas<%>] for information on canvas flushing.} @@ -223,19 +242,10 @@ Under Mac OS X, enables or disables space for a resize tab at the @defmethod[(suspend-flush) void?]{ -Drawing to a canvas's drawing context actually renders into an -offscreen buffer. The buffer is automatically flushed to the screen by -a background thread, explicitly via the @method[canvas<%> flush] method, -or explicitly via @racket[flush-display] --- unless flushing has been disabled for the canvas. -The @method[canvas<%> suspend-flush] method suspends flushing for a -canvas until a matching @method[canvas<%> resume-flush] calls; calls to -@method[canvas<%> suspend-flush] and @method[canvas<%> resume-flush] can -be nested, in which case flushing is suspended until the outermost -@method[canvas<%> suspend-flush] is balanced by a @method[canvas<%> -resume-flush]. +See @racket[canvas<%>] for information on canvas flushing. -On some platforms, beware that suspending flushing for a canvas can -discourage refreshes for other windows in the same frame.} +Beware that suspending flushing for a canvas can discourage refreshes +for other windows in the same frame on some platforms.} @defmethod[(warp-pointer [x (integer-in 0 10000)] diff --git a/collects/scribblings/gui/editor-canvas-class.scrbl b/collects/scribblings/gui/editor-canvas-class.scrbl index f0bf858935..4b6e24bd53 100644 --- a/collects/scribblings/gui/editor-canvas-class.scrbl +++ b/collects/scribblings/gui/editor-canvas-class.scrbl @@ -71,7 +71,9 @@ The @scheme[style] list can contain the following flags: method} @item{@scheme['transparent] --- the canvas is ``erased'' before an - update using its parent window's background} + update using its parent window's background; see @racket[canvas<%>] + for information on the interaction of @racket['transparent] and + offscreen buffering} ]