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

fixed a bug with zero-sized htdp/image images interactive with 2htdp/image primitives

Browse Source
This commit is contained in:
Robby Findler 2010-04-23 12:34:17 -05:00
parent 1812515a57
commit 256e3fedd2
2 changed files with 30 additions and 3 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

24
collects/2htdp/private/img-err.ss
View File

@ -20,6 +20,7 @@
lang/posn
scheme/gui/base
"../../mrlib/image-core.ss"
(prefix-in cis: "../../mrlib/cache-image-snip.ss")
(for-syntax scheme/base
scheme/list))
@ -270,9 +271,26 @@
[else arg]))
(define (image-snip->image is)
(bitmap->image (send is get-bitmap)
(or (send is get-bitmap-mask)
(send (send is get-bitmap) get-loaded-mask))))
(let ([bm (send is get-bitmap)])
(cond
[(not bm)
;; this might mean we have a cache-image-snip%
;; or it might mean we have a useless snip.
(let-values ([(w h) (if (is-a? is cis:cache-image-snip%)
(send is get-size)
(values 0 0))])
(make-image (make-polygon
(list (make-point 0 0)
(make-point w 0)
(make-point w h)
(make-point 0 h))
'solid "black")
(make-bb w h h)
#f))]
[else
(bitmap->image bm
(or (send is get-bitmap-mask)
(send bm get-loaded-mask)))])))
(define (bitmap->image bm [mask-bm (send bm get-loaded-mask)])
(let ([w (send bm get-width)]

9
collects/2htdp/tests/test-image.ss
View File

@ -46,6 +46,7 @@
scheme/class
scheme/gui/base
schemeunit
(prefix-in 1: htdp/image)
(only-in lang/htdp-advanced equal~?))
(require (for-syntax scheme/base))
@ -202,6 +203,14 @@
(check-close (image-height (rotate 30 (ellipse 0 100 'solid 'blue)))
(ceiling (* (cos (* pi 1/6)) 100)))
;; zero-sized htdp/image images should also work
(test (image-width (1:text "" 18 "blue"))
=>
0)
(test (image-height (1:rectangle 10 0 'solid "red"))
=>
0)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; polygon equality