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))] (get-output-bytes s))]
[else default]))]))) [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) (define (to-bitmap img)
(let* ([bb (send img get-bb)] (define bb (send img get-bb))
[bm (make-bitmap (define w (min (inexact->exact (ceiling (bb-right bb))) maximum-width))
(inexact->exact (ceiling (bb-right bb))) (define h (min (inexact->exact (ceiling (bb-bottom bb))) maximum-height))
(inexact->exact (ceiling (bb-bottom bb))))] (define bm (make-bitmap w h))
[bdc (new bitmap-dc% [bitmap bm])]) (define bdc (new bitmap-dc% [bitmap bm]))
(send bdc erase)
(render-image img bdc 0 0) (render-image img bdc 0 0)
(begin0 (send bdc set-bitmap #f)
(send bdc get-bitmap) bm)
(send bdc set-bitmap #f))))
(define-local-member-name (define-local-member-name
set-use-bitmap-cache?! set-use-bitmap-cache?!
@ -350,8 +354,8 @@ has been moved out).
(define/public (compute-cached-bitmap) (define/public (compute-cached-bitmap)
(when use-cached-bitmap? (when use-cached-bitmap?
(unless cached-bitmap (unless cached-bitmap
(set! cached-bitmap (make-bitmap (+ (inexact->exact (round (bb-right bb))) 1) (set! cached-bitmap (make-bitmap (min (+ (inexact->exact (round (bb-right bb))) 1) maximum-width)
(+ (inexact->exact (round (bb-bottom bb))) 1))) (min (+ (inexact->exact (round (bb-bottom bb))) 1) maximum-height)))
(define bdc (make-object bitmap-dc% cached-bitmap)) (define bdc (make-object bitmap-dc% cached-bitmap))
(send bdc erase) (send bdc erase)
(render-image this bdc 0 0) (render-image this bdc 0 0)