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

racket/draw: fix problems with monochrome PNGs

Browse Source 
Merge to v5.3.1
This commit is contained in:
Matthew Flatt 2012-10-18 10:00:53 -06:00
parent 484636d92e
commit 274d004546
3 changed files with 50 additions and 8 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
collects/racket/draw/private/bitmap.rkt
View File

@ -231,7 +231,7 @@
(cairo_image_surface_get_width s)
(cairo_image_surface_get_height s)
b&w?
alpha?
(and alpha? (not b&w?))
s
mask-bm)
(values #f 0 0 #f #f #f #f))))]
@ -546,9 +546,9 @@
(let ([src (+ (* j row-width) (* (* bi 8) 4))])
(for/fold ([v 0]) ([k (in-range 8)])
(if ((+ (* 8 bi) k) . < . width)
(if (zero? (bytes-ref data (+ src (* 4 k))))
v
(bitwise-ior v (unsafe-fxrshift 128 k)))
(if (zero? (bytes-ref data (+ src 3 (* 4 k))))
(bitwise-ior v (unsafe-fxrshift 128 k))
v)
v)))))))
(let ([w (create-png-writer out width height #t #f)])
(write-png w rows)

9
collects/racket/draw/unsafe/png.rkt
View File

@ -220,12 +220,13 @@
interlace-type compression-type filter-type)
(png_get_IHDR png info)])
(let* ([tRNS? (positive? (png_get_valid png info PNG_INFO_tRNS))]
[alpha? (and keep-alpha?
(or tRNS?
(positive? (bitwise-ior color-type PNG_COLOR_MASK_ALPHA))))]
[b&w? (and (= depth 1)
(= color-type PNG_COLOR_TYPE_GRAY)
(not tRNS?))])
(not tRNS?))]
[alpha? (and keep-alpha?
(not b&w?)
(or tRNS?
(positive? (bitwise-ior color-type PNG_COLOR_MASK_ALPHA))))])
(unless b&w?
;; Normalize formal of returned rows:
(when (= color-type PNG_COLOR_TYPE_PALETTE)

41
collects/tests/gracket/dc.rktl
View File

@ -623,6 +623,47 @@
(let ([bm (make-object bitmap% 1 1)])
(test #t 'load-file (send bm load-file (collection-file-path "sk.jpg" "icons"))))
;; ----------------------------------------
;; Check save & load of monochrome PNG:
(let ()
(define N 5)
(define bm (make-object bitmap% N N #t #f))
(define dc (make-object bitmap-dc% bm))
(send dc draw-rectangle 2 2 (- N 2) (- N 2))
(define-values (i o) (make-pipe))
(send bm save-file o 'png)
(close-output-port o)
(define bm2 (make-object bitmap% 10 10))
(send bm2 load-file i 'png)
(define-values (i2 o2) (make-pipe))
(send bm save-file o2 'png)
(close-output-port o2)
(define bm3 (read-bitmap i2))
(define s1 (make-bytes (* N N 4)))
(define s2 (make-bytes (* N N 4)))
(define s3 (make-bytes (* N N 4)))
(send bm get-argb-pixels 0 0 N N s1)
(send bm2 get-argb-pixels 0 0 N N s2)
(send bm3 get-argb-pixels 0 0 N N s3)
(test #t 'same (equal? s1 s2))
(test #t 'same (equal? s1 s3))
(test 1 'mono (send bm2 get-depth))
(test 1 'mono (send bm3 get-depth))
(test #f 'b&w (send bm2 is-color?))
(test #f 'b&w (send bm3 is-color?))
(test #f 'no-alpha (send bm2 has-alpha-channel?))
(test #f 'no-alpha (send bm3 has-alpha-channel?)))
;; ----------------------------------------
(report-errs)