From 274d0045464b80116fa83faef4cc21e87f651a7c Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Thu, 18 Oct 2012 10:00:53 -0600
Subject: [PATCH] racket/draw: fix problems with monochrome PNGs

Merge to v5.3.1
---
 collects/racket/draw/private/bitmap.rkt |  8 ++---
 collects/racket/draw/unsafe/png.rkt     |  9 +++---
 collects/tests/gracket/dc.rktl          | 41 +++++++++++++++++++++++++
 3 files changed, 50 insertions(+), 8 deletions(-)

diff --git a/collects/racket/draw/private/bitmap.rkt b/collects/racket/draw/private/bitmap.rkt
index 10deb3dc7d..77be9adddb 100644
--- a/collects/racket/draw/private/bitmap.rkt
+++ b/collects/racket/draw/private/bitmap.rkt
@@ -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)
diff --git a/collects/racket/draw/unsafe/png.rkt b/collects/racket/draw/unsafe/png.rkt
index b8cb0599f1..a39b92ecab 100644
--- a/collects/racket/draw/unsafe/png.rkt
+++ b/collects/racket/draw/unsafe/png.rkt
@@ -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)
diff --git a/collects/tests/gracket/dc.rktl b/collects/tests/gracket/dc.rktl
index fde2dc637b..adb61ea8d8 100644
--- a/collects/tests/gracket/dc.rktl
+++ b/collects/tests/gracket/dc.rktl
@@ -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)