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

2htdp/image fix bitmap scaling to respect alpha channels

Browse Source
This commit is contained in:
Robby Findler 2010-12-28 18:13:53 -06:00
parent 3b032893c1
commit 1d89cfc9d7
2 changed files with 20 additions and 12 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -856,6 +856,23 @@
=>
(ellipse (* 30 3) (* 60 4) 'outline 'purple))
;; test scaling of bitmaps with alpha (in this case, a completely blank one)
(let ()
(define bmp (make-bitmap 1 1))
(define bdc (make-object bitmap-dc% bmp))
(send bdc erase)
(send bdc set-bitmap #f)
(define i (make-object image-snip% bmp))
(test (overlay i
(rectangle 1 1 'solid 'red))
=>
(rectangle 1 1 'solid 'red))
(test (overlay (scale 2 i)
(rectangle 2 2 'solid 'red))
=>
(rectangle 2 2 'solid 'red)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; misc tests

15
collects/mrlib/image-core.rkt
View File

@ -982,25 +982,16 @@ the mask bitmap and the original bitmap are all together in a single bytes!
[orig-h (send orig-bm get-height)]
[scale-w (ceiling (inexact->exact (* x-scale (send orig-bm get-width))))]
[scale-h (ceiling (inexact->exact (* y-scale (send orig-bm get-height))))]
[new-bm (make-object bitmap% scale-w scale-h)]
[new-mask (and orig-mask (make-object bitmap% scale-w scale-h))])
(when new-mask
(send new-bm set-loaded-mask new-mask))
[new-bm (make-bitmap scale-w scale-h)])
(send bdc set-bitmap new-bm)
(send bdc set-scale x-scale y-scale)
(send bdc erase)
(send bdc draw-bitmap orig-bm 0 0)
(when new-mask
(send bdc set-bitmap new-mask)
(send bdc set-scale x-scale y-scale)
(send bdc erase)
(send bdc draw-bitmap orig-mask 0 0))
(send bdc draw-bitmap orig-bm 0 0 'solid (send the-color-database find-color "black") orig-mask)
(send bdc set-bitmap #f)
(values new-bm new-mask))])))
(values new-bm #f))])))
(define (text->font text)
(define adjusted-size (min (max (inexact->exact (round (text-size text))) 1) 255))