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

32
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]))])))
(define (to-bitmap img) ;; these are used when building a bitmap to render the final image
(let* ([bb (send img get-bb)] ;; they are probably smaller than the allowed maximum, but they are
[bm (make-bitmap ;; still huge
(inexact->exact (ceiling (bb-right bb))) (define maximum-width 5000)
(inexact->exact (ceiling (bb-bottom bb))))] (define maximum-height 5000)
[bdc (new bitmap-dc% [bitmap bm])])
(send bdc erase) (define (to-bitmap img)
(render-image img bdc 0 0) (define bb (send img get-bb))
(begin0 (define w (min (inexact->exact (ceiling (bb-right bb))) maximum-width))
(send bdc get-bitmap) (define h (min (inexact->exact (ceiling (bb-bottom bb))) maximum-height))
(send bdc set-bitmap #f)))) (define bm (make-bitmap w h))
(define bdc (new bitmap-dc% [bitmap bm]))
(render-image img bdc 0 0)
(send bdc set-bitmap #f)
bm)
(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)
@ -1032,7 +1036,7 @@ the mask bitmap and the original bitmap are all together in a single bytes!
(define sth (apply max latitudes)) (define sth (apply max latitudes))
(define new-w (ceiling (inexact->exact (- east west)))) (define new-w (ceiling (inexact->exact (- east west))))
(define new-h (ceiling (inexact->exact (- sth nrth)))) (define new-h (ceiling (inexact->exact (- sth nrth))))
(define new-bm (make-bitmap new-w new-h)) (define new-bm (make-bitmap new-w new-h))
(define bdc (make-object bitmap-dc% new-bm)) (define bdc (make-object bitmap-dc% new-bm))
(send bdc set-smoothing 'smoothed) (send bdc set-smoothing 'smoothed)