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

adjust 2htdp/image library so that it doesn't create arbitrarily large

Browse Source 
bitmaps when rendering images

closes PR 12277 (except I didn't fix the make-bitmap contract)

include in 5.2
This commit is contained in:
Robby Findler 2011-10-11 08:32:42 -05:00
parent 32b5390ad2
commit 10d19bf8d5
1 changed files with 18 additions and 14 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -230,17 +230,21 @@ has been moved out).
(get-output-bytes s))]
[else default]))])))
;; these are used when building a bitmap to render the final image
;; they are probably smaller than the allowed maximum, but they are
;; still huge
(define maximum-width 5000)
(define maximum-height 5000)
(define (to-bitmap img)
(let* ([bb (send img get-bb)]
[bm (make-bitmap
(inexact->exact (ceiling (bb-right bb)))
(inexact->exact (ceiling (bb-bottom bb))))]
[bdc (new bitmap-dc% [bitmap bm])])
(send bdc erase)
(define bb (send img get-bb))
(define w (min (inexact->exact (ceiling (bb-right bb))) maximum-width))
(define h (min (inexact->exact (ceiling (bb-bottom bb))) maximum-height))
(define bm (make-bitmap w h))
(define bdc (new bitmap-dc% [bitmap bm]))
(render-image img bdc 0 0)
(begin0
(send bdc get-bitmap)
(send bdc set-bitmap #f))))
(send bdc set-bitmap #f)
bm)
(define-local-member-name
set-use-bitmap-cache?!
@ -350,8 +354,8 @@ has been moved out).
(define/public (compute-cached-bitmap)
(when use-cached-bitmap?
(unless cached-bitmap
(set! cached-bitmap (make-bitmap (+ (inexact->exact (round (bb-right bb))) 1)
(+ (inexact->exact (round (bb-bottom bb))) 1)))
(set! cached-bitmap (make-bitmap (min (+ (inexact->exact (round (bb-right bb))) 1) maximum-width)
(min (+ (inexact->exact (round (bb-bottom bb))) 1) maximum-height)))
(define bdc (make-object bitmap-dc% cached-bitmap))
(send bdc erase)
(render-image this bdc 0 0)