diff --git a/collects/2htdp/private/image-more.rkt b/collects/2htdp/private/image-more.rkt index 1645c94dbe..870a25aa27 100644 --- a/collects/2htdp/private/image-more.rkt +++ b/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)] - [h (image-height image)] - [bm (make-bitmap w h)] - [bdc (make-object bitmap-dc% bm)] - [c (make-object color%)] - [bytes (make-bytes (* w h 4))]) - (send bdc erase) - (render-image image bdc 0 0) - (send bdc get-argb-pixels 0 0 w h bytes) - (for/list ([i (in-range 0 (* w h 4) 4)]) - (color (bytes-ref bytes (+ i 1)) - (bytes-ref bytes (+ i 2)) - (bytes-ref bytes (+ i 3)) - (bytes-ref bytes i))))) + (define w (image-width image)) + (define h (image-height image)) + (cond + [(or (= w 0) (= h 0)) '()] + [else + (define bm (make-bitmap w h)) + (define bdc (make-object bitmap-dc% bm)) + (define c (make-object color%)) + (define bytes (make-bytes (* w h 4))) + (send bdc erase) + (render-image image bdc 0 0) + (send bdc get-argb-pixels 0 0 w h bytes) + (for/list ([i (in-range 0 (* w h 4) 4)]) + (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)] - [bytes (make-bytes (* width height 4) 0)] - [o (make-object color%)]) - (for ([c (in-list color-list)] - [i (in-naturals)]) - (define j (* i 4)) - (cond - [(color? c) - (bytes-set! bytes j (color-alpha c)) - (bytes-set! bytes (+ j 1) (color-red c)) - (bytes-set! bytes (+ j 2) (color-green c)) - (bytes-set! bytes (+ j 3) (color-blue c))] - [else - (let* ([str (if (string? c) c (symbol->string c))] - [clr (or (send the-color-database find-color str) - (send the-color-database find-color "black"))]) - (bytes-set! bytes j 255) ;; this should probably (send clr alpha) when that's possible - (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))) + (cond + [(or (zero? width) (zero? height)) + (rectangle width height "solid" "black")] + [else + (define bmp (make-bitmap width height)) + (define bytes (make-bytes (* width height 4) 0)) + (define o (make-object color%)) + (for ([c (in-list color-list)] + [i (in-naturals)]) + (define j (* i 4)) + (cond + [(color? c) + (bytes-set! bytes j (color-alpha c)) + (bytes-set! bytes (+ j 1) (color-red c)) + (bytes-set! bytes (+ j 2) (color-green c)) + (bytes-set! bytes (+ j 3) (color-blue c))] + [else + (define str (if (string? c) c (symbol->string c))) + (define clr (or (send the-color-database find-color str) + (send the-color-database find-color "black"))) + (bytes-set! bytes j 255) ;; this should probably (send clr alpha) when that's possible + (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)) - (define bdc (make-object bitmap-dc% bm)) - (render-image image bdc (- x) (- y)) - (send bdc set-bitmap #f) - (to-img bm)) + (cond + [(or (zero? w) (zero? h)) image] + [else + (define bm (make-bitmap w h)) + (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 diff --git a/collects/2htdp/tests/test-image.rkt b/collects/2htdp/tests/test-image.rkt index af902eacbb..33dc9caea5 100644 --- a/collects/2htdp/tests/test-image.rkt +++ b/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:")