From dc00e22b85265605db7493b374015104259e1b48 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 11 Jun 2010 03:44:59 -0400 Subject: [PATCH] fix drawing bugs and improve backward compatibility --- collects/racket/draw/bitmap-dc.rkt | 3 ++- collects/racket/draw/bitmap.rkt | 38 +++++++++++++++--------------- collects/racket/draw/dc.rkt | 21 +++++------------ collects/tests/gracket/draw.rkt | 33 +++++++++++++++++++------- 4 files changed, 51 insertions(+), 44 deletions(-) diff --git a/collects/racket/draw/bitmap-dc.rkt b/collects/racket/draw/bitmap-dc.rkt index dcf509d356..c4dc8cc441 100644 --- a/collects/racket/draw/bitmap-dc.rkt +++ b/collects/racket/draw/bitmap-dc.rkt @@ -40,13 +40,14 @@ (values (exact->inexact (send bm get-width)) (exact->inexact (send bm get-height)))) + (define last-y -1) (def/public (set-pixel [real? x][real? y][color% c]) (let ([s (bytes 255 (color-red c) (color-green c) (color-blue c))]) (set-argb-pixels x y 1 1 s))) (def/public (get-pixel [real? x][real? y][color% c]) (let ([b (make-bytes 4)]) - (get-argb-pixels x y 1 1) + (get-argb-pixels x y 1 1 b) (send c set (bytes-ref b 1) (bytes-ref b 2) (bytes-ref b 3)) #t)) diff --git a/collects/racket/draw/bitmap.rkt b/collects/racket/draw/bitmap.rkt index df03999334..3f2a5a0cad 100644 --- a/collects/racket/draw/bitmap.rkt +++ b/collects/racket/draw/bitmap.rkt @@ -113,6 +113,7 @@ (let ([mask-bm (and s (not alpha?) + (not b&w?) (let ([w (cairo_image_surface_get_width s)] [h (cairo_image_surface_get_height s)] [row-width (cairo_image_surface_get_stride s)] @@ -522,13 +523,13 @@ (cairo_surface_flush s) (let ([data (cairo_image_surface_get_data s)] [row-width (cairo_image_surface_get_stride s)]) - (let ([w (min (- width x) w)]) + (let ([w2 (+ x (min (- width x) w))]) (for* ([j (in-range y (min (+ y h) height))]) (let ([row (* j row-width)] - [p (* 4 (+ x (* j w)))]) - (for ([i (in-range x w)]) + [p (* 4 (* (- j y) w))]) + (for ([i (in-range x w2)]) (let* ([4i (* 4 i)] - [pi (+ p 4i)] + [pi (+ p (* 4 (- i x)))] [ri (+ row 4i)] [a (bytes-ref data (+ ri A))] [unmult (lambda (a v) @@ -554,9 +555,9 @@ (get-alphas-as-mask x y w h bstr)] [(and (not get-alpha?) (not alpha-channel?)) ;; For non-alpha mode or no mask; fill in 255s: - (for ([j (in-range y (min (+ y h) height))]) + (for ([j (in-range 0 (min h (- height y)))]) (let ([row (* j (* 4 w))]) - (for ([i (in-range x (min (+ x w) width))]) + (for ([i (in-range 0 (min w (- width x)))]) (let ([p (+ (* 4 i) row)]) (bytes-set! bstr p 255)))))])) @@ -576,14 +577,14 @@ (cairo_surface_flush s) (let ([data (cairo_image_surface_get_data s)] [row-width (cairo_image_surface_get_stride s)]) - (let ([w (min (- width x) w)]) + (let ([w2 (+ x (min (- width x) w))]) (for ([j (in-range y (min (+ y h) height))] [dj (in-naturals)]) (let ([row (* j row-width)] [p (* 4 (* dj w))]) - (for ([i (in-range x w)]) + (for ([i (in-range x w2)]) (let* ([4i (* 4 i)] - [pi (+ p 4i)] + [pi (+ p (* 4 (- i x)))] [ri (+ row 4i)]) (if b&w? (let ([v (if (and (= (bytes-ref bstr (+ pi 1)) 255) @@ -592,8 +593,8 @@ 255 0)]) (bytes-set! data (+ ri A) (- 255 v)) - (bytes-set! data (+ ri R) v) - (bytes-set! data (+ ri G) v) + (bytes-set! data (+ ri 1) v) + (bytes-set! data (+ ri 2) v) (bytes-set! data (+ ri B) v)) (begin (when alpha-channel? @@ -647,14 +648,13 @@ (let ([row (* j row-width)]) (for ([i (in-range width)]) (let ([q (+ row (* i 4))]) - (bytes-set! alpha-data - (+ q A) - (- 255 - (quotient - (+ (+ (bytes-ref data (+ q 1)) - (bytes-ref data (+ q 2))) - (bytes-ref data (+ q B))) - 3)))))))) + (let ([v (quotient + (+ (+ (bytes-ref data (+ q 1)) + (bytes-ref data (+ q 2))) + (bytes-ref data (+ q B))) + 3)]) + (bytes-set! alpha-data (+ q A) (- 255 v)))))))) + (cairo_surface_mark_dirty alpha-s) (set! alpha-s-up-to-date? #t)))) (define/public (transparent-white! s width height) diff --git a/collects/racket/draw/dc.rkt b/collects/racket/draw/dc.rkt index 36e70d0332..a5d978886f 100644 --- a/collects/racket/draw/dc.rkt +++ b/collects/racket/draw/dc.rkt @@ -457,7 +457,7 @@ [else 0]))) (cairo_set_line_cap cr (case (if ((send pen get-width) . <= . 1.0) - 'butt + 'round (send pen get-cap)) [(butt) CAIRO_LINE_CAP_BUTT] [(round) CAIRO_LINE_CAP_ROUND] @@ -516,24 +516,15 @@ (draw-arc x y width height 0 2pi)) (def/public (draw-line [real? x1] [real? y1] [real? x2] [real? y2]) - (let-values ([(x1 y1 x2 y2) - (if (and (eq? smoothing 'unsmoothed) - (x2 . < . x1)) - (values x2 y2 x1 y1) - (values x1 y1 x2 y2))]) + (let ([dot (if (and (= x1 x2) (= y1 y2)) + 0.1 + 0)]) (with-cr (void) cr (cairo_new_path cr) (cairo_move_to cr (align-x x1) (align-y y1)) - (if #f ; (eq? smoothing 'unsmoothed) - ;; An unsmoothed line is supposed to hit the pixel to the - ;; lower right of the ending point. (We've revered the points - ;; above to ensure that the line goes left to right.) - (if ((abs (- x2 x1)) . > . (abs (- y2 y1))) - (cairo_line_to cr (+ (align-x x2) (sgn (- x2 x1))) (align-y y2)) - (cairo_line_to cr (align-x x2) (+ (align-y y2) (sgn (- y2 y1))))) - (cairo_line_to cr (align-x x2) (align-y y2))) + (cairo_line_to cr (+ (align-x x2) dot) (+ (align-y y2) dot)) (draw cr #f #t)))) (def/public (draw-point [real? x] [real? y]) @@ -544,7 +535,7 @@ (let ([x (align-x x)] [y (align-y y)]) (cairo_move_to cr x y) - (cairo_line_to cr x y) + (cairo_line_to cr (+ 0.1 x) (+ 0.1 y)) (draw cr #f #t)))) (def/public (draw-lines [(make-alts (make-list point%) list-of-pair-of-real?) pts] diff --git a/collects/tests/gracket/draw.rkt b/collects/tests/gracket/draw.rkt index 4d7f2b3566..e9d9d59d62 100644 --- a/collects/tests/gracket/draw.rkt +++ b/collects/tests/gracket/draw.rkt @@ -657,11 +657,11 @@ (case mask-ex-mode [(plt plt-mask plt^plt mred^plt) (let* ([plt (get-plt)] - [tmp-bm (make-object bitmap% - (send mred-icon get-width) - (send mred-icon get-height) - #f)] - [tmp-dc (make-object bitmap-dc% tmp-bm)]) + [ww (send mred-icon get-width)] + [hh (send mred-icon get-height)] + [tmp-bm (make-object bitmap% ww hh #f)] + [tmp-dc (make-object bitmap-dc% tmp-bm)] + [mask-bm tmp-bm]) (send tmp-dc draw-bitmap plt (/ (- (send mred-icon get-width) (send plt get-width)) @@ -669,16 +669,33 @@ (/ (- (send mred-icon get-height) (send plt get-height)) 2)) + (when (memq mask-ex-mode '(plt^plt mred^plt)) + ;; Convert to grayscale + (let ([s (make-bytes (* 4 ww hh))]) + (send tmp-bm get-argb-pixels 0 0 ww hh s) + (for* ([i (in-range 0 ww)] + [j (in-range 0 hh)]) + (let* ([p (* 4 (+ (* j ww) i))] + [v (quotient (+ (bytes-ref s (+ p 1)) + (bytes-ref s (+ p 2)) + (bytes-ref s (+ p 3))) + 3)]) + (bytes-set! s (+ p 1) v) + (bytes-set! s (+ p 2) v) + (bytes-set! s (+ p 3) v))) + (set! mask-bm (make-object bitmap% ww hh #f)) + (send tmp-dc set-bitmap mask-bm) + (send tmp-dc set-argb-pixels 0 0 ww hh s))) (if (eq? mask-ex-mode 'mred^plt) (send dc draw-bitmap mred-icon x y 'solid (send the-color-database find-color "BLACK") - tmp-bm) + mask-bm) (send dc draw-bitmap tmp-bm x y 'solid (send the-color-database find-color "BLACK") (cond [(eq? mask-ex-mode 'plt-mask) mred-icon] - [(eq? mask-ex-mode 'plt^plt) tmp-bm] + [(eq? mask-ex-mode 'plt^plt) mask-bm] [else #f]))))] [(mred^mred) (send dc draw-bitmap mred-icon x y @@ -722,9 +739,7 @@ (let ([start x]) ;; First three return icons: (do-one return 'solid black) - (printf "HERE\n") (do-one return 'solid red) - (printf "DONE\n") (do-one return 'opaque red) ;; Next three, on a blue background (let ([end x]