add dc<%> copy method; speed text drawing a little and implement but disable editor scrolling with dc<%> copy
original commit: 4bd84adb3afa20f3c95799b915ab6a042ea54c42
This commit is contained in:
Matthew Flatt
parent
4c3749468d
commit
0ebcd5678d
|
|
@ -440,13 +440,14 @@
|
|||
(let-boxes ([x 0]
|
||||
[y 0])
|
||||
(get-scroll x y)
|
||||
(let ([y (max (+ y
|
||||
(let ([old-y y]
|
||||
[y (max (+ y
|
||||
(* wheel-amt
|
||||
(if (eq? code 'wheel-up)
|
||||
-1
|
||||
1)))
|
||||
0)])
|
||||
(do-scroll x y #t))))]
|
||||
(do-scroll x y #t x old-y))))]
|
||||
[else
|
||||
(when (and media (not (send media get-printing)))
|
||||
(using-admin
|
||||
|
|
@ -490,7 +491,7 @@
|
|||
(when (not (send media get-printing))
|
||||
(let-boxes ([x 0][y 0][w 0][h 0])
|
||||
(get-view x y w h)
|
||||
(redraw x y w h)))
|
||||
(redraw x y w h #f)))
|
||||
(let ([bg (get-canvas-background)])
|
||||
(when bg
|
||||
(let ([adc (get-dc)])
|
||||
|
|
@ -538,28 +539,31 @@
|
|||
(let-boxes ([x 0]
|
||||
[y 0])
|
||||
(get-scroll x y)
|
||||
(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))))))
|
||||
(convert-scroll-to-location x y fx fy)))
|
||||
(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])
|
||||
(let ([w (box 0)]
|
||||
[h (box 0)])
|
||||
|
|
@ -574,10 +578,21 @@
|
|||
(when fw
|
||||
(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
|
||||
(not (send media get-printing)))
|
||||
(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)]
|
||||
[y (box 0)]
|
||||
[w (box 0)]
|
||||
|
|
@ -694,7 +709,7 @@
|
|||
(send hscroll set-value sx))
|
||||
(when vscroll
|
||||
(send vscroll set-value sy))
|
||||
(do-scroll sx sy refresh?)
|
||||
(do-scroll sx sy refresh? cx cy)
|
||||
#t)
|
||||
#f)))))))))
|
||||
|
||||
|
|
@ -863,7 +878,7 @@
|
|||
|
||||
retval)))))))
|
||||
|
||||
(define/private (do-scroll x y refresh?)
|
||||
(define/private (do-scroll x y refresh? old-x old-y)
|
||||
(let ([savenoloop? noloop?])
|
||||
(set! noloop? #t)
|
||||
|
||||
|
|
@ -878,8 +893,45 @@
|
|||
(set-scroll-pos 'vertical (->long (min y scroll-height)))))
|
||||
|
||||
(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))
|
||||
|
||||
|
|
@ -1113,7 +1165,7 @@
|
|||
[is-shown?
|
||||
(if (not (send canvas get-canvas-background))
|
||||
(send canvas repaint)
|
||||
(send canvas redraw localx localy w h))]))))
|
||||
(send canvas redraw localx localy w h #f))]))))
|
||||
|
||||
(define/override (resized update?)
|
||||
(all-in-chain (lambda (a) (send a do-resized update?))))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user