Fixes for PNG conversion, and make `image-snip%' convertible.

This commit is contained in:
Sam Tobin-Hochstadt 2010-12-15 13:59:57 -05:00
parent d92ce41a6f
commit 13cae20838
2 changed files with 21 additions and 7 deletions

View File

@ -1,6 +1,6 @@
#lang scheme/base #lang scheme/base
(require scheme/class (require scheme/class
scheme/file scheme/file file/convertible
"../syntax.ss" "../syntax.ss"
"snip-flags.ss" "snip-flags.ss"
"private.ss" "private.ss"
@ -863,7 +863,18 @@
jpeg png png/mask png/alpha jpeg png png/mask png/alpha
xbm xpm bmp pict)) xbm xpm bmp pict))
(defclass* image-snip% internal-snip% (equal<%>) (define png-convertible<%>
(interface* ()
([prop:convertible
(lambda (img format default)
(case format
[(png-bytes)
(let ([s (open-output-bytes)])
(send (send img get-bitmap) save-file s 'png)
(get-output-bytes s))]
[else default]))])))
(defclass* image-snip% internal-snip% (equal<%> png-convertible<%>)
(inherit-field s-admin (inherit-field s-admin
s-flags) s-flags)
(inherit set-snipclass) (inherit set-snipclass)

View File

@ -28,6 +28,7 @@ has been moved out).
|# |#
(require racket/class (require racket/class
racket/draw
racket/gui/base racket/gui/base
racket/math racket/math
racket/contract racket/contract
@ -211,13 +212,15 @@ has been moved out).
(define (to-bitmap img) (define (to-bitmap img)
(let* ([bb (send img get-bb)] (let* ([bb (send img get-bb)]
[bm (make-object bitmap% [bm (make-bitmap
(add1 (inexact->exact (ceiling (bb-right bb)))) (add1 (inexact->exact (ceiling (bb-right bb))))
(add1 (inexact->exact (ceiling (bb-bottom bb)))))] (add1 (inexact->exact (ceiling (bb-bottom bb)))))]
[bdc (make-object bitmap-dc% bm)]) [bdc (new bitmap-dc% [bitmap bm])])
(send bdc clear) (send bdc clear)
(render-image img bdc 0 0) (render-image img bdc 0 0)
(send bdc get-bitmap))) (begin0
(send bdc get-bitmap)
(send bdc set-bitmap #f)))
(define image% (define image%
(class* snip% (png-convertible<%> equal<%> image<%>) (class* snip% (png-convertible<%> equal<%> image<%>)