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

add dc<%> copy method; speed text drawing a little and implement but disable editor scrolling with dc<%> copy

Browse Source
This commit is contained in:
Matthew Flatt 2010-09-14 19:27:46 -06:00
parent ed2c685a73
commit 4bd84adb3a
3 changed files with 138 additions and 48 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

110
collects/mred/private/wxme/editor-canvas.rkt
View File

@ -440,13 +440,14 @@
(let-boxes ([x 0] (let-boxes ([x 0]
[y 0]) [y 0])
(get-scroll x y) (get-scroll x y)
(let ([y (max (+ y (let ([old-y y]
[y (max (+ y
(* wheel-amt (* wheel-amt
(if (eq? code 'wheel-up) (if (eq? code 'wheel-up)
-1 -1
1))) 1)))
0)]) 0)])
(do-scroll x y #t))))] (do-scroll x y #t x old-y))))]
[else [else
(when (and media (not (send media get-printing))) (when (and media (not (send media get-printing)))
(using-admin (using-admin
@ -490,7 +491,7 @@
(when (not (send media get-printing)) (when (not (send media get-printing))
(let-boxes ([x 0][y 0][w 0][h 0]) (let-boxes ([x 0][y 0][w 0][h 0])
(get-view x y w h) (get-view x y w h)
(redraw x y w h))) (redraw x y w h #f)))
(let ([bg (get-canvas-background)]) (let ([bg (get-canvas-background)])
(when bg (when bg
(let ([adc (get-dc)]) (let ([adc (get-dc)])
@ -538,28 +539,31 @@
(let-boxes ([x 0] (let-boxes ([x 0]
[y 0]) [y 0])
(get-scroll x y) (get-scroll x y)
(when fx (convert-scroll-to-location x y fx fy)))
(set-box! fx (- (* x hpixels-per-scroll) xmargin)))
(when fy
(if (and media
(or (positive? y)
scroll-bottom-based?))
(let ([v (- (if (send media locked-for-read?)
0.0
(send media scroll-line-location (+ y scroll-offset)))
ymargin)])
(set-box! fy v)
(when (and scroll-bottom-based?
(or (positive? scroll-height)
scroll-to-last?))
(let-boxes ([w 0] [h 0])
(get-client-size w h)
(let ([h (max (- h (* 2 ymargin))
0)])
(set-box! fy (- (unbox fy) h))))))
(set-box! fy (- ymargin))))))
(get-dc)) (get-dc))
(define/private (convert-scroll-to-location x y fx fy)
(when fx
(set-box! fx (- (* x hpixels-per-scroll) xmargin)))
(when fy
(if (and media
(or (positive? y)
scroll-bottom-based?))
(let ([v (- (if (send media locked-for-read?)
0.0
(send media scroll-line-location (+ y scroll-offset)))
ymargin)])
(set-box! fy v)
(when (and scroll-bottom-based?
(or (positive? scroll-height)
scroll-to-last?))
(let-boxes ([w 0] [h 0])
(get-client-size w h)
(let ([h (max (- h (* 2 ymargin))
0)])
(set-box! fy (- (unbox fy) h))))))
(set-box! fy (- ymargin)))))
(define/public (get-view fx fy fw fh [unused-full? #f]) (define/public (get-view fx fy fw fh [unused-full? #f])
(let ([w (box 0)] (let ([w (box 0)]
[h (box 0)]) [h (box 0)])
@ -574,10 +578,21 @@
(when fw (when fw
(set-box! fw (max 0 (- (unbox w) (* 2 xmargin))))))) (set-box! fw (max 0 (- (unbox w) (* 2 xmargin)))))))
(define/public (redraw localx localy fw fh) (define/public (redraw localx localy fw fh clear?)
(when (and media (when (and media
(not (send media get-printing))) (not (send media get-printing)))
(begin-refresh-sequence) (begin-refresh-sequence)
(when clear?
(let ([bg (get-canvas-background)])
(when bg
(let ([adc (get-dc)])
(let ([b (send adc get-brush)]
[p (send adc get-pen)])
(send adc set-brush bg 'solid)
(send adc set-pen bg 1 'transparent)
(send adc draw-rectangle localx localy fw fh)
(send adc set-brush b)
(send adc set-pen p))))))
(let ([x (box 0)] (let ([x (box 0)]
[y (box 0)] [y (box 0)]
[w (box 0)] [w (box 0)]
@ -694,7 +709,7 @@
(send hscroll set-value sx)) (send hscroll set-value sx))
(when vscroll (when vscroll
(send vscroll set-value sy)) (send vscroll set-value sy))
(do-scroll sx sy refresh?) (do-scroll sx sy refresh? cx cy)
#t) #t)
#f))))))))) #f)))))))))
@ -863,7 +878,7 @@
retval))))))) retval)))))))
(define/private (do-scroll x y refresh?) (define/private (do-scroll x y refresh? old-x old-y)
(let ([savenoloop? noloop?]) (let ([savenoloop? noloop?])
(set! noloop? #t) (set! noloop? #t)
@ -878,8 +893,45 @@
(set-scroll-pos 'vertical (->long (min y scroll-height))))) (set-scroll-pos 'vertical (->long (min y scroll-height)))))
(set! noloop? savenoloop?) (set! noloop? savenoloop?)
(when refresh? (repaint)))) (when refresh?
(if (and #f ;; special scrolling disabled: not faster with Cocoa, broken for Gtk
(not need-refresh?)
(not lazy-refresh?)
(get-canvas-background)
(= x old-x)) ; could handle horizontal scrolling in the future
(let-boxes ([fx 0]
[old-fy 0]
[new-fy 0])
(begin
(convert-scroll-to-location x y fx new-fy)
(convert-scroll-to-location old-x old-y #f old-fy))
(let-boxes ([vx 0][vy 0][vw 0][vh 0])
(get-view vx vy vw vh) ; editor coords
(cond
[(and (new-fy . < . old-fy)
(old-fy . < . (+ new-fy vh)))
(let ([dc (get-dc)])
(send dc copy
xmargin ymargin
vw (- (+ new-fy vh) old-fy)
xmargin (+ ymargin (- old-fy new-fy)))
(redraw xmargin ymargin
vw (- old-fy new-fy)
#t))]
[(and (old-fy . < . new-fy)
(new-fy . < . (+ old-fy vh)))
(let ([dc (get-dc)])
(send dc copy
xmargin (+ ymargin (- new-fy old-fy))
vw (- (+ old-fy vh) new-fy)
xmargin ymargin)
(let ([d (- (+ old-fy vh) new-fy)])
(redraw xmargin (+ ymargin d)
vw (- vh d)
#t)))]
[else (repaint)])))
(repaint)))))
(define/override (set-scrollbars x y x2 y2 x3 y3 x4 y4 ?) (void)) (define/override (set-scrollbars x y x2 y2 x3 y3 x4 y4 ?) (void))
@ -1113,7 +1165,7 @@
[is-shown? [is-shown?
(if (not (send canvas get-canvas-background)) (if (not (send canvas get-canvas-background))
(send canvas repaint) (send canvas repaint)
(send canvas redraw localx localy w h))])))) (send canvas redraw localx localy w h #f))]))))
(define/override (resized update?) (define/override (resized update?)
(all-in-chain (lambda (a) (send a do-resized update?)))) (all-in-chain (lambda (a) (send a do-resized update?))))

59
collects/racket/draw/dc.rkt
View File

@ -424,6 +424,7 @@
(define/override (reset-cr cr) (define/override (reset-cr cr)
(set! context #f) (set! context #f)
(set! current-smoothing #f)
(reset-layouts!) (reset-layouts!)
(do-reset-matrix cr) (do-reset-matrix cr)
(when clipping-region (when clipping-region
@ -437,7 +438,7 @@
(def/public (set-smoothing [(symbol-in unsmoothed smoothed aligned) s]) (def/public (set-smoothing [(symbol-in unsmoothed smoothed aligned) s])
(set! smoothing s)) (set! smoothing s))
(def/public (get-smoothing) (def/public (get-smoothing)
smoothing) smoothing)
(define/private (align-x/delta x delta) (define/private (align-x/delta x delta)
(if (aligned? smoothing) (if (aligned? smoothing)
(/ (- (+ (floor (+ (* x effective-scale-x) effective-origin-x)) delta) (/ (- (+ (floor (+ (* x effective-scale-x) effective-origin-x)) delta)
@ -455,20 +456,25 @@
(define/private (align-y y) (define/private (align-y y)
(align-y/delta y y-align-delta)) (align-y/delta y y-align-delta))
(define current-smoothing #f)
(define (set-font-antialias context smoothing) (define (set-font-antialias context smoothing)
(let ([o (pango_cairo_context_get_font_options context)] (let ([smoothing (dc-adjust-smoothing smoothing)])
[o2 (cairo_font_options_create)]) (unless (eq? current-smoothing smoothing)
(when o (set! current-smoothing smoothing)
(cairo_font_options_copy o2 o)) (let ([o (pango_cairo_context_get_font_options context)]
(cairo_font_options_set_antialias [o2 (cairo_font_options_create)])
o2 (when o
(case (dc-adjust-smoothing smoothing) (cairo_font_options_copy o2 o))
[(default) CAIRO_ANTIALIAS_SUBPIXEL] ; should be DEFAULT? (cairo_font_options_set_antialias
[(unsmoothed) CAIRO_ANTIALIAS_NONE] o2
[(partly-smoothed) CAIRO_ANTIALIAS_GRAY] (case smoothing
[(smoothed) CAIRO_ANTIALIAS_SUBPIXEL])) [(default) CAIRO_ANTIALIAS_SUBPIXEL] ; should be DEFAULT?
(pango_cairo_context_set_font_options context o2) [(unsmoothed) CAIRO_ANTIALIAS_NONE]
(cairo_font_options_destroy o2))) [(partly-smoothed) CAIRO_ANTIALIAS_GRAY]
[(smoothed) CAIRO_ANTIALIAS_SUBPIXEL]))
(pango_cairo_context_set_font_options context o2)
(cairo_font_options_destroy o2)))))
(define alpha 1.0) (define alpha 1.0)
(def/public (get-alpha) alpha) (def/public (get-alpha) alpha)
@ -601,6 +607,20 @@
(cairo_paint cr) (cairo_paint cr)
(cairo_set_operator cr CAIRO_OPERATOR_OVER))) (cairo_set_operator cr CAIRO_OPERATOR_OVER)))
(def/public (copy [real? x] [real? y] [nonnegative-real? w] [nonnegative-real? h]
[real? x2] [real? y2])
(with-cr
(void)
cr
(cairo_set_source_surface cr
(cairo_get_target cr)
(- x2 x) (- y2 y))
(cairo_set_operator cr CAIRO_OPERATOR_SOURCE)
(cairo_new_path cr)
(cairo_rectangle cr x2 y2 w h)
(cairo_fill cr)
(cairo_set_operator cr CAIRO_OPERATOR_OVER)))
(define/private (make-pattern-surface cr col draw) (define/private (make-pattern-surface cr col draw)
(let* ([s (cairo_surface_create_similar (cairo_get_target cr) (let* ([s (cairo_surface_create_similar (cairo_get_target cr)
CAIRO_CONTENT_COLOR_ALPHA CAIRO_CONTENT_COLOR_ALPHA
@ -1027,7 +1047,7 @@
(let* ([s (if (zero? offset) (let* ([s (if (zero? offset)
s s
(substring s offset))] (substring s offset))]
[blank? (equal? s "")] [blank? (string=? s "")]
[s (if (and (not draw?) blank?) " " s)] [s (if (and (not draw?) blank?) " " s)]
[rotate? (and draw? (not (zero? angle)))]) [rotate? (and draw? (not (zero? angle)))])
(unless context (unless context
@ -1123,8 +1143,8 @@
;; object. ;; object.
(let ([logical (make-PangoRectangle 0 0 0 0)] (let ([logical (make-PangoRectangle 0 0 0 0)]
[cache (if (or combine? [cache (if (or combine?
(not (= 1.0 effective-scale-x)) (not (fl= 1.0 effective-scale-x))
(not (= 1.0 effective-scale-y))) (not (fl= 1.0 effective-scale-y)))
#f #f
(get-size-cache desc))] (get-size-cache desc))]
[layouts (let ([attr-layouts (or (hash-ref desc-layouts desc #f) [layouts (let ([attr-layouts (or (hash-ref desc-layouts desc #f)
@ -1186,10 +1206,11 @@
(let loop ([i 0]) (let loop ([i 0])
(or (= i len) (or (= i len)
(let* ([ch (string-ref s i)] (let* ([ch (string-ref s i)]
[layout-info (hash-ref layouts (char->integer ch))] [chi (char->integer ch)]
[layout-info (hash-ref layouts chi)]
[font (vector-ref layout-info 3)] [font (vector-ref layout-info 3)]
[glyphs (vector-ref layout-info 4)] [glyphs (vector-ref layout-info 4)]
[v (hash-ref cache (char->integer ch) #f)]) [v (hash-ref cache chi #f)])
(and font (and font
v v
;; Need the same font for all glyphs for the fast path: ;; Need the same font for all glyphs for the fast path:

17
collects/scribblings/gui/dc-intf.scrbl
View File

@ -30,6 +30,23 @@ as determined by @method[dc<%> get-background]).
} }
@defmethod[(copy [x real?]
[y real?]
[width (and/c real? (not/c negative?))]
[height (and/c real? (not/c negative?))]
[x2 real?]
[y2 real?])
void?]{
Copies the rectangle defined by @racket[x], @racket[y],
@racket[width], and @racket[height] of the drawing context to the same
drawing context at the position specified by @racket[x2] and
@racket[y2].
The result is undefined if the source and destination rectangles
overlap.}
@defmethod[(draw-arc [x real?] @defmethod[(draw-arc [x real?]
[y real?] [y real?]
[width (and/c real? (not/c negative?))] [width (and/c real? (not/c negative?))]