From 20cec1d43f382f57f78187ca3a2eeeae2e068bef Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 5 Jan 2014 17:12:57 -0700 Subject: [PATCH] image-snip%: preserve bitmap backing scale on save & load --- .../scribblings/gui/image-snip-class.scrbl | 10 +++-- pkgs/gui-pkgs/gui-lib/info.rkt | 2 + .../snip-lib/racket/snip/private/snip.rkt | 43 +++++++++++++------ 3 files changed, 38 insertions(+), 17 deletions(-) diff --git a/pkgs/gui-pkgs/gui-doc/scribblings/gui/image-snip-class.scrbl b/pkgs/gui-pkgs/gui-doc/scribblings/gui/image-snip-class.scrbl index 759272c2ec..958e1c3e6d 100644 --- a/pkgs/gui-pkgs/gui-doc/scribblings/gui/image-snip-class.scrbl +++ b/pkgs/gui-pkgs/gui-doc/scribblings/gui/image-snip-class.scrbl @@ -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?)]) diff --git a/pkgs/gui-pkgs/gui-lib/info.rkt b/pkgs/gui-pkgs/gui-lib/info.rkt index 8bceff5a7c..979675f951 100644 --- a/pkgs/gui-pkgs/gui-lib/info.rkt +++ b/pkgs/gui-pkgs/gui-lib/info.rkt @@ -28,3 +28,5 @@ (define pkg-desc "implementation (no documentation) part of \"gui\"") (define pkg-authors '(mflatt)) + +(define version "1.1") diff --git a/pkgs/snip-pkgs/snip-lib/racket/snip/private/snip.rkt b/pkgs/snip-pkgs/snip-lib/racket/snip/private/snip.rkt index 863ac15aca..2d3982faf6 100644 --- a/pkgs/snip-pkgs/snip-lib/racket/snip/private/snip.rkt +++ b/pkgs/snip-pkgs/snip-lib/racket/snip/private/snip.rkt @@ -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: