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

various 0-sized image repairs

Browse Source 
closes PR 13540
This commit is contained in:
Robby Findler 2013-02-21 16:28:32 -06:00
parent 61db1d6405
commit 09f9f31213
2 changed files with 88 additions and 41 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

50
collects/2htdp/private/image-more.rkt
View File

@ -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,12 +1334,15 @@
(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))])
(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)
@ -1339,16 +1350,20 @@
(color (bytes-ref bytes (+ i 1))
(bytes-ref bytes (+ i 2))
(bytes-ref bytes (+ i 3))
(bytes-ref bytes i)))))
(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%)])
(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))
@ -1359,15 +1374,15 @@
(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"))])
(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)))]))
(bytes-set! bytes (+ j 3) (send clr blue))]))
(send bmp set-argb-pixels 0 0 width height bytes)
(bitmap->image bmp)))
(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)
(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))
(to-img bm)]))
(provide overlay
overlay/align

29
collects/2htdp/tests/test-image.rkt
View File

@ -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:")