various 0-sized image repairs

closes PR 13540

collects/2htdp/private/image-more.rkt

@@ -68,6 +68,14 @@
                         filename 
                         [width (if (image? image) (image-width image) 0)] 
                         [height (if (image? image) (image-height image) 0)])
+  (check-dependencies 'save-image
+                      (not (zero? width))
+                      "the width must not be zero, got ~e"
+                      width)
+  (check-dependencies 'save-image
+                      (not (zero? height))
+                      "the width must not be zero, got ~e"
+                      height)
   (let* ([bm (make-bitmap (inexact->exact (ceiling width)) 
                           (inexact->exact (ceiling height)))]
          [bdc (make-object bitmap-dc% bm)])
@@ -1326,48 +1334,55 @@
    (read-bitmap filename)))
 
 (define/chk (image->color-list image)
-  (let* ([w (image-width image)]
+  (define w (image-width image))
-         [h (image-height image)]
+  (define h (image-height image))
-         [bm (make-bitmap w h)]
+  (cond
-         [bdc (make-object bitmap-dc% bm)]
+    [(or (= w 0) (= h 0)) '()]
-         [c (make-object color%)]
+    [else
-         [bytes (make-bytes (* w h 4))])
+     (define bm (make-bitmap w h))
-    (send bdc erase)
+     (define bdc (make-object bitmap-dc% bm))
-    (render-image image bdc 0 0)
+     (define c (make-object color%))
-    (send bdc get-argb-pixels 0 0 w h bytes)
+     (define bytes (make-bytes (* w h 4)))
-    (for/list ([i (in-range 0 (* w h 4) 4)])
+     (send bdc erase)
-      (color (bytes-ref bytes (+ i 1))
+     (render-image image bdc 0 0)
-             (bytes-ref bytes (+ i 2))
+     (send bdc get-argb-pixels 0 0 w h bytes)
-             (bytes-ref bytes (+ i 3))
+     (for/list ([i (in-range 0 (* w h 4) 4)])
-             (bytes-ref bytes i)))))
+       (color (bytes-ref bytes (+ i 1))
+              (bytes-ref bytes (+ i 2))
+              (bytes-ref bytes (+ i 3))
+              (bytes-ref bytes i)))]))
 
 (define/chk (color-list->bitmap color-list width height)
   (check-dependencies 'color-list->bitmap
                       (= (* width height) (length color-list))
                       "the length of the color list to match the product of the width and the height, but the list has ~a elements and the width and height are ~a and ~a respectively"
                       (length color-list) width height)
-  (let* ([bmp (make-bitmap width height)]
+  (cond
-         [bytes (make-bytes (* width height 4) 0)]
+    [(or (zero? width) (zero? height))
-         [o (make-object color%)])
+     (rectangle width height "solid" "black")]
-    (for ([c (in-list color-list)]
+    [else
-          [i (in-naturals)])
+     (define bmp (make-bitmap width height))
-      (define j (* i 4))
+     (define bytes (make-bytes (* width height 4) 0))
-      (cond
+     (define o (make-object color%))
-        [(color? c)
+     (for ([c (in-list color-list)]
-         (bytes-set! bytes j (color-alpha c))
+           [i (in-naturals)])
-         (bytes-set! bytes (+ j 1) (color-red c))
+       (define j (* i 4))
-         (bytes-set! bytes (+ j 2) (color-green c))
+       (cond
-         (bytes-set! bytes (+ j 3) (color-blue c))]
+         [(color? c)
-        [else
+          (bytes-set! bytes j (color-alpha c))
-         (let* ([str (if (string? c) c (symbol->string c))]
+          (bytes-set! bytes (+ j 1) (color-red c))
-                [clr (or (send the-color-database find-color str)
+          (bytes-set! bytes (+ j 2) (color-green c))
-                         (send the-color-database find-color "black"))])
+          (bytes-set! bytes (+ j 3) (color-blue c))]
-           (bytes-set! bytes j 255)  ;; this should probably (send clr alpha) when that's possible
+         [else
-           (bytes-set! bytes (+ j 1) (send clr red))
+          (define str (if (string? c) c (symbol->string c)))
-           (bytes-set! bytes (+ j 2) (send clr green))
+          (define clr (or (send the-color-database find-color str)
-           (bytes-set! bytes (+ j 3) (send clr blue)))]))
+                          (send the-color-database find-color "black")))
-    (send bmp set-argb-pixels 0 0 width height bytes)
+          (bytes-set! bytes j 255)  ;; this should probably (send clr alpha) when that's possible
-    (bitmap->image bmp)))
+          (bytes-set! bytes (+ j 1) (send clr red))
+          (bytes-set! bytes (+ j 2) (send clr green))
+          (bytes-set! bytes (+ j 3) (send clr blue))]))
+     (send bmp set-argb-pixels 0 0 width height bytes)
+     (bitmap->image bmp)]))
       
 (define build-color/make-color
   (let ([orig-make-color make-color])
@@ -1420,11 +1435,14 @@
     [(x y width height image) (freeze/internal x y width height image)]))
 
 (define (freeze/internal x y w h image)
-  (define bm (make-bitmap w h))
+  (cond
-  (define bdc (make-object bitmap-dc% bm))
+    [(or (zero? w) (zero? h)) image]
-  (render-image image bdc (- x) (- y))
+    [else
-  (send bdc set-bitmap #f)
+     (define bm (make-bitmap w h))
-  (to-img bm))
+     (define bdc (make-object bitmap-dc% bm))
+     (render-image image bdc (- x) (- y))
+     (send bdc set-bitmap #f)
+     (to-img bm)]))
 
 (provide overlay
          overlay/align

collects/2htdp/tests/test-image.rkt

@@ -1785,6 +1785,9 @@
       =>
       (list (color 1 1 1) (color 2 2 2) (color 3 3 3) 
             (color 4 4 4) (color 5 5 5) (color 6 6 6)))
+(test (image->color-list (empty-scene 0 0))
+      =>
+      '())
 
 (test (color-list->bitmap
        (list (color 1 1 1) (color 2 2 2) (color 3 3 3) 
@@ -1798,6 +1801,10 @@
                      (rectangle 1 1 'solid (color 5 5 5))
                      (rectangle 1 1 'solid (color 6 6 6)))))
 
+(test (color-list->bitmap '() 0 0) => (empty-scene 0 0))
+(test (color-list->bitmap '() 0 10) => (empty-scene 0 10))
+(test (color-list->bitmap '() 4 0) => (empty-scene 4 0))
+
 (let ([has-color? 
        (λ (img) 
          (ormap (λ (x) (or (not (equal? (color-red x)
@@ -1843,6 +1850,18 @@
       =>
       (rectangle 12 10 'solid 'blue))
 
+(test (freeze (rectangle 0 0 'solid 'blue))
+      =>
+      (rectangle 0 0 'solid 'blue))
+
+(test (freeze (rectangle 0 4 'solid 'blue))
+      =>
+      (rectangle 0 4 'solid 'blue))
+
+(test (freeze (rectangle 4 0 'solid 'blue))
+      =>
+      (rectangle 4 0 'solid 'blue))
+
 (let ()
   (define bkg (rectangle 12 12 'solid 'white))
   (define i1 (overlay/xy 
@@ -2153,6 +2172,16 @@
 (test/exn (save-image "tri.png" (triangle 50 "solid" "purple"))
           =>
           #rx"^save-image:")
+(test/exn (save-image (rectangle 0 0 'solid 'blue) "sq.png")
+          =>
+          #rx"^save-image:")
+(test/exn (save-image (rectangle 10 0 'solid 'blue) "sq.png")
+          =>
+          #rx"^save-image:")
+(test/exn (save-image (rectangle 0 10 'solid 'blue) "sq.png")
+          =>
+          #rx"^save-image:")
+
 (test/exn (save-svg-image "tri.png" (triangle 50 "solid" "purple"))
           =>
           #rx"^save-svg-image:")