diff --git a/collects/mred/private/mrcanvas.rkt b/collects/mred/private/mrcanvas.rkt index 1a3282ab63..b0259ff57b 100644 --- a/collects/mred/private/mrcanvas.rkt +++ b/collects/mred/private/mrcanvas.rkt @@ -1,8 +1,8 @@ -(module mrcanvas mzscheme +(module mrcanvas racket/base (require mzlib/class mzlib/class100 mzlib/list - (prefix wx: "kernel.ss") + (prefix-in wx: "kernel.ss") "lock.ss" "const.ss" "kw.ss" @@ -103,7 +103,9 @@ (private-field [paint-cb paint-callback] [has-x? (and (list? style) (memq 'hscroll style))] [has-y? (and (list? style) (memq 'vscroll style))]) - (inherit get-client-size get-dc set-label) + (inherit get-client-size get-dc set-label + suspend-flush resume-flush flush + get-canvas-background) (rename [super-on-paint on-paint]) (sequence (let ([cwho '(constructor canvas)]) @@ -196,6 +198,29 @@ (if (eq? paint-cb default-paint-cb) (super-on-paint) (paint-cb this (get-dc))))]) + (private-field [no-clear? (memq 'no-autoclear style)]) + (public + [refresh-now (lambda ([do-paint (lambda (dc) (on-paint))] + #:flush? [flush? #t]) + (let ([dc (get-dc)]) + (dynamic-wind + (lambda () + (suspend-flush)) + (lambda () + (unless no-clear? + (let ([bg (get-canvas-background)]) + (if bg + (let ([old-bg (send dc get-background)]) + (as-entry + (lambda () + (send dc set-background bg) + (send dc clear) + (send dc set-background old-bg)))) + (send dc erase)))) + (do-paint dc)) + (lambda () + (resume-flush))) + (when flush? (flush))))]) (private-field [wx #f]) (sequence diff --git a/collects/scribblings/gui/canvas-class.scrbl b/collects/scribblings/gui/canvas-class.scrbl index 701d4e57d9..eaf7751367 100644 --- a/collects/scribblings/gui/canvas-class.scrbl +++ b/collects/scribblings/gui/canvas-class.scrbl @@ -290,6 +290,22 @@ This method is called only when manual } +@defmethod[(refresh-now [paint-proc ((is-a?/c dc<%>) . -> . any) + (lambda (dc) (send @#,this-obj[] on-paint))] + [#:flush? flush? any/c #t]) + void?]{ + +Calls @racket[paint-proc] with the canvas's drawing context to immediately +update the canvas (in contrast to @method[window<%> refresh], which merely +queues an update request to be handled at the windowing system's discretion). + +Before @racket[paint-proc] is called, flushing is disabled for the +canvas. Also, the canvas is erased, unless the canvas has the +@racket['no-autoclear] style. After @racket[paint-proc] returns, +flushing is enabled, and if @racket[flush?] is true, then +@method[canvas<%> flush] is called immediately.} + + @defmethod[(scroll [h-value (or/c (real-in 0.0 1.0) false/c)] [v-value (or/c (real-in 0.0 1.0) false/c)]) void?]{ diff --git a/collects/scribblings/gui/canvas-intf.scrbl b/collects/scribblings/gui/canvas-intf.scrbl index 2b480d3fb2..e6dbbda4a6 100644 --- a/collects/scribblings/gui/canvas-intf.scrbl +++ b/collects/scribblings/gui/canvas-intf.scrbl @@ -56,7 +56,10 @@ To draw onto a canvas, get its device context via @method[canvas<%> Calling an @method[canvas<%> on-paint] method directly is the same as drawing outside an @method[canvas<%> on-paint] callback - from the windowing system.} + from the windowing system. For a @racket[canvas%], use + @method[canvas% refresh-now] to force an immediate update of + the canvas's content that is otherwise analogous to queueing an + update with @method[window<%> refresh].} ] @@ -72,7 +75,7 @@ is suspended until the outermost @method[canvas<%> suspend-flush] is balanced by a @method[canvas<%> resume-flush]. An @method[canvas<%> on-paint] call from the windowing system is implicitly wrapped with @method[canvas<%> suspend-flush] and @method[canvas<%> resume-flush] -calls. +calls, as is a call to a paint procedure by @method[canvas% refresh-now]. In the case of a transparent canvas, line and text smoothing can depend on the window that serves as the canvas's background. For