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

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

@ -811,8 +811,7 @@
(let-values ([(loadfile (let-values ([(loadfile
type type
inlined? inlined?)
delfile)
(if (and (equal? filename #"") (if (and (equal? filename #"")
can-inline? can-inline?
(positive? type)) (positive? type))
@ -821,24 +820,18 @@
(send f get-fixed len) (send f get-fixed len)
(if (and (len . > . 0) (if (and (len . > . 0)
(send f ok?)) (send f ok?))
(let ([fname (make-temporary-file "img~a")]) (let-values ([(in out) (make-pipe)])
(call-with-output-file*
fname
#:exists 'truncate
(lambda (fi)
(for ([i (in-range len)]) (for ([i (in-range len)])
(display (send f get-unterminated-bytes) fi)))) (display (send f get-unterminated-bytes) out))
(values fname (close-output-port out)
'unknown/mask (values in
#t 'unknown/alpha
fname)) #t))
(values filename (values filename
(int->img-type type) (int->img-type type)
#f
#f))) #f)))
(values filename (values filename
(int->img-type type) (int->img-type type)
#f
#f))]) #f))])
(let ([snip (make-object image-snip% (let ([snip (make-object image-snip%
(if (equal? loadfile #"") (if (equal? loadfile #"")
@ -849,8 +842,6 @@
type type
(positive? relative) (positive? relative)
inlined?)]) inlined?)])
(when delfile
(delete-file delfile))
(send snip resize w h) (send snip resize w h)
(send snip set-offset dx dy) (send snip set-offset dx dy)
@ -901,7 +892,7 @@
args args
[([bitmap% bm] [(make-or-false bitmap%) [mask #f]]) [([bitmap% bm] [(make-or-false bitmap%) [mask #f]])
(set-bitmap bm mask)] (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]] [image-type? [kind 'unknown]]
[bool? [relative-path? #f]] [bool? [relative-path? #f]]
[bool? [inline? #t]]) [bool? [inline? #t]])
@ -963,7 +954,7 @@
(and mask (and mask
(send mask ok?) (send mask ok?)
(= w (send mask get-width)) (= w (send mask get-width))
(= w (send mask get-height)) (= h (send mask get-height))
mask)))] mask)))]
[alpha (send dc get-alpha)]) [alpha (send dc get-alpha)])
(when (pair? caret) (when (pair? caret)
@ -1007,52 +998,56 @@
(send f put-fixed 0) (send f put-fixed 0)
(let ([num-lines (let ([num-lines
(let ([fname (make-temporary-file "img~a")]) (let-values ([(in out) (make-pipe)])
(send bm save-file fname 'png) (send bm save-file out 'png)
(begin0 (close-output-port out)
(call-with-input-file*
fname
(lambda (fi)
(let loop ([numlines 0]) (let loop ([numlines 0])
(let ([s (read-bytes IMG-MOVE-BUF-SIZE fi)]) (let ([s (read-bytes IMG-MOVE-BUF-SIZE in)])
(if (eof-object? s) (if (eof-object? s)
numlines numlines
(begin (begin
(send f put-unterminated s) (send f put-unterminated s)
(loop (add1 numlines)))))))) (loop (add1 numlines)))))))])
(delete-file fname)))])
(let ([end (send f tell)]) (let ([end (send f tell)])
(send f jump-to lenpos) (send f jump-to lenpos)
(send f put-fixed num-lines) (send f put-fixed num-lines)
(send f jump-to end))))))) (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]] [image-type? [kind 'unknown]]
[bool? [rel-path? #f]] [bool? [rel-path? #f]]
[bool? [inline? #t]]) [bool? [inline? #t]])
(do-set-bitmap #f #f #f) (do-set-bitmap #f #f #f)
(let* ([rel-path? (and rel-path? (let* ([rel-path? (and rel-path?
name (path-string? name)
(relative-path? name))] (relative-path? name))]
[name (if rel-path? [name (if rel-path?
name name
(and name (path->complete-path name)))]) (and name
(if (path-string? name)
(path->complete-path name)
name)))])
(set! s-flags (set! s-flags
(if rel-path? (if rel-path?
(add-flag s-flags USES-BUFFER-PATH) (add-flag s-flags USES-BUFFER-PATH)
(remove-flag s-flags USES-BUFFER-PATH))) (remove-flag s-flags USES-BUFFER-PATH)))
(let ([name (and name (if (string? name) (let ([orig-name name]
[name (and name
(path-string? name)
(if (string? name)
(string->path name) (string->path name)
name))]) name))])
(unless inline? (unless inline?
(set! filename name) (set! filename name)
(set! filetype kind)) (set! filetype kind))
(when name (when orig-name
(let ([fullpath (if rel-path? (let ([fullpath (if (input-port? orig-name)
orig-name
(if rel-path?
(path->complete-path (path->complete-path
name name
(or (and s-admin (or (and s-admin
@ -1064,7 +1059,7 @@
(and (path? base) (and (path? base)
(path->complete-path base)))))))) (path->complete-path base))))))))
(current-directory))) (current-directory)))
name)]) name))])
(let ([nbm (dynamic-wind (let ([nbm (dynamic-wind
begin-busy-cursor begin-busy-cursor
(lambda () (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. 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 [kind (one-of/c 'unknown 'unknown/mask 'unknown/alpha
'gif 'gif/mask 'gif/alpha 'gif 'gif/mask 'gif/alpha
'jpeg 'png 'png/mask 'png/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] [relative-path? any/c #f]
[inline? any/c #t]) [inline? any/c #t])
([bitmap (is-a?/c bitmap%)] ([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 specified (see also @method[image-snip% load-file]), or using the
given @scheme[bitmap]. given @scheme[bitmap].
@ -57,7 +57,7 @@ See also @scheme[equal<%>].}
@defmethod[(get-bitmap) @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 Returns the bitmap that is displayed by the snip, whether set through
@method[image-snip% set-bitmap] or @method[image-snip% load-file]. If @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) @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 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 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]) @defmethod[(get-filename [relative-path (or/c (box/c any/c) #f) #f])
(or/c path-string? false/c)]{ (or/c path-string? #f)]{
Returns the name of the currently loaded, non-inlined file, or 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 @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 [kind (one-of/c 'unknown 'unknown/mask 'unknown/alpha
'gif 'gif/mask 'gif/alpha 'gif 'gif/mask 'gif/alpha
'jpeg 'png 'png/mask 'png/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]) [inline? any/c #t])
void?]{ void?]{
Loads the file by passing @scheme[filename] and @scheme[kind] to Loads the file by passing @scheme[file] and @scheme[kind] to
@method[bitmap% load-file] If a bitmap had previously been specified @xmethod[bitmap% load-file]. If a bitmap had previously been specified
with @method[image-snip% set-bitmap], that bitmap (and mask) will no 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. image is cleared.
When @scheme['unknown/mask], @scheme['gif/mask], or @scheme['png/mask] When @scheme['unknown/mask], @scheme['gif/mask], or @scheme['png/mask]
is specified and the loaded bitmap object includes a mask (see is specified and the loaded bitmap object includes a mask (see
@method[bitmap% get-loaded-mask]), the mask is used for drawing the @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 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 owning editor's filename. If the image is not inlined, it will be
saved as a relative pathname. 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%)] @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?]{ void?]{
Sets the bitmap that is displayed by the snip. This method also Sets the bitmap that is displayed by the snip.
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).
The supplied bitmap must not be selected into a @scheme[bitmap-dc%] An optional @racket[mask] is used when drawing the bitmap (see
object, otherwise @|MismatchExn|, and it cannot be selected into @method[dc<%> draw-bitmap]), but supplying the mask directly is
a @scheme[bitmap-dc%] as long as it belongs to the snip, but it deprecated. If no mask is supplied but the bitmap's
can be used as a pen or brush stipple. @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.
} }