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

racket/draw: add #:try-@2x? argument to read-bitmap

Browse Source
This commit is contained in:
Matthew Flatt 2014-01-03 08:38:15 -07:00
parent 4ee266fd97
commit 90a534f304
2 changed files with 26 additions and 4 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
pkgs/draw-pkgs/draw-doc/scribblings/draw/draw-funcs.scrbl
View File

@ -179,13 +179,21 @@ on Windows and Mac OS X. See @secref["Portability"] for more information.}
'unknown/alpha] 'unknown/alpha]
[bg-color (or/c (is-a?/c color%) #f) #f] [bg-color (or/c (is-a?/c color%) #f) #f]
[complain-on-failure? any/c #t] [complain-on-failure? any/c #t]
[#:backing-scale backing-scale (>/c 0.0) 1.0]) [#:backing-scale backing-scale (>/c 0.0) 1.0]
[#:try-@2x? try-@2x? any/c #f])
(is-a?/c bitmap%)]{ (is-a?/c bitmap%)]{
Returns @racket[(make-object bitmap% in kind bg-color Returns @racket[(make-object bitmap% in kind bg-color
complain-on-failure? backing-scale)], but this procedure is preferred complain-on-failure? backing-scale)], but this procedure is preferred
because it defaults @racket[kind] and @racket[complain-on-failure?] in because it defaults @racket[kind] and @racket[complain-on-failure?] in
a more useful way.} a more useful way.
If @racket[try-@2x?] is true, @racket[in] is a path, and @racket[kind]
is not one of the @racketidfont{/mask} symbols, then
@racket[read-bitmap] checks whether a file exists matching @racket[in]
but with @filepath{@"@"2x} added to the name (before the file suffix,
if any). If the @filepath{@"@"2x} path exists, it is used instead of
@racket[in], and @racket[backing-store] is multiplied by @racket[2].}
@defproc[(recorded-datum->procedure [datum any/c]) ((is-a?/c dc<%>) . -> . void?)]{ @defproc[(recorded-datum->procedure [datum any/c]) ((is-a?/c dc<%>) . -> . void?)]{

18
pkgs/draw-pkgs/draw-lib/racket/draw/private/bitmap.rkt
View File

@ -947,11 +947,25 @@
#:backing-scale [nonnegative-real? [backing-scale 1.0]]) #:backing-scale [nonnegative-real? [backing-scale 1.0]])
(make-object bitmap% w h #f alpha? backing-scale)) (make-object bitmap% w h #f alpha? backing-scale))
(define/top (read-bitmap [(make-alts path-string? input-port?) filename] (define/top (read-bitmap [(make-alts path-string? input-port?) given-filename]
[bitmap-file-kind-symbol? [kind 'unknown/alpha]] [bitmap-file-kind-symbol? [kind 'unknown/alpha]]
[(make-or-false color%) [bg-color #f]] [(make-or-false color%) [bg-color #f]]
[any? [complain-on-failure? #t]] [any? [complain-on-failure? #t]]
#:backing-scale [nonnegative-real? [backing-scale 1.0]]) #:try-@2x? [any? [try-@2x? #f]]
#:backing-scale [nonnegative-real? [given-backing-scale 1.0]])
(define-values (filename backing-scale)
(cond
[(and try-@2x?
(path? given-filename)
(not (memq kind '(unknown/mask gif/mask png/mask))))
(define new-filename (bytes->path
(regexp-replace #rx"([.][^.]*|)$"
(path->bytes given-filename)
#"@2x\\1")))
(if (file-exists? new-filename)
(values new-filename (* 2 given-backing-scale))
(values given-filename given-backing-scale))]
[else (values given-filename given-backing-scale)]))
(make-object bitmap% filename kind bg-color complain-on-failure? backing-scale)) (make-object bitmap% filename kind bg-color complain-on-failure? backing-scale))
(define/top (make-monochrome-bitmap [exact-positive-integer? w] (define/top (make-monochrome-bitmap [exact-positive-integer? w]