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

fixed a bug replating to zero sized images

Browse Source 
svn: r11569
This commit is contained in:
Robby Findler 2008-09-07 13:28:44 +00:00
parent 6a174fa7c9
commit 4f24a1c0cd
2 changed files with 51 additions and 33 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

53
collects/htdp/image.ss
View File

@ -877,31 +877,34 @@ converting from the computer's coordinates, we get:
(define (image->color-list i-raw)
(check-image 'image->color-list i-raw "first")
(let* ([cis (coerce-to-cache-image-snip i-raw)]
[i (send cis get-bitmap)]
[iw (send i get-width)]
[ih (send i get-height)]
[new-bitmap (make-object bitmap% iw ih)]
[bdc (make-object bitmap-dc% new-bitmap)])
(send bdc clear)
(send bdc draw-bitmap i 0 0 'solid
(send the-color-database find-color "black")
(send i get-loaded-mask))
(let ([is (make-bytes (* 4 iw ih))]
[cols (make-vector (* iw ih))])
(send bdc get-argb-pixels 0 0 iw ih is)
(let yloop ([y 0][pos 0])
(unless (= y ih)
(let xloop ([x 0][pos pos])
(if (= x iw)
(yloop (add1 y) pos)
(begin
(vector-set! cols (+ x (* y iw))
(make-color (bytes-ref is (+ 1 pos))
(bytes-ref is (+ 2 pos))
(bytes-ref is (+ 3 pos))))
(xloop (add1 x) (+ pos 4)))))))
(send bdc set-bitmap #f)
(vector->list cols))))
[i (send cis get-bitmap)])
(cond
[(not i) '()]
[else
(let* ([iw (send i get-width)]
[ih (send i get-height)]
[new-bitmap (make-object bitmap% iw ih)]
[bdc (make-object bitmap-dc% new-bitmap)])
(send bdc clear)
(send bdc draw-bitmap i 0 0 'solid
(send the-color-database find-color "black")
(send i get-loaded-mask))
(let ([is (make-bytes (* 4 iw ih))]
[cols (make-vector (* iw ih))])
(send bdc get-argb-pixels 0 0 iw ih is)
(let yloop ([y 0][pos 0])
(unless (= y ih)
(let xloop ([x 0][pos pos])
(if (= x iw)
(yloop (add1 y) pos)
(begin
(vector-set! cols (+ x (* y iw))
(make-color (bytes-ref is (+ 1 pos))
(bytes-ref is (+ 2 pos))
(bytes-ref is (+ 3 pos))))
(xloop (add1 x) (+ pos 4)))))))
(send bdc set-bitmap #f)
(vector->list cols)))])))
(define (image->alpha-color-list i)
(check-image 'image->alpha-color-list i "first")

31
collects/tests/mzscheme/htdp-image.ss
View File

@ -503,14 +503,6 @@
'image-height
(image-height (rectangle 5 7 'solid 'red)))
(test 10 image-width (rectangle 10 0 'solid 'red))
(test 0 image-height (rectangle 10 0 'solid 'red))
(test 0 image-width (rectangle 0 10 'solid 'red))
(test 10 image-height (rectangle 0 10 'solid 'red))
(test 0 image-width (text "" 12 'black))
(test #t 'not-zero-empty-string-height (not (zero? (image-height (text "" 12 'black)))))
(test 1 'color-red (color-red (make-color 1 2 3)))
(test 2 'color-green (color-green (make-color 1 2 3)))
(test 3 'color-blue (color-blue (make-color 1 2 3)))
@ -918,6 +910,29 @@
(shrink (shrink (rectangle 11 11 'solid 'red)
5 5 5 5)
1 1 1 1))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; test images with zero width or zero height
;; for various things
;;
(test 10 image-width (rectangle 10 0 'solid 'red))
(test 0 image-height (rectangle 10 0 'solid 'red))
(test 0 image-width (rectangle 0 10 'solid 'red))
(test 10 image-height (rectangle 0 10 'solid 'red))
(test 0 image-width (text "" 12 'black))
(test #t 'not-zero-empty-string-height (not (zero? (image-height (text "" 12 'black)))))
(test '() image->color-list (rectangle 0 10 'solid 'red))
(test '() image->color-list (rectangle 10 0 'solid 'red))
(test '() image->color-list (rectangle 0 0 'solid 'red))
(test '() image->alpha-color-list (rectangle 0 10 'solid 'red))
(test '() image->alpha-color-list (rectangle 10 0 'solid 'red))
(test '() image->alpha-color-list (rectangle 0 0 'solid 'red))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;