image-snip%: preserve bitmap backing scale on save & load
This commit is contained in:
Matthew Flatt
parent
b1acdfba86
commit
20cec1d43f
|
|
@ -14,7 +14,8 @@ An @racket[image-snip%] is a snip that can display bitmap images
|
|||
'jpeg 'png 'png/mask 'png/alpha
|
||||
'xbm 'xpm 'bmp 'pict) 'unknown]
|
||||
[relative-path? any/c #f]
|
||||
[inline? any/c #t])
|
||||
[inline? any/c #t]
|
||||
[backing-scale (>/c 0.0) 1.0])
|
||||
([bitmap (is-a?/c bitmap%)]
|
||||
[mask (or/c (is-a?/c bitmap%) #f) #f]))]{
|
||||
|
||||
|
|
@ -22,7 +23,7 @@ Creates an image snip, loading the image @racket[file] if
|
|||
specified (see also @method[image-snip% load-file]), or using the
|
||||
given @racket[bitmap].
|
||||
|
||||
}
|
||||
@history[#:changed "1.1" @elem{Added the @racket[backing-scale] argument.}]}
|
||||
|
||||
|
||||
@defmethod[(equal-hash-code-of [hash-code (any/c . -> . exact-integer?)])
|
||||
|
|
@ -91,7 +92,8 @@ Returns the kind used to load the currently loaded, non-inlined file,
|
|||
'jpeg 'png 'png/mask 'png/alpha
|
||||
'xbm 'xpm 'bmp 'pict) 'unknown]
|
||||
[relative-path? any/c #f]
|
||||
[inline? any/c #t])
|
||||
[inline? any/c #t]
|
||||
[backing-scale (>/c 0.0) 1.0])
|
||||
void?]{
|
||||
|
||||
Loads the file by passing @racket[file] and @racket[kind] to
|
||||
|
|
@ -117,7 +119,7 @@ If @racket[inline?] is not @racket[#f], the image data will be saved
|
|||
(preserving the bitmap's mask, if any). The source filename and kind
|
||||
is no longer relevant.
|
||||
|
||||
}
|
||||
@history[#:changed "1.1" @elem{Added the @racket[backing-scale] argument.}]}
|
||||
|
||||
@defmethod[(other-equal-to? [snip (is-a?/c image-snip%)]
|
||||
[equal? (any/c any/c . -> . boolean?)])
|
||||
|
|
|
|||
|
|
@ -28,3 +28,5 @@
|
|||
(define pkg-desc "implementation (no documentation) part of \"gui\"")
|
||||
|
||||
(define pkg-authors '(mflatt))
|
||||
|
||||
(define version "1.1")
|
||||
|
|
|
|||
|
|
@ -829,7 +829,8 @@
|
|||
|
||||
(let-values ([(loadfile
|
||||
type
|
||||
inlined?)
|
||||
inlined?
|
||||
backing-scale)
|
||||
(if (and (equal? filename #"")
|
||||
can-inline?
|
||||
(positive? type))
|
||||
|
|
@ -838,19 +839,26 @@
|
|||
(send f get-fixed len)
|
||||
(if (and (len . > . 0)
|
||||
(send f ok?))
|
||||
(let-values ([(in out) (make-pipe)])
|
||||
(let-values ([(in out) (make-pipe)]
|
||||
[(backing-scale)
|
||||
(if (= type 4)
|
||||
(send f get-inexact)
|
||||
1.0)])
|
||||
(for ([i (in-range len)])
|
||||
(display (send f get-unterminated-bytes) out))
|
||||
(close-output-port out)
|
||||
(values in
|
||||
'unknown/alpha
|
||||
#t))
|
||||
#t
|
||||
backing-scale))
|
||||
(values filename
|
||||
(int->img-type type)
|
||||
#f)))
|
||||
#f
|
||||
1.0)))
|
||||
(values filename
|
||||
(int->img-type type)
|
||||
#f))])
|
||||
#f
|
||||
1.0))])
|
||||
;; the call to create an image-snip% object
|
||||
;; here should match the way that super-make-object
|
||||
;; is called in wxme/image.rkt
|
||||
|
|
@ -862,7 +870,8 @@
|
|||
loadfile))
|
||||
type
|
||||
(positive? relative)
|
||||
inlined?)])
|
||||
inlined?
|
||||
backing-scale)])
|
||||
(send snip resize w h)
|
||||
(send snip set-offset dx dy)
|
||||
|
||||
|
|
@ -927,8 +936,9 @@
|
|||
[([(make-or-false (make-alts path-string? input-port?)) [name #f]]
|
||||
[image-type? [kind 'unknown]]
|
||||
[bool? [relative-path? #f]]
|
||||
[bool? [inline? #t]])
|
||||
(load-file name kind relative-path? inline?)]
|
||||
[bool? [inline? #t]]
|
||||
[positive-real? [backing-scale 1.0]])
|
||||
(load-file name kind relative-path? inline? backing-scale)]
|
||||
(init-name 'bitmap%))
|
||||
|
||||
(define (size-cache-invalid)
|
||||
|
|
@ -1015,9 +1025,12 @@
|
|||
[(= (send bm get-depth) 1)
|
||||
(send f put 1)
|
||||
'bm]
|
||||
[else
|
||||
[(= 1 (send bm get-backing-scale))
|
||||
(send f put 2)
|
||||
'pm]))])
|
||||
'pm]
|
||||
[else
|
||||
(send f put 4)
|
||||
'scaled-pm]))])
|
||||
(send f put vieww)
|
||||
(send f put viewh)
|
||||
(send f put viewdx)
|
||||
|
|
@ -1029,9 +1042,12 @@
|
|||
(let ([lenpos (send f tell)])
|
||||
(send f put-fixed 0)
|
||||
|
||||
(when (eq? write-mode 'scaled-pm)
|
||||
(send f put (send bm get-backing-scale)))
|
||||
|
||||
(let ([num-lines
|
||||
(let-values ([(in out) (make-pipe)])
|
||||
(send bm save-file out 'png)
|
||||
(send bm save-file out 'png #:unscaled? #t)
|
||||
(close-output-port out)
|
||||
(let loop ([numlines 0])
|
||||
(let ([s (read-bytes IMG-MOVE-BUF-SIZE in)])
|
||||
|
|
@ -1049,7 +1065,8 @@
|
|||
(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]])
|
||||
[bool? [inline? #t]]
|
||||
[positive-real? [backing-scale 1.0]])
|
||||
(do-set-bitmap #f #f #f)
|
||||
|
||||
(let* ([rel-path? (and rel-path?
|
||||
|
|
@ -1096,7 +1113,7 @@
|
|||
(send s-admin call-with-busy-cursor
|
||||
(lambda ()
|
||||
(make-object bitmap% fullpath kind)))
|
||||
(make-object bitmap% fullpath kind))])
|
||||
(make-object bitmap% fullpath kind #f #f backing-scale))])
|
||||
(when (send nbm ok?)
|
||||
(do-set-bitmap nbm #f #f))))))
|
||||
;; for refresh:
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user