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

make 2htdp/image images convertible to picts

Browse Source
This commit is contained in:
Robby Findler 2013-01-18 20:15:07 -06:00
parent 193bff7a2b
commit ccbedb652f
2 changed files with 20 additions and 3 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -55,6 +55,8 @@
wxme wxme
rackunit rackunit
file/convertible file/convertible
slideshow/pict-convert
(only-in slideshow/pict pict?)
(only-in lang/imageeq image=?) (only-in lang/imageeq image=?)
(prefix-in 1: htdp/image) (prefix-in 1: htdp/image)
(only-in lang/htdp-advanced equal~?) (only-in lang/htdp-advanced equal~?)
@ -2317,6 +2319,8 @@
(test (convertible? (circle 20 "solid" "red")) => #t) (test (convertible? (circle 20 "solid" "red")) => #t)
(test (bytes? (convert (circle 20 "solid" "red") 'png-bytes)) => #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 () (let ()
(define tmpfile (make-temporary-file "2htdpimage-test-~a")) (define tmpfile (make-temporary-file "2htdpimage-test-~a"))
(define i (circle 15 "solid" "red")) (define i (circle 15 "solid" "red"))

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

@ -32,6 +32,8 @@ has been moved out).
make-pen make-color) make-pen make-color)
(for-syntax racket/base) (for-syntax racket/base)
file/convertible file/convertible
slideshow/pict-convert
(prefix-in pict: (only-in slideshow/pict dc))
racket/math racket/math
racket/contract racket/contract
"private/image-core-bitmap.rkt" "private/image-core-bitmap.rkt"
@ -220,7 +222,7 @@ has been moved out).
(define skip-image-equality-fast-path (make-parameter #f)) (define skip-image-equality-fast-path (make-parameter #f))
(define render-normalized (make-parameter #f)) (define render-normalized (make-parameter #f))
(define png-convertible<%> (define convertible<%>
(interface* () (interface* ()
([prop:convertible ([prop:convertible
(lambda (img format default) (lambda (img format default)
@ -229,7 +231,18 @@ has been moved out).
(let ([s (open-output-bytes)]) (let ([s (open-output-bytes)])
(send (to-bitmap (to-img img)) save-file s 'png) (send (to-bitmap (to-img img)) save-file s 'png)
(get-output-bytes s))] (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 ;; these are used when building a bitmap to render the final image
;; they are probably smaller than the allowed maximum, but they are ;; they are probably smaller than the allowed maximum, but they are
@ -253,7 +266,7 @@ has been moved out).
compute-cached-bitmap) compute-cached-bitmap)
(define image% (define image%
(class* snip% (png-convertible<%> image<%>) (class* snip% (convertible<%> image<%>)
(init-field shape bb normalized? pinhole) (init-field shape bb normalized? pinhole)
(define/override (equal-to? that eq-recur) (compare-em that eq-recur)) (define/override (equal-to? that eq-recur) (compare-em that eq-recur))