Skip to content

Commit 7dc5e12

Browse files
rfindlerrfindler
committed
adjust image-snip%s to save using the bytes in get-data-from-file and,
when constructing a bitmap from a file, to request that data be saved related to racket/htdp#105
1 parent 033a612 commit 7dc5e12

File tree

2 files changed

+82
-56
lines changed

2 files changed

+82
-56
lines changed

‎snip-lib/info.rkt

+1-1
Original file line numberDiff line numberDiff line change
@@ -3,7 +3,7 @@
33
(define collection 'multi)
44

55
(define deps '("base"
6-
"draw-lib"))
6+
["draw-lib" #:version "1.17"]))
77

88
(define pkg-desc "implementation (no documentation) part of \"snip\"")
99

‎snip-lib/racket/snip/private/snip.rkt

+81-55
Original file line numberDiff line numberDiff line change
@@ -1,11 +1,13 @@
11
#lang racket/base
22
(require racket/class
3+
racket/match
34
racket/file file/convertible
45
"snip-flags.rkt"
56
"load-one.rkt"
67
"style.rkt"
78
"private.rkt"
89
racket/draw/private/syntax
10+
(only-in racket/draw/private/bitmap specialize-unknown-kind)
911
racket/draw)
1012

1113
(provide snip%
@@ -831,39 +833,41 @@
831833
(send f get dx)
832834
(send f get dy)
833835
(send f get relative))
834-
835-
(let-values ([(loadfile
836-
type
837-
inlined?
838-
backing-scale)
839-
(if (and (equal? filename #"")
840-
can-inline?
841-
(positive? type))
842-
;; read inlined image
843-
(let-boxes ([len 0])
844-
(send f get-fixed len)
845-
(if (and (len . > . 0)
846-
(send f ok?))
847-
(let-values ([(in out) (make-pipe)]
848-
[(backing-scale)
849-
(if (= type 4)
850-
(send f get-inexact)
851-
1.0)])
852-
(for ([i (in-range len)])
853-
(display (send f get-unterminated-bytes) out))
854-
(close-output-port out)
855-
(values in
856-
'unknown/alpha
857-
#t
858-
backing-scale))
859-
(values filename
860-
(int->img-type type)
861-
#f
862-
1.0)))
863-
(values filename
864-
(int->img-type type)
865-
#f
866-
1.0))])
836+
(define-values (loadfile
837+
kind
838+
inlined?
839+
backing-scale)
840+
(cond
841+
[(and (equal? filename #"")
842+
can-inline?
843+
(positive? type))
844+
;; read inlined image
845+
(define len (send f get-fixed-exact))
846+
(cond
847+
[(and (len . > . 0)
848+
(send f ok?))
849+
(let-values ([(in out) (make-pipe)]
850+
[(backing-scale)
851+
(if (= type 4)
852+
(send f get-inexact)
853+
1.0)])
854+
(for ([i (in-range len)])
855+
(display (send f get-unterminated-bytes) out))
856+
(close-output-port out)
857+
(values in
858+
'unknown/alpha
859+
#t
860+
backing-scale))]
861+
[else
862+
(values filename
863+
(int->img-type type)
864+
#f
865+
1.0)])]
866+
[else
867+
(values filename
868+
(int->img-type type)
869+
#f
870+
1.0)]))
867871
;; the call to create an image-snip% object
868872
;; here should match the way that super-make-object
869873
;; is called in wxme/image.rkt
@@ -873,14 +877,14 @@
873877
(if (bytes? loadfile)
874878
(bytes->path loadfile)
875879
loadfile))
876-
type
880+
kind
877881
(positive? relative)
878882
inlined?
879883
backing-scale)])
880884
(send snip resize w h)
881885
(send snip set-offset dx dy)
882886

883-
snip)))))))
887+
snip))))))
884888

885889
;; ------------------------------------------------------------
886890

@@ -932,6 +936,7 @@
932936
(define viewdx 0.0)
933937
(define viewdy 0.0)
934938
(define contents-changed? #f)
939+
(define bytes-from-png-fallback #f)
935940

936941
(super-new)
937942

@@ -1049,26 +1054,47 @@
10491054
;; inline the image
10501055
(let ([lenpos (send f tell)])
10511056
(send f put-fixed 0)
1052-
10531057
(when (eq? write-mode 'scaled-pm)
10541058
(send f put (send bm get-backing-scale)))
1055-
1056-
(let ([num-lines
1057-
(let-values ([(in out) (make-pipe)])
1058-
(send bm save-file out 'png #:unscaled? #t)
1059-
(close-output-port out)
1060-
(let loop ([numlines 0])
1061-
(let ([s (read-bytes IMG-MOVE-BUF-SIZE in)])
1062-
(if (eof-object? s)
1063-
numlines
1064-
(begin
1065-
(send f put-unterminated s)
1066-
(loop (add1 numlines)))))))])
1067-
1068-
(let ([end (send f tell)])
1069-
(send f jump-to lenpos)
1070-
(send f put-fixed num-lines)
1071-
(send f jump-to end)))))))
1059+
(define data-from-file (send bm get-data-from-file))
1060+
(define (png-bytes-fallback)
1061+
(unless bytes-from-png-fallback
1062+
(define bp (open-output-bytes))
1063+
(send bm save-file bp 'png #:unscaled? #t)
1064+
(close-output-port bp)
1065+
(set! bytes-from-png-fallback (get-output-bytes bp)))
1066+
(open-input-bytes bytes-from-png-fallback))
1067+
(define in
1068+
(match data-from-file
1069+
[(vector kind bg-color bytes)
1070+
(cond
1071+
[(saved-data-compatible-with-loading-code? kind bg-color bytes)
1072+
(open-input-bytes bytes)]
1073+
[else (png-bytes-fallback)])]
1074+
[#f
1075+
(png-bytes-fallback)]))
1076+
(define num-lines
1077+
(let loop ([numlines 0])
1078+
(let ([s (read-bytes IMG-MOVE-BUF-SIZE in)])
1079+
(if (eof-object? s)
1080+
numlines
1081+
(begin
1082+
(send f put-unterminated s)
1083+
(loop (add1 numlines)))))))
1084+
(define end (send f tell))
1085+
(send f jump-to lenpos)
1086+
(send f put-fixed num-lines)
1087+
(send f jump-to end)))))
1088+
1089+
(define/private (saved-data-compatible-with-loading-code? kind bg-color bytes)
1090+
(and (not bg-color)
1091+
(case kind
1092+
[(unknown/apha) #t]
1093+
[(unknown/mask unknown)
1094+
(equal? (specialize-unknown-kind (open-input-bytes bytes) kind)
1095+
(specialize-unknown-kind (open-input-bytes bytes) 'unknown/alpha))]
1096+
[else
1097+
(equal? kind (specialize-unknown-kind (open-input-bytes bytes) 'unknown/alpha))])))
10721098

10731099
(def/public (load-file [(make-or-false (make-alts path-string? input-port?)) [name #f]]
10741100
[image-type? [kind 'unknown]]
@@ -1120,8 +1146,8 @@
11201146
(let ([nbm (if s-admin
11211147
(send s-admin call-with-busy-cursor
11221148
(lambda ()
1123-
(make-object bitmap% fullpath kind)))
1124-
(make-object bitmap% fullpath kind #f #f backing-scale))])
1149+
(make-object bitmap% fullpath kind #f #f 1.0 #t)))
1150+
(make-object bitmap% fullpath kind #f #f backing-scale #t))])
11251151
(when (send nbm ok?)
11261152
(do-set-bitmap nbm #f #f))))))
11271153
;; for refresh:

0 commit comments

Comments
 (0)