diff --git a/collects/2htdp/tests/test-image.rkt b/collects/2htdp/tests/test-image.rkt index 284aea785c..84de83bfd4 100644 --- a/collects/2htdp/tests/test-image.rkt +++ b/collects/2htdp/tests/test-image.rkt @@ -55,6 +55,8 @@ wxme rackunit file/convertible + slideshow/pict-convert + (only-in slideshow/pict pict?) (only-in lang/imageeq image=?) (prefix-in 1: htdp/image) (only-in lang/htdp-advanced equal~?) @@ -2317,6 +2319,8 @@ (test (convertible? (circle 20 "solid" "red")) => #t) (test (bytes? (convert (circle 20 "solid" "red") 'png-bytes)) => #t) +(test (pict-convertible? (circle 20 "solid" "red")) => #t) +(test (pict? (pict-convert (circle 20 "solid" "red"))) => #t) (let () (define tmpfile (make-temporary-file "2htdpimage-test-~a")) (define i (circle 15 "solid" "red")) diff --git a/collects/mrlib/image-core.rkt b/collects/mrlib/image-core.rkt index b047b8ab64..3d560e7950 100644 --- a/collects/mrlib/image-core.rkt +++ b/collects/mrlib/image-core.rkt @@ -32,6 +32,8 @@ has been moved out). make-pen make-color) (for-syntax racket/base) file/convertible + slideshow/pict-convert + (prefix-in pict: (only-in slideshow/pict dc)) racket/math racket/contract "private/image-core-bitmap.rkt" @@ -220,7 +222,7 @@ has been moved out). (define skip-image-equality-fast-path (make-parameter #f)) (define render-normalized (make-parameter #f)) -(define png-convertible<%> +(define convertible<%> (interface* () ([prop:convertible (lambda (img format default) @@ -229,7 +231,18 @@ has been moved out). (let ([s (open-output-bytes)]) (send (to-bitmap (to-img img)) save-file s 'png) (get-output-bytes s))] - [else default]))]))) + [else default]))] + [prop:pict-convertible + (λ (image) + (define the-bb (send image get-bb)) + (pict:dc + (λ (dc dx dy) + (render-image image dc dx dy)) + (ceiling (inexact->exact (bb-right the-bb))) + (ceiling (inexact->exact (bb-bottom the-bb))) + 0 + (ceiling (inexact->exact (- (bb-bottom the-bb) + (bb-baseline the-bb))))))]))) ;; these are used when building a bitmap to render the final image ;; they are probably smaller than the allowed maximum, but they are @@ -253,7 +266,7 @@ has been moved out). compute-cached-bitmap) (define image% - (class* snip% (png-convertible<%> image<%>) + (class* snip% (convertible<%> image<%>) (init-field shape bb normalized? pinhole) (define/override (equal-to? that eq-recur) (compare-em that eq-recur))