From aac7e0b58a2dd7a5e964785b0162ab48c9081c8f Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 19 Sep 2010 19:17:58 -0600 Subject: [PATCH] extend `invalidate-bitmap-cache' in `editor<%>' with 'display-end option which the framework's background-rectangle implementation can use to queue refreshes for changing rectangles, instead of requiring a full-canvas refresh --- collects/framework/private/text.rkt | 131 ++++++--------------- collects/mred/private/wxme/pasteboard.rkt | 73 ++++++------ collects/mred/private/wxme/text.rkt | 38 +++--- collects/scribblings/gui/editor-intf.scrbl | 12 +- 4 files changed, 105 insertions(+), 149 deletions(-) diff --git a/collects/framework/private/text.rkt b/collects/framework/private/text.rkt index 9fd0cbc990..72d5bbb11b 100644 --- a/collects/framework/private/text.rkt +++ b/collects/framework/private/text.rkt @@ -144,98 +144,45 @@ WARNING: printf is rebound in the body of the unit to always (send (get-style-list) find-named-style "Standard")) (define/private (invalidate-rectangles rectangles) - (let ([b1 (box 0)] - [b2 (box 0)] - [b3 (box 0)] - [b4 (box 0)] - [canvases (get-canvases)]) - (let-values ([(min-left max-right) - (cond - [(null? canvases) - (let ([admin (get-admin)]) - (if admin - (begin - (send admin get-view b1 b2 b3 b4) - (let* ([this-left (unbox b1)] - [this-width (unbox b3)] - [this-right (+ this-left this-width)]) - (values this-left - this-right))) - (values #f #f)))] - [else - (let loop ([left #f] - [right #f] - [canvases canvases]) - (cond - [(null? canvases) - (values left right)] - [else - (let-values ([(this-left this-right) - (send (car canvases) - call-as-primary-owner - (λ () - (send (get-admin) get-view b1 b2 b3 b4) - (let* ([this-left (unbox b1)] - [this-width (unbox b3)] - [this-right (+ this-left this-width)]) - (values this-left - this-right))))]) - (if (and left right) - (loop (min this-left left) - (max this-right right) - (cdr canvases)) - (loop this-left - this-right - (cdr canvases))))]))])]) - (when (and min-left max-right) - (let loop ([left #f] - [top #f] - [right #f] - [bottom #f] - [rectangles rectangles] - [refresh? #f]) - (cond - [(null? rectangles) - (when left - (let ([width (- right left)] - [height (- bottom top)]) - (when refresh? - (for-each (λ (canvas) (send canvas refresh)) - canvases)) - (when (and (> width 0) - (> height 0)) - (invalidate-bitmap-cache left top width height))))] - [else (let* ([r (car rectangles)] - - [adjust (λ (w f) - (+ w (f (case (rectangle-style r) - [(dot hollow-ellipse) 8] - [else 0]))))] - [this-left (if (number? (rectangle-left r)) - (adjust (rectangle-left r) -) - min-left)] - [this-right (if (number? (rectangle-right r)) - (adjust (rectangle-right r) +) - max-right)] - [this-top (adjust (rectangle-top r) -)] - [this-bottom (adjust (rectangle-bottom r) +)]) - (if (and left top right bottom) - (loop (min this-left left) - (min this-top top) - (max this-right right) - (max this-bottom bottom) - (cdr rectangles) - (or refresh? - (not (number? (rectangle-left r))) - (not (number? (rectangle-right r))))) - (loop this-left - this-top - this-right - this-bottom - (cdr rectangles) - (or refresh? - (not (number? (rectangle-left r))) - (not (number? (rectangle-right r)))))))])))))) + (let loop ([left #f] + [top #f] + [right #f] + [bottom #f] + [rectangles rectangles]) + (cond + [(null? rectangles) + (when left + (let ([width (if (number? right) (- right left) 'display-end)] + [height (if (number? bottom) (- bottom top) 'display-end)]) + (when (and (or (symbol? width) (> width 0)) + (or (symbol? height) (> height 0))) + (invalidate-bitmap-cache left top width height))))] + [else (let* ([r (car rectangles)] + [adjust (λ (w f) + (+ w (f (case (rectangle-style r) + [(dot hollow-ellipse) 8] + [else 0]))))] + [this-left (if (number? (rectangle-left r)) + (adjust (rectangle-left r) -) + 0.0)] + [this-right (if (number? (rectangle-right r)) + (adjust (rectangle-right r) +) + 'display-end)] + [this-top (adjust (rectangle-top r) -)] + [this-bottom (adjust (rectangle-bottom r) +)]) + (if (and left top right bottom) + (loop (min this-left left) + (min this-top top) + (if (and (number? this-right) (number? right)) + (max this-right right) + 'display-end) + (max this-bottom bottom) + (cdr rectangles)) + (loop this-left + this-top + this-right + this-bottom + (cdr rectangles))))]))) (define/private (recompute-range-rectangles) (let* ([b1 (box 0)] diff --git a/collects/mred/private/wxme/pasteboard.rkt b/collects/mred/private/wxme/pasteboard.rkt index 4c07fd665a..0d9a76bf42 100644 --- a/collects/mred/private/wxme/pasteboard.rkt +++ b/collects/mred/private/wxme/pasteboard.rkt @@ -137,8 +137,10 @@ (define update-left 0.0) (define update-right 0.0) + (define update-right-end #f) (define update-top 0.0) (define update-bottom 0.0) + (define update-bottom-end #f) (define update-nonempty? #f) (define no-implicit-update? #f) @@ -1409,8 +1411,8 @@ delayedscroll-x delayedscroll-y delayedscroll-w delayedscroll-h #t delayedscrollbias))) - (let ([r (+ x w)] - [b (+ y h)]) + (let ([r (if (symbol? w) x (+ x w))] + [b (if (symbol? h) y (+ y h))]) (let ([x (max x 0.0)] [y (max y 0.0)] [r (max r 0.0)] @@ -1422,51 +1424,42 @@ (begin (set! update-top y) (set! update-left x) - (set! update-bottom (if (h . < . 0) h b)) - (set! update-right (if (w . < . 0) w r)) + (set! update-bottom b) + (set! update-bottom-end (and (symbol? h) h)) + (set! update-right r) + (set! update-right-end (and (symbol? w) w)) (set! update-nonempty? #t)) (begin (set! update-top (min y update-top)) (set! update-left (min x update-left)) - (let ([ub (if (and (h . < . 0) (update-bottom . > . 0)) - (- update-bottom) - update-bottom)]) - (set! update-bottom - (if (ub . < . 0) - (if (and (h . < . 0) (h . < . ub)) - h - (if (and (h . > . 0) - ((- b) . < . ub)) - (- b) - ub)) - (max b ub)))) - (let ([ur (if (and (w . < . 0) (update-right . > . 0)) - (- update-right) - update-right)]) - (set! update-right - (if (ur . < . 0) - (if (and (w . < . 0) (w . < . ur)) - w - (if (and (w . > . 0) - ((- r) . < . ur)) - (- r) - ur)) - (max r ur)))))) + (set! update-bottom (max b update-bottom)) + (when (symbol? b) + (if (eq? b 'display-end) + (set! update-bottom-end 'display-end) + (unless (eq? update-bottom-end 'display-end) + (set! update-bottom-end 'end)))) + (set! update-right (max r update-right)) + (when (symbol? r) + (if (eq? r 'display-end) + (set! update-right-end 'display-end) + (unless (eq? update-right-end 'display-end) + (set! update-right-end 'end)))))) (unless (or (positive? sequence) (not s-admin) flow-locked?) (check-recalc) - (when (update-bottom . < . 0) - (set! update-bottom (- update-bottom)) - (when (update-bottom . < . real-height) - (set! update-bottom real-height))) - - (when (update-right . < . 0) - (set! update-right (- update-right)) - (when (update-right . < . real-width) - (set! update-right real-width))) + (let-boxes ([vx 0.0] [vy 0.0] [vw 0.0] [vh 0.0]) + (when (or (eq? update-bottom-end 'display-end) + (eq? update-right-end 'display-end)) + (send s-admin get-max-view x y w h)) + (case update-bottom-end + [(end) (set! update-bottom (max update-bottom real-height))] + [(display-end) (set! update-bottom (max update-bottom vh))]) + (case update-right-end + [(end) (set! update-right (max update-right real-width))] + [(display-end) (set! update-right (max update-right vw))])) (set! update-nonempty? #f) @@ -1520,9 +1513,9 @@ (def/override (invalidate-bitmap-cache [real? [x 0.0]] [real? [y 0.0]] - [(make-alts nonnegative-real? (symbol-in end)) [w 'end]] - [(make-alts nonnegative-real? (symbol-in end)) [h 'end]]) - (update x y (if (symbol? w) -1.0 w) (if (symbol? h) -1.0 h))) + [(make-alts nonnegative-real? (symbol-in end display-end)) [w 'end]] + [(make-alts nonnegative-real? (symbol-in end display-end)) [h 'end]]) + (update x y w h)) ;; ---------------------------------------- diff --git a/collects/mred/private/wxme/text.rkt b/collects/mred/private/wxme/text.rkt index f932224d08..978bb8a360 100644 --- a/collects/mred/private/wxme/text.rkt +++ b/collects/mred/private/wxme/text.rkt @@ -277,8 +277,8 @@ (define refresh-end 0) (define refresh-l 0.0) (define refresh-t 0.0) - (define refresh-r 0.0) - (define refresh-b 0.0) + (define refresh-r 0.0) ; can be 'display-end + (define refresh-b 0.0) ; can be 'display-end (define last-draw-l 0.0) (define last-draw-t 0.0) @@ -3908,8 +3908,8 @@ #t)))) (define/public (refresh-box L T w h) - (let ([B (+ T h)] - [R (+ L w)]) + (let ([B (if (eq? h 'display-end) h (+ T h))] + [R (if (eq? w 'display-end) w (+ L w))]) (if refresh-box-unset? (begin (set! refresh-l L) @@ -3920,11 +3920,13 @@ (begin (when (L . < . refresh-l) (set! refresh-l L)) - (when (R . > . refresh-r) + (when (or (eq? R 'display-end) + (R . > . refresh-r)) (set! refresh-r R)) (when (T . < . refresh-t) (set! refresh-t T)) - (when (B . > . refresh-b) + (when (or (eq? B 'display-end) + (B . > . refresh-b)) (set! refresh-b B)))) (set! draw-cached-in-bitmap? #f))) @@ -3943,10 +3945,10 @@ (def/override (invalidate-bitmap-cache [real? [x 0.0]] [real? [y 0.0]] - [(make-alts nonnegative-real? (symbol-in end)) [w 'end]] - [(make-alts nonnegative-real? (symbol-in end)) [h 'end]]) - (let ([w (if (symbol? w) (- total-width x) w)] - [h (if (symbol? h) (- total-height y) h)]) + [(make-alts nonnegative-real? (symbol-in end display-end)) [w 'end]] + [(make-alts nonnegative-real? (symbol-in end display-end)) [h 'end]]) + (let ([w (if (eq? w 'end) (- total-width x) w)] + [h (if (eq? h 'end) (- total-height y) h)]) (refresh-box x y w h) (when (zero? delay-refresh) @@ -4809,9 +4811,13 @@ (values left right top bottom) (values (max refresh-l left) - (min refresh-r right) + (if (eq? refresh-r 'display-end) + right + (min refresh-r right)) (max refresh-t top) - (min refresh-b bottom)))]) + (if (eq? refresh-b 'display-end) + bottom + (min refresh-b bottom))))]) (set! refresh-unset? #t) (set! refresh-box-unset? #t) (set! refresh-all? #f) @@ -4884,8 +4890,12 @@ #t)) (values (max refresh-l left) (max top refresh-t) - (min right refresh-r) - (min bottom refresh-b) + (if (eq? refresh-r 'display-end) + right + (min right refresh-r)) + (if (eq? refresh-b 'display-end) + bottom + (min bottom refresh-b)) #t)) (values left top right bottom refresh-all?))]) diff --git a/collects/scribblings/gui/editor-intf.scrbl b/collects/scribblings/gui/editor-intf.scrbl index 5134b7e240..cf63072165 100644 --- a/collects/scribblings/gui/editor-intf.scrbl +++ b/collects/scribblings/gui/editor-intf.scrbl @@ -1006,8 +1006,8 @@ See also @method[editor<%> insert-file]. @defmethod[(invalidate-bitmap-cache [x real? 0.0] [y real? 0.0] - [width (or/c (and/c real? (not/c negative?)) 'end) 'end] - [height (or/c (and/c real? (not/c negative?)) 'end) 'end]) + [width (or/c (and/c real? (not/c negative?)) 'end 'display-end) 'end] + [height (or/c (and/c real? (not/c negative?)) 'end 'display-end) 'end]) void?]{ When @method[editor<%> on-paint] is overridden, call this method when @@ -1018,7 +1018,13 @@ The @scheme[x], @scheme[y], @scheme[width], and @scheme[height] coordinates. If @scheme[width]/@scheme[height] is @scheme['end], then the total height/width of the editor (as reported by @method[editor<%> get-extent]) is used. Note that the editor's size - can be smaller than the visible region of its @techlink{display}. + can be smaller than the visible region of its @techlink{display}. If + @scheme[width]/@scheme[height] is @scheme['display-end], then the + largest height/width of the editor's views (as reported by + @method[editor-admin% get-max-view]) is used. If + @scheme[width]/@scheme[height] is not @scheme['display-end], then + the given @scheme[width]/@scheme[height] is constrained to the + editor's size. The default implementation triggers a redraw of the editor, either immediately or at the end of the current edit sequence (if any)