Fixes for PNG conversion, and make `image-snip%' convertible.
This commit is contained in:
parent
d92ce41a6f
commit
13cae20838
|
@ -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)
|
||||||
|
|
|
@ -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<%>)
|
||||||
|
|
Loading…
Reference in New Issue
Block a user