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

fix problems with image-snip%, masks or alpha channels, and saving

Browse Source 
and also generalize image-snip% to accept input port instead
 of filenames, and avoid temporary files for loading and saving images
This commit is contained in:
Matthew Flatt 2010-12-14 21:09:58 -07:00
parent 0542d3ca70
commit cad500d802
2 changed files with 73 additions and 79 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

101
collects/mred/private/wxme/snip.rkt
View File

@ -811,8 +811,7 @@
(let-values ([(loadfile
type
inlined?
delfile)
inlined?)
(if (and (equal? filename #"")
can-inline?
(positive? type))
@ -821,24 +820,18 @@
(send f get-fixed len)
(if (and (len . > . 0)
(send f ok?))
(let ([fname (make-temporary-file "img~a")])
(call-with-output-file*
fname
#:exists 'truncate
(lambda (fi)
(for ([i (in-range len)])
(display (send f get-unterminated-bytes) fi))))
(values fname
'unknown/mask
#t
fname))
(let-values ([(in out) (make-pipe)])
(for ([i (in-range len)])
(display (send f get-unterminated-bytes) out))
(close-output-port out)
(values in
'unknown/alpha
#t))
(values filename
(int->img-type type)
#f
#f)))
(values filename
(int->img-type type)
#f
#f))])
(let ([snip (make-object image-snip%
(if (equal? loadfile #"")
@ -849,8 +842,6 @@
type
(positive? relative)
inlined?)])
(when delfile
(delete-file delfile))
(send snip resize w h)
(send snip set-offset dx dy)
@ -901,7 +892,7 @@
args
[([bitmap% bm] [(make-or-false bitmap%) [mask #f]])
(set-bitmap bm mask)]
[([(make-or-false path-string?) [name #f]]
[([(make-or-false (make-alts path-string? input-port?)) [name #f]]
[image-type? [kind 'unknown]]
[bool? [relative-path? #f]]
[bool? [inline? #t]])
@ -963,7 +954,7 @@
(and mask
(send mask ok?)
(= w (send mask get-width))
(= w (send mask get-height))
(= h (send mask get-height))
mask)))]
[alpha (send dc get-alpha)])
(when (pair? caret)
@ -1007,64 +998,68 @@
(send f put-fixed 0)
(let ([num-lines
(let ([fname (make-temporary-file "img~a")])
(send bm save-file fname 'png)
(begin0
(call-with-input-file*
fname
(lambda (fi)
(let loop ([numlines 0])
(let ([s (read-bytes IMG-MOVE-BUF-SIZE fi)])
(if (eof-object? s)
numlines
(begin
(send f put-unterminated s)
(loop (add1 numlines))))))))
(delete-file fname)))])
(let-values ([(in out) (make-pipe)])
(send bm save-file out 'png)
(close-output-port out)
(let loop ([numlines 0])
(let ([s (read-bytes IMG-MOVE-BUF-SIZE in)])
(if (eof-object? s)
numlines
(begin
(send f put-unterminated s)
(loop (add1 numlines)))))))])
(let ([end (send f tell)])
(send f jump-to lenpos)
(send f put-fixed num-lines)
(send f jump-to end)))))))
(def/public (load-file [(make-or-false path-string?) [name #f]]
(def/public (load-file [(make-or-false (make-alts path-string? input-port?)) [name #f]]
[image-type? [kind 'unknown]]
[bool? [rel-path? #f]]
[bool? [inline? #t]])
(do-set-bitmap #f #f #f)
(let* ([rel-path? (and rel-path?
name
(path-string? name)
(relative-path? name))]
[name (if rel-path?
name
(and name (path->complete-path name)))])
(and name
(if (path-string? name)
(path->complete-path name)
name)))])
(set! s-flags
(if rel-path?
(add-flag s-flags USES-BUFFER-PATH)
(remove-flag s-flags USES-BUFFER-PATH)))
(let ([name (and name (if (string? name)
(string->path name)
name))])
(let ([orig-name name]
[name (and name
(path-string? name)
(if (string? name)
(string->path name)
name))])
(unless inline?
(set! filename name)
(set! filetype kind))
(when name
(let ([fullpath (if rel-path?
(path->complete-path
name
(or (and s-admin
(let ([e (send s-admin get-editor)])
(and e
(let ([fn (send e get-filename)])
(and fn
(let-values ([(base name dir?) (split-path fn)])
(and (path? base)
(path->complete-path base))))))))
(current-directory)))
name)])
(when orig-name
(let ([fullpath (if (input-port? orig-name)
orig-name
(if rel-path?
(path->complete-path
name
(or (and s-admin
(let ([e (send s-admin get-editor)])
(and e
(let ([fn (send e get-filename)])
(and fn
(let-values ([(base name dir?) (split-path fn)])
(and (path? base)
(path->complete-path base))))))))
(current-directory)))
name))])
(let ([nbm (dynamic-wind
begin-busy-cursor
(lambda ()

51
collects/scribblings/gui/image-snip-class.scrbl
View File

@ -8,7 +8,7 @@ An @scheme[image-snip%] is a snip that can display bitmap images
box containing an ``X'' is drawn.
@defconstructor*/make[(([filename (or/c path-string? false/c) #f]
@defconstructor*/make[(([file (or/c path-string? input-port? #f) #f]
[kind (one-of/c 'unknown 'unknown/mask 'unknown/alpha
'gif 'gif/mask 'gif/alpha
'jpeg 'png 'png/mask 'png/alpha
@ -16,9 +16,9 @@ An @scheme[image-snip%] is a snip that can display bitmap images
[relative-path? any/c #f]
[inline? any/c #t])
([bitmap (is-a?/c bitmap%)]
[mask (or/c (is-a?/c bitmap%) false/c) #f]))]{
[mask (or/c (is-a?/c bitmap%) #f) #f]))]{
Creates an image snip, loading the image @scheme[filename] if
Creates an image snip, loading the image @scheme[file] if
specified (see also @method[image-snip% load-file]), or using the
given @scheme[bitmap].
@ -57,7 +57,7 @@ See also @scheme[equal<%>].}
@defmethod[(get-bitmap)
(or/c (is-a?/c bitmap%) false/c)]{
(or/c (is-a?/c bitmap%) #f)]{
Returns the bitmap that is displayed by the snip, whether set through
@method[image-snip% set-bitmap] or @method[image-snip% load-file]. If
@ -70,7 +70,7 @@ The returned bitmap cannot be selected into a @scheme[bitmap-dc%] as
}
@defmethod[(get-bitmap-mask)
(or/c (is-a?/c bitmap%) false/c)]{
(or/c (is-a?/c bitmap%) #f)]{
Returns the mask bitmap that is used for displaying by the snip, if
one was installed with @method[image-snip% set-bitmap]. If no mask
@ -82,8 +82,8 @@ The returned bitmap cannot be selected into a @scheme[bitmap-dc%] as
}
@defmethod[(get-filename [relative-path (or/c (box/c any/c) false/c) #f])
(or/c path-string? false/c)]{
@defmethod[(get-filename [relative-path (or/c (box/c any/c) #f) #f])
(or/c path-string? #f)]{
Returns the name of the currently loaded, non-inlined file, or
@scheme[#f] if a file is not loaded or if a file was loaded with
@ -106,7 +106,7 @@ Returns the kind used to load the currently loaded, non-inlined file,
}
@defmethod[(load-file [filename (or/c path-string? false/c)]
@defmethod[(load-file [file (or/c path-string? input-port? #f)]
[kind (one-of/c 'unknown 'unknown/mask 'unknown/alpha
'gif 'gif/mask 'gif/alpha
'jpeg 'png 'png/mask 'png/alpha
@ -115,18 +115,20 @@ Returns the kind used to load the currently loaded, non-inlined file,
[inline? any/c #t])
void?]{
Loads the file by passing @scheme[filename] and @scheme[kind] to
@method[bitmap% load-file] If a bitmap had previously been specified
Loads the file by passing @scheme[file] and @scheme[kind] to
@xmethod[bitmap% load-file]. If a bitmap had previously been specified
with @method[image-snip% set-bitmap], that bitmap (and mask) will no
longer be used. If @scheme[filename] is @scheme[#f], then the current
longer be used. If @scheme[file] is @scheme[#f], then the current
image is cleared.
When @scheme['unknown/mask], @scheme['gif/mask], or @scheme['png/mask]
is specified and the loaded bitmap object includes a mask (see
@method[bitmap% get-loaded-mask]), the mask is used for drawing the
bitmap (see @method[dc<%> draw-bitmap]).
bitmap (see @method[dc<%> draw-bitmap]). The @scheme['unknown/alpha],
@scheme['gif/alpha], or @scheme['png/alpha] variants are recommended,
however.
If @scheme[relative-path?] is not @scheme[#f] and @scheme[filename] is a
If @scheme[relative-path?] is not @scheme[#f] and @scheme[file] is a
relative path, then the file will be read using the path of the
owning editor's filename. If the image is not inlined, it will be
saved as a relative pathname.
@ -162,22 +164,19 @@ The bitmap will be cropped to fit in the given dimensions.
}
@defmethod[(set-bitmap [bm (is-a?/c bitmap%)]
[mask (or/c (is-a?/c bitmap%) false/c) #f])
[mask (or/c (is-a?/c bitmap%) #f) #f])
void?]{
Sets the bitmap that is displayed by the snip. This method also
accepts an optional mask to be used when drawing the bitmap (see
@method[dc<%> draw-bitmap]), but supplying the mask directly is now
deprecated. Instead, if no mask is supplied but the bitmap's
@method[bitmap% get-loaded-mask] method produces a bitmap of the same
dimensions, it is used as the mask. Furthermore, such a mask is saved
with the snip when it is saved to a file or copied (whereas a
directly supplied mask is not saved).
Sets the bitmap that is displayed by the snip.
The supplied bitmap must not be selected into a @scheme[bitmap-dc%]
object, otherwise @|MismatchExn|, and it cannot be selected into
a @scheme[bitmap-dc%] as long as it belongs to the snip, but it
can be used as a pen or brush stipple.
An optional @racket[mask] is used when drawing the bitmap (see
@method[dc<%> draw-bitmap]), but supplying the mask directly is
deprecated. If no mask is supplied but the bitmap's
@method[bitmap% get-loaded-mask] method produces a bitmap of the same
dimensions, it is used as the mask; furthermore, such a mask is saved
with the snip when it is saved to a file or copied (whereas a
directly supplied mask is not saved). Typically, however, @racket[bm]
instead should have an alpha channel instead of a separate mask bitmap.
}