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

racket/draw: fix problems with set-argb-pixels on scaled, no-alpha bitmaps

Browse Source 
Also, fix the docs to clarify that `just-alpha?` as #t means a no-op for
a target bitmap that has an alpha channel.
This commit is contained in:
Matthew Flatt 2014-07-23 09:15:27 +01:00
parent 295cb46c48
commit a114733559
3 changed files with 60 additions and 40 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
pkgs/draw-pkgs/draw-doc/scribblings/draw/bitmap-dc-class.scrbl
View File

@ -140,6 +140,8 @@ The pixel RGB values are taken from @racket[pixels]. The first byte
If @racket[just-alpha?] is false, then the alpha value for each pixel is
used only if the DC's current bitmap has an alpha channel. If
@racket[just-alpha?] is true and the bitmap has an alpha channel, then the
bitmap is not modified. If
@racket[just-alpha?] is true and the bitmap has no alpha channel, then each
pixel is set based @italic{only} on the alpha value, but inverted to serve
as a mask. Thus, when working with bitmaps that have an associated mask

14
pkgs/draw-pkgs/draw-lib/racket/draw/private/bitmap.rkt
View File

@ -241,7 +241,7 @@
(let ([v (bytes-ref bstr (+ A (* 4 i) (* j row-width)))])
(or (= v 0) (= v 255))))])
(let ([mask-bm (make-object bitmap% w h b&w?)])
(send mask-bm set-alphas-as-mask 0 0 w h bstr row-width A)
(send mask-bm set-alphas-as-mask 0 0 w h bstr row-width A w h)
mask-bm)))
;; Force all alpha values to 255
(for* ([j (in-range h)]
@ -691,7 +691,7 @@
(or (if (or b&w? alpha-channel?)
s
(begin
(prep-alpha)
(prep-alpha (*i width backing-scale) (*i height backing-scale))
alpha-s))
(get-empty-surface)))
@ -873,7 +873,9 @@
[(and set-alpha?
(not alpha-channel?))
;; Set alphas:
(set-alphas-as-mask x y w h bstr (* 4 w) 0)])
(set-alphas-as-mask x y w h bstr (* 4 w) 0
(if unscaled? (*i width backing-scale) width)
(if unscaled? (*i height backing-scale) height))])
(drop-alpha-s)]))
(define/public (get-alphas-as-mask x y w h bstr width height)
@ -882,7 +884,7 @@
(cairo_surface_flush s)
s)
(begin
(prep-alpha)
(prep-alpha width height)
(cairo_surface_flush alpha-s)
alpha-s)))]
[row-width (cairo_image_surface_get_stride s)]
@ -894,7 +896,7 @@
[q (+ row (* i 4))])
(bytes-set! bstr p (bytes-ref data (+ q A)))))))))
(define/public (prep-alpha)
(define/public (prep-alpha width height)
(when (and (not b&w?)
(not alpha-channel?))
(unless alpha-s-up-to-date?
@ -931,7 +933,7 @@
(for ([i (in-range width)])
(bytes-set! bstr (+ A (+ row (* i 4))) 0))))))
(define/public (set-alphas-as-mask x y w h bstr src-w src-A)
(define/public (set-alphas-as-mask x y w h bstr src-w src-A width height)
(when (or b&w? (and (not b&w?) (not alpha-channel?)))
(let ([data (cairo_image_surface_get_data s)]
[row-width (cairo_image_surface_get_stride s)]

84
pkgs/gui-pkgs/gui-test/tests/gracket/dc.rktl
View File

@ -754,46 +754,62 @@
;; -----------------------------------------------------------
;; Check pixel operations on a bitmap with a x2 backing scale
(let ([bm (make-bitmap 10 11 #:backing-scale 2)])
(test 2.0 'scale (send bm get-backing-scale))
(test 10 'width (send bm get-width))
(test 11 'height (send bm get-height))
(define (scaled-bm-test alpha?)
(let ([bm (make-bitmap 10 11 alpha? #:backing-scale 2)])
(test 2.0 'scale (send bm get-backing-scale))
(test 10 'width (send bm get-width))
(test 11 'height (send bm get-height))
(define dc (send bm make-dc))
(send dc set-pen "black" 0 'transparent)
(send dc set-brush (make-color 100 100 200) 'solid)
(send dc draw-rectangle 0 0 3 3)
(send dc draw-rectangle 9 9 1 1)
(define dc (send bm make-dc))
(send dc set-pen "black" 0 'transparent)
(send dc set-brush (make-color 100 100 200) 'solid)
(send dc draw-rectangle 0 0 3 3)
(send dc draw-rectangle 9 9 1 1)
(let ([s (make-bytes 4)])
(send bm get-argb-pixels 2 2 1 1 s)
(test (list 255 100 100 200) 'scaled (bytes->list s))
(send bm get-argb-pixels 4 4 1 1 s)
(test 0 'scaled (bytes-ref s 0))
(send bm get-argb-pixels 2 2 1 1 s #:unscaled? #t)
(test (list 255 100 100 200) 'unscaled (bytes->list s))
(let ([s (make-bytes 4)])
(send bm get-argb-pixels 2 2 1 1 s)
(test (list 255 100 100 200) 'scaled (bytes->list s))
(send bm get-argb-pixels 4 4 1 1 s)
(test (if alpha? 0 255) 'scaled (bytes-ref s 0))
(send bm get-argb-pixels 2 2 1 1 s #:unscaled? #t)
(test (list 255 100 100 200) 'unscaled (bytes->list s))
(bytes-copy! s 0 (bytes 0 1 2 3))
(send bm get-argb-pixels 2 2 1 1 s #:unscaled? #t 'just-alpha)
(test (list 255 1 2 3) 'unscaled-alpha (bytes->list s))
(bytes-copy! s 0 (bytes 0 1 2 3))
(send bm get-argb-pixels 2 2 1 1 s #:unscaled? #t 'just-alpha)
;; for (not alpha?), 122 is the mask equivalent of the brush color
(test (list (if alpha? 255 122) 1 2 3) 'unscaled-alpha (bytes->list s))
(bytes-copy! s 0 (bytes 0 1 2 3))
(send bm get-argb-pixels 9 9 1 1 s #:unscaled? #t 'just-alpha)
(test (list 0 1 2 3) 'unscaled-alpha-miss (bytes->list s))
(send bm get-argb-pixels 18 18 1 1 s #:unscaled? #t 'just-alpha)
(test (list 255 1 2 3) 'unscaled-alpha-hit (bytes->list s))
(bytes-copy! s 0 (bytes 0 1 2 3))
(send bm get-argb-pixels 9 9 1 1 s #:unscaled? #t 'just-alpha)
(test (list 0 1 2 3) 'unscaled-alpha-miss (bytes->list s))
(send bm get-argb-pixels 18 18 1 1 s #:unscaled? #t 'just-alpha)
(test (list (if alpha? 255 122) 1 2 3) 'unscaled-alpha-hit (bytes->list s))
(send bm set-argb-pixels 0 0 2 1 #"\xff\x0\x0\x0\xff\x0\x0\x0"
#:unscaled? #t)
(send bm get-argb-pixels 0 0 1 1 s #:unscaled? #t)
(test (list 255 0 0 0) 'unscaled (bytes->list s))
;; scaled is average of black and blue:
(send bm get-argb-pixels 0 0 1 1 s)
(test (list 255 50 50 100) 'scaled (bytes->list s))
(send bm set-argb-pixels 0 0 2 1 #"\xff\x0\x0\x0\xff\x0\x0\x0"
#:unscaled? #t)
(send bm get-argb-pixels 0 0 1 1 s #:unscaled? #t)
(test (list 255 0 0 0) 'unscaled (bytes->list s))
;; scaled is average of black and blue:
(send bm get-argb-pixels 0 0 1 1 s)
(test (list 255 50 50 100) 'scaled (bytes->list s))
(send bm set-argb-pixels 0 0 2 1 #"\xff\x0\x0\x0\xff\x0\x0\x0")
(send bm get-argb-pixels 0 0 1 1 s)
(test (list 255 0 0 0) 'scaled (bytes->list s))))
(send bm set-argb-pixels 0 0 2 1 #"\xff\x0\x0\x0\xff\x0\x0\x0")
(send bm get-argb-pixels 0 0 1 1 s)
(test (list 255 0 0 0) 'scaled (bytes->list s))
(when (not alpha?)
(bytes-copy! s 0 (bytes 100 1 2 3))
(send bm set-argb-pixels 9 9 1 1 s #:unscaled? #t 'just-alpha)
(send bm get-argb-pixels 9 9 1 1 s #:unscaled? #t)
(test (list 255 155 155 155) 'unscaled-alpha-set (bytes->list s))
(bytes-copy! s 0 (bytes 100 1 2 3))
(send bm set-argb-pixels 18 18 1 1 s #:unscaled? #t 'just-alpha)
(send bm get-argb-pixels 18 18 1 1 s #:unscaled? #t)
(test (list 255 155 155 155) 'unscaled-alpha-set-far (bytes->list s))))))
(scaled-bm-test #t)
(scaled-bm-test #f)
(let ([p (collection-file-path "sk.jpg" "icons")])
(let ([bm1 (read-bitmap p)]