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

image-snip%: preserve bitmap backing scale on save & load

Browse Source
This commit is contained in:
Matthew Flatt 2014-01-05 17:12:57 -07:00
parent b1acdfba86
commit 20cec1d43f
3 changed files with 38 additions and 17 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
pkgs/gui-pkgs/gui-doc/scribblings/gui/image-snip-class.scrbl
View File

@ -14,7 +14,8 @@ An @racket[image-snip%] is a snip that can display bitmap images
'jpeg 'png 'png/mask 'png/alpha 'jpeg 'png 'png/mask 'png/alpha
'xbm 'xpm 'bmp 'pict) 'unknown] 'xbm 'xpm 'bmp 'pict) 'unknown]
[relative-path? any/c #f] [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%)] ([bitmap (is-a?/c bitmap%)]
[mask (or/c (is-a?/c bitmap%) #f) #f]))]{ [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 specified (see also @method[image-snip% load-file]), or using the
given @racket[bitmap]. 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?)]) @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 'jpeg 'png 'png/mask 'png/alpha
'xbm 'xpm 'bmp 'pict) 'unknown] 'xbm 'xpm 'bmp 'pict) 'unknown]
[relative-path? any/c #f] [relative-path? any/c #f]
[inline? any/c #t]) [inline? any/c #t]
[backing-scale (>/c 0.0) 1.0])
void?]{ void?]{
Loads the file by passing @racket[file] and @racket[kind] to 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 (preserving the bitmap's mask, if any). The source filename and kind
is no longer relevant. 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%)] @defmethod[(other-equal-to? [snip (is-a?/c image-snip%)]
[equal? (any/c any/c . -> . boolean?)]) [equal? (any/c any/c . -> . boolean?)])

2
pkgs/gui-pkgs/gui-lib/info.rkt
View File

@ -28,3 +28,5 @@
(define pkg-desc "implementation (no documentation) part of \"gui\"") (define pkg-desc "implementation (no documentation) part of \"gui\"")
(define pkg-authors '(mflatt)) (define pkg-authors '(mflatt))
(define version "1.1")

43
pkgs/snip-pkgs/snip-lib/racket/snip/private/snip.rkt
View File

@ -829,7 +829,8 @@
(let-values ([(loadfile (let-values ([(loadfile
type type
inlined?) inlined?
backing-scale)
(if (and (equal? filename #"") (if (and (equal? filename #"")
can-inline? can-inline?
(positive? type)) (positive? type))
@ -838,19 +839,26 @@
(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-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)]) (for ([i (in-range len)])
(display (send f get-unterminated-bytes) out)) (display (send f get-unterminated-bytes) out))
(close-output-port out) (close-output-port out)
(values in (values in
'unknown/alpha 'unknown/alpha
#t)) #t
backing-scale))
(values filename (values filename
(int->img-type type) (int->img-type type)
#f))) #f
1.0)))
(values filename (values filename
(int->img-type type) (int->img-type type)
#f))]) #f
1.0))])
;; the call to create an image-snip% object ;; the call to create an image-snip% object
;; here should match the way that super-make-object ;; here should match the way that super-make-object
;; is called in wxme/image.rkt ;; is called in wxme/image.rkt
@ -862,7 +870,8 @@
loadfile)) loadfile))
type type
(positive? relative) (positive? relative)
inlined?)]) inlined?
backing-scale)])
(send snip resize w h) (send snip resize w h)
(send snip set-offset dx dy) (send snip set-offset dx dy)
@ -927,8 +936,9 @@
[([(make-or-false (make-alts path-string? input-port?)) [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]]
(load-file name kind relative-path? inline?)] [positive-real? [backing-scale 1.0]])
(load-file name kind relative-path? inline? backing-scale)]
(init-name 'bitmap%)) (init-name 'bitmap%))
(define (size-cache-invalid) (define (size-cache-invalid)
@ -1015,9 +1025,12 @@
[(= (send bm get-depth) 1) [(= (send bm get-depth) 1)
(send f put 1) (send f put 1)
'bm] 'bm]
[else [(= 1 (send bm get-backing-scale))
(send f put 2) (send f put 2)
'pm]))]) 'pm]
[else
(send f put 4)
'scaled-pm]))])
(send f put vieww) (send f put vieww)
(send f put viewh) (send f put viewh)
(send f put viewdx) (send f put viewdx)
@ -1029,9 +1042,12 @@
(let ([lenpos (send f tell)]) (let ([lenpos (send f tell)])
(send f put-fixed 0) (send f put-fixed 0)
(when (eq? write-mode 'scaled-pm)
(send f put (send bm get-backing-scale)))
(let ([num-lines (let ([num-lines
(let-values ([(in out) (make-pipe)]) (let-values ([(in out) (make-pipe)])
(send bm save-file out 'png) (send bm save-file out 'png #:unscaled? #t)
(close-output-port out) (close-output-port out)
(let loop ([numlines 0]) (let loop ([numlines 0])
(let ([s (read-bytes IMG-MOVE-BUF-SIZE in)]) (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]] (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]]
[positive-real? [backing-scale 1.0]])
(do-set-bitmap #f #f #f) (do-set-bitmap #f #f #f)
(let* ([rel-path? (and rel-path? (let* ([rel-path? (and rel-path?
@ -1096,7 +1113,7 @@
(send s-admin call-with-busy-cursor (send s-admin call-with-busy-cursor
(lambda () (lambda ()
(make-object bitmap% fullpath kind))) (make-object bitmap% fullpath kind)))
(make-object bitmap% fullpath kind))]) (make-object bitmap% fullpath kind #f #f backing-scale))])
(when (send nbm ok?) (when (send nbm ok?)
(do-set-bitmap nbm #f #f)))))) (do-set-bitmap nbm #f #f))))))
;; for refresh: ;; for refresh: