[racket-dev] [plt] Push #28005: master branch updated
This has had one unintentional side effect: 2x bitmaps like DrRacket's
icons and logos have to be drawn *with smoothing turned on*, or they
look jagged. This is an issue with bitmaps on GUIs, whose device
contexts generally have smoothing turned off.
DrRacket's little running man is the easiest example to see, but check
out the Macro Stepper's About dialog for the most terrible.
I can change `bitmap-canvas%' in "images/gui.rkt" so that it always
draws bitmaps smoothed. That would fix all the icon and logo problems
I've seen. But I worry about making other users do this. It would be
great if they never had to think about the internal resolution of the
icons they use.
But I'm not sure what the Right Thing is. Here's one idea: if drawing a
bitmap with backing scale != 1 and smoothing is off, rescale the bitmap
first and draw the rescaled version. (Is that what
`call-with-alt-bitmap' is for?) Such uses would get no benefit from
higher resolution, but transformations look like crap without smoothing
anyway.
Neil ⊥
On 01/02/2014 07:28 PM, mflatt at racket-lang.org wrote:
> mflatt has updated `master' from 533a2f21f8 to 4ee266fd97.
> http://git.racket-lang.org/plt/533a2f21f8..4ee266fd97
>
> =====[ 3 Commits ]======================================================
> Directory summary:
> 22.3% pkgs/draw-pkgs/draw-doc/scribblings/draw/
> 49.7% pkgs/draw-pkgs/draw-lib/racket/draw/private/
> 3.0% pkgs/gui-pkgs/gui-lib/mred/private/wx/
> 11.4% pkgs/gui-pkgs/gui-test/tests/gracket/
> 3.7% pkgs/images-pkgs/images-lib/images/icons/
> 3.3% pkgs/images-pkgs/images-lib/images/private/
> 4.9% pkgs/images-pkgs/images-lib/images/
>
> ~~~~~~~~~~
>
> 4f86f1d Matthew Flatt <mflatt at racket-lang.org> 2014-01-02 07:14
> :
> | racket/gui cocoa: preserve resolution of bitmaps as control labels
> |
> | This change is mainly for Retina display mode.
> :
> M .../gui-lib/mred/private/wx/cocoa/image.rkt | 21 +++++++++++++++++---
>
> ~~~~~~~~~~
>
> 5e90344 Matthew Flatt <mflatt at racket-lang.org> 2014-01-02 15:03
> :
> | racket/draw: add a backing-scale argument to bitmap constructors
> |
> | Generalizes backing-scale support created for `make-platform-bitmap`
> | and Mac OS X in Retina mode so that any bitmap can be created with
> | a backing scale (except monochrome bitmaps or bitmaps with masks).
> :
> M .../draw-doc/scribblings/draw/bitmap-class.scrbl | 87 ++++++---
> M .../draw-doc/scribblings/draw/draw-funcs.scrbl | 21 +-
> M .../draw-lib/racket/draw/private/bitmap.rkt | 192 ++++++++++++-------
> M .../draw-lib/racket/draw/private/contract.rkt | 7 +-
> M .../draw-lib/racket/draw/private/record-dc.rkt | 33 ++--
> M .../draw-lib/racket/draw/private/syntax.rkt | 65 +++++--
> M pkgs/gui-pkgs/gui-lib/mred/private/wx/gtk/dc.rkt | 2 +-
> M pkgs/gui-pkgs/gui-test/tests/gracket/dc.rktl | 60 ++++++
> M pkgs/gui-pkgs/gui-test/tests/gracket/draw.rkt | 12 +-
> M .../scribblings/draw/bitmap-dc-class.scrbl | 15 +-
>
> ~~~~~~~~~~
>
> 4ee266f Matthew Flatt <mflatt at racket-lang.org> 2014-01-02 18:57
> :
> | images/icons: add `backing-scale` arguments
> |
> | By default, icons render with a backing scale of 2.
> :
> M .../images-doc/images/scribblings/flomap.scrbl | 2 +-
> M .../images-doc/images/scribblings/icons.scrbl | 8 +++++
> M .../images-lib/images/compile-time.rkt | 31 ++++++++++++--------
> M .../images-lib/images/icons/control.rkt | 1 +
> M .../images-lib/images/icons/stickman.rkt | 2 ++
> M .../images-lib/images/icons/symbol.rkt | 6 ++++
> M .../images-lib/images/private/flomap-convert.rkt | 9 +++---
> M .../images-lib/images/private/flomap.rkt | 8 ++---
> M .../images-pkgs/images-lib/images/icons/arrow.rkt | 1 +
> M .../images-pkgs/images-lib/images/icons/style.rkt | 13 +++++---
> M pkgs/images-pkgs/images-lib/images/icons/file.rkt | 2 ++
> M pkgs/images-pkgs/images-lib/images/icons/misc.rkt | 8 +++++
> M pkgs/images-pkgs/images-lib/images/icons/tool.rkt | 1 +
> M pkgs/images-pkgs/images-lib/images/logos.rkt | 2 ++
>
> =====[ Overall Diff ]===================================================
>
> pkgs/draw-pkgs/draw-doc/scribblings/draw/bitmap-class.scrbl
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- OLD/pkgs/draw-pkgs/draw-doc/scribblings/draw/bitmap-class.scrbl
> +++ NEW/pkgs/draw-pkgs/draw-doc/scribblings/draw/bitmap-class.scrbl
> @@ -10,6 +10,14 @@ A @racket[bitmap%] object is a pixel-based image, either monochrome,
> @racketmodname[racket/gui/base]), @xmethod[canvas% make-bitmap] (from
> @racketmodname[racket/gui/base]), and @secref["Portability"].
>
> +A bitmap has a @deftech{backing scale}, which is the number of pixels
> + that correspond to a drawing unit for the bitmap, either when the
> + bitmap is used as a target for drawing or when the bitmap is drawn
> + into another context. For example, on Mac OS X when the main monitor
> + is in Retina mode, @racket[make-screen-bitmap] returns a bitmap whose
> + backing scale is @racket[2.0]. A monochrome bitmap always has a
> + backing scale of @racket[1.0].
> +
> A bitmap is convertible to @racket['png-bytes] through the
> @racketmodname[file/convertible] protocol.
>
> @@ -17,7 +25,8 @@ A bitmap is convertible to @racket['png-bytes] through the
> @defconstructor*/make[(([width exact-positive-integer?]
> [height exact-positive-integer?]
> [monochrome? any/c #f]
> - [alpha? any/c #f])
> + [alpha? any/c #f]
> + [backing-scale (>/c 0.0) 1.0])
> ([in (or/c path-string? input-port?)]
> [kind (or/c 'unknown 'unknown/mask 'unknown/alpha
> 'gif 'gif/mask 'gif/alpha
> @@ -27,7 +36,8 @@ A bitmap is convertible to @racket['png-bytes] through the
> 'bmp 'bmp/alpha)
> 'unknown]
> [bg-color (or/c (is-a?/c color%) #f) #f]
> - [complain-on-failure? any/c #f])
> + [complain-on-failure? any/c #f]
> + [backing-scale (>/c 0.0) 1.0])
> ([bits bytes?]
> [width exact-positive-integer?]
> [height exact-positive-integer?]))]{
> @@ -43,12 +53,20 @@ When @racket[width] and @racket[height] are provided: Creates a new
> bitmap. If @racket[monochrome?] is true, the bitmap is monochrome; if
> @racket[monochrome?] is @racket[#f] and @racket[alpha?] is true, the
> bitmap has an alpha channel; otherwise, the bitmap is color without
> - an alpha channel. The initial content of the bitmap is ``empty'': all white, and with
> + an alpha channel. The @racket[backing-scale] argument sets the
> + bitmap's @tech{backing scale}, and it must be @racket[1.0] if
> + @racket[monochrome] is true.
> + The initial content of the bitmap is ``empty'': all white, and with
> zero alpha in the case of a bitmap with an alpha channel.
>
> When @racket[in] is provided: Creates a bitmap from a file format,
> where @racket[kind] specifies the format. See @method[bitmap%
> - load-file] for details.
> + load-file] for details. The @racket[backing-scale] argument sets the
> + bitmap's @tech{backing scale}, so that the bitmap's size (as reported
> + by @method[bitmap% get-width] and @method[bitmap% get-height]) is the
> + @racket[ceiling] of the bitmap's size from @racket[in] divided by
> + @racket[backing-scale]; the backing scale must be @racket[1.0] if the
> + bitmap is monocrhome or loaded with a mask.
>
> When a @racket[bits] byte string is provided: Creates a monochrome
> bitmap from an array of bit values, where each byte in @racket[bits]
> @@ -58,7 +76,6 @@ When a @racket[bits] byte string is provided: Creates a monochrome
> @racket[height] is larger than 8 times the length of @racket[bits],
> @|MismatchExn|.
>
> -
> }
>
> @defmethod[(get-argb-pixels [x real?]
> @@ -67,25 +84,26 @@ When a @racket[bits] byte string is provided: Creates a monochrome
> [height exact-nonnegative-integer?]
> [pixels (and/c bytes? (not/c immutable?))]
> [just-alpha? any/c #f]
> - [pre-multiplied? any/c #f])
> + [pre-multiplied? any/c #f]
> + [#:unscaled? unscaled? any/c #f])
> void?]{
>
> -Produces the same result as @xmethod[bitmap-dc% get-argb-pixels], but the
> -bitmap does not have to be selected into the DC (and this method works even if
> -the bitmap is selected into another DC, attached as a button label, etc.).
> +Produces the same result as @xmethod[bitmap-dc% get-argb-pixels] when
> + at racket[unscaled?] is @racket[#f], but the bitmap does not have to be
> +selected into the DC (and this method works even if the bitmap is
> +selected into another DC, attached as a button label, etc.).
> +
> +If the bitmap has a @tech{backing scale} other than @racket[1.0] and
> + at racket[unscaled?] is true, then the result corresponds to the
> +bitmap's pixels ignoring the @tech{backing scale}. In that case,
> + at racket[x], @racket[y], @racket[width], and @racket[height] are
> +effectively in pixels instead of drawing units.}
>
> -}
>
> @defmethod[(get-backing-scale)
> (>/c 0.0)]{
>
> -Gets the number of pixels that correspond to a drawing unit for the
> -bitmap, either when the bitmap is used as a target for drawing or when
> -the bitmap is drawn into another context.
> -
> -For example, on Mac OS X when the main monitor is in Retina mode,
> - at racket[make-screen-bitmap] returns a bitmap whose backing scale is
> - at racket[2.0].}
> +Returns the bitmap's @tech{backing scale}.}
>
>
> @defmethod[(get-depth)
> @@ -109,9 +127,9 @@ image surface.}
> @defmethod[(get-height)
> exact-positive-integer?]{
>
> -Gets the height of the bitmap in pixels.
> +Gets the height of the bitmap in drawing units (which is the same as
> +pixels if the @tech{backing scale} is 1.0).}
>
> -}
>
> @defmethod[(get-loaded-mask)
> (or/c (is-a?/c bitmap%) #f)]{
> @@ -152,9 +170,9 @@ Unlike an alpha channel, the mask bitmap is @italic{not} used
> @defmethod[(get-width)
> exact-positive-integer?]{
>
> -Gets the width of the bitmap in pixels.
> +Gets the width of the bitmap in drawing units (which is the same as
> +pixels of the @tech{backing scale} is 1.0).}
>
> -}
>
> @defmethod[(has-alpha-channel?)
> boolean?]{
> @@ -251,7 +269,9 @@ For PNG loading, if @racket[bg-color] is not @racket[#f], then it is
> variable if it is defined. If the preference and environment variable
> are both undefined, a platform-specific default is used.
>
> -}
> +After a bitmap is created, @method[bitmap% load-file] can be used
> + only if the bitmap's @tech{backing scale} is @racket[1.0].}
> +
>
> @defmethod[(make-dc)
> (is-a?/c bitmap-dc%)]{
> @@ -271,7 +291,8 @@ Returns @racket[#t] if the bitmap is valid in the sense that an image
>
> @defmethod[(save-file [name (or/c path-string? output-port?)]
> [kind (or/c 'png 'jpeg 'xbm 'xpm 'bmp)]
> - [quality (integer-in 0 100) 75])
> + [quality (integer-in 0 100) 75]
> + [#:unscaled? unscaled? any/c #f])
> boolean?]{
>
> Writes a bitmap to the named file or output stream.
> @@ -307,7 +328,10 @@ A monochrome bitmap saved as @racket['png] without a mask bitmap
> @method[bitmap% load-file], creates a monochrome @racket[bitmap%]
> object.)
>
> -}
> +If the bitmap has a @tech{backing scale} other than 1.0, then it is
> + effectively converted to a single pixel per drawing unit before
> + saving unless @racket[unscaled?] is true.}
> +
>
> @defmethod[(set-argb-pixels [x real?]
> [y real?]
> @@ -315,13 +339,20 @@ A monochrome bitmap saved as @racket['png] without a mask bitmap
> [height exact-nonnegative-integer?]
> [pixels bytes?]
> [just-alpha? any/c #f]
> - [pre-multiplied? any/c #f])
> + [pre-multiplied? any/c #f]
> + [#:unscaled? unscaled? any/c #f])
> void?]{
>
> -The same as @xmethod[bitmap-dc% set-argb-pixels], but the
> -bitmap does not have to be selected into the DC.
> +The same as @xmethod[bitmap-dc% set-argb-pixels] when
> + at racket[unscaled?] is @racket[#f], but the bitmap does not have to be
> +selected into the DC.
> +
> +If the bitmap has a @tech{backing scale} other than @racket[1.0] and
> + at racket[unscaled?] is true, then pixel values are installed ignoring
> +the @tech{backing scale}. In that case, @racket[x], @racket[y],
> + at racket[width], and @racket[height] are effectively in pixels instead
> +of drawing units.}
>
> -}
>
> @defmethod[(set-loaded-mask [mask (is-a?/c bitmap%)])
> void?]{
>
> pkgs/draw-pkgs/draw-doc/scribblings/draw/bitmap-dc-class.scrbl
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- OLD/pkgs/draw-pkgs/draw-doc/scribblings/draw/bitmap-dc-class.scrbl
> +++ NEW/pkgs/draw-pkgs/draw-doc/scribblings/draw/bitmap-dc-class.scrbl
> @@ -90,11 +90,10 @@ If @racket[pre-multiplied?] is true, @racket[just-alpha?] is false,
> are scaled by the corresponding alpha value (i.e., multiplied by the
> alpha value and then divided by 255).
>
> -If the bitmap has a backing scale (see @xmethod[bitmap%
> - get-backing-scale]) other than @racket[1.0], the the result of
> - @method[bitmap-dc% get-argb-pixels] is as if the bitmap is drawn to a
> - bitmap with a backing scale of @racket[1.0] and the pixels of the
> - target bitmap are returned.}
> +If the bitmap has a @tech{backing scale} other than @racket[1.0], the
> + result of @method[bitmap-dc% get-argb-pixels] is as if the bitmap is
> + drawn to a bitmap with a backing scale of @racket[1.0] and the pixels
> + of the target bitmap are returned.}
>
>
> @defmethod[(get-bitmap)
> @@ -127,7 +126,6 @@ result is @racket[#f].
> [pre-multiplied? any/c #f])
> void?]{
>
> -
> Sets a rectangle of pixels in the bitmap, unless
> the DC's current bitmap was produced by @racket[make-screen-bitmap] or
> @xmethod[canvas% make-bitmap] (in which case @|MismatchExn|).
> @@ -158,7 +156,10 @@ If @racket[pre-multiplied?] is true, @racket[just-alpha?] is false,
> is not possible if the value is properly scaled), then it is effectively
> reduced to the alpha value.
>
> -}
> +If the bitmap has a @tech{backing scale} other than @racket[1.0], then
> + @racket[pixels] are effectively scaled by the backing scale to obtain
> + pixel values that are installed into the bitmap.}
> +
>
> @defmethod[(set-bitmap [bitmap (or/c (is-a?/c bitmap%) #f)])
> void?]{
>
> pkgs/draw-pkgs/draw-doc/scribblings/draw/draw-funcs.scrbl
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- OLD/pkgs/draw-pkgs/draw-doc/scribblings/draw/draw-funcs.scrbl
> +++ NEW/pkgs/draw-pkgs/draw-doc/scribblings/draw/draw-funcs.scrbl
> @@ -38,12 +38,13 @@ See @racket[font%] for information about @racket[family].}
>
> @defproc[(make-bitmap [width exact-positive-integer?]
> [height exact-positive-integer?]
> - [alpha? any/c #t])
> + [alpha? any/c #t]
> + [#:backing-scale backing-scale (>/c 0.0) 1.0])
> (is-a?/c bitmap%)]{
>
> -Returns @racket[(make-object bitmap% width height #f alpha?)], but
> -this procedure is preferred because it defaults @racket[alpha?] in a
> -more useful way.
> +Returns @racket[(make-object bitmap% width height #f alpha?
> +backing-scale)], but this procedure is preferred because it defaults
> + at racket[alpha?] in a more useful way.
>
> See also @racket[make-platform-bitmap] and @secref["Portability"].
> }
> @@ -159,7 +160,8 @@ When @racket[stipple] is @racket[#f], @racket[immutable?] is true, and
>
>
> @defproc[(make-platform-bitmap [width exact-positive-integer?]
> - [height exact-positive-integer?])
> + [height exact-positive-integer?]
> + [#:backing-scale backing-scale (>/c 0.0) 1.0])
> (is-a?/c bitmap%)]{
>
> Creates a bitmap that uses platform-specific drawing operations
> @@ -176,13 +178,14 @@ on Windows and Mac OS X. See @secref["Portability"] for more information.}
> 'bmp 'bmp/alpha)
> 'unknown/alpha]
> [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])
> (is-a?/c bitmap%)]{
>
> Returns @racket[(make-object bitmap% in kind bg-color
> -complain-on-failure?)], but this procedure is preferred because it
> -defaults @racket[kind] and @racket[complain-on-failure?] in a more
> -useful way.}
> +complain-on-failure? backing-scale)], but this procedure is preferred
> +because it defaults @racket[kind] and @racket[complain-on-failure?] in
> +a more useful way.}
>
>
> @defproc[(recorded-datum->procedure [datum any/c]) ((is-a?/c dc<%>) . -> . void?)]{
>
> pkgs/draw-pkgs/draw-lib/racket/draw/private/bitmap.rkt
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- OLD/pkgs/draw-pkgs/draw-lib/racket/draw/private/bitmap.rkt
> +++ NEW/pkgs/draw-pkgs/draw-lib/racket/draw/private/bitmap.rkt
> @@ -35,7 +35,7 @@
> ;; FIXME: there must be some way to abstract over all many of the
> ;; ARGB/RGBA/BGRA iterations.
>
> -(define-struct alternate-bitmap-kind (width height))
> +(define-struct alternate-bitmap-kind (width height scale))
>
> (define-local-member-name
> get-alphas-as-mask
> @@ -141,6 +141,9 @@
> (define (get-empty-surface)
> (cairo_image_surface_create CAIRO_FORMAT_ARGB32 1 1))
>
> +(define (*i x y) (inexact->exact (ceiling (* x y))))
> +(define (/i x y) (inexact->exact (ceiling (/ x y))))
> +
> (define bitmap%
> (class* object% (png-convertible<%>)
>
> @@ -162,25 +165,29 @@
> (init-rest args)
> (super-new)
>
> - (define-values (alt? width height b&w? alpha-channel? s loaded-mask)
> + (define-values (alt? width height b&w? alpha-channel? s loaded-mask backing-scale)
> (case-args
> args
> [([alternate-bitmap-kind? a])
> (values #t
> (alternate-bitmap-kind-width a)
> (alternate-bitmap-kind-height a)
> - #f #t #f #f)]
> + #f #t #f #f
> + (alternate-bitmap-kind-scale a))]
> [([exact-positive-integer? w]
> [exact-positive-integer? h]
> [any? [b&w? #f]]
> - [any? [alpha? #f]])
> + [any? [alpha? #f]]
> + [positive-real? [scale 1.0]])
> (values
> #f
> w
> h
> (and b&w? #t)
> (and alpha? (not b&w?))
> - (let ([s (cairo_image_surface_create CAIRO_FORMAT_ARGB32 (max w 1) (max h 1))])
> + (let ([s (cairo_image_surface_create CAIRO_FORMAT_ARGB32
> + (max (*i scale w) 1)
> + (max (*i scale h) 1))])
> (cairo_surface_flush s)
> (cond
> [b&w?
> @@ -194,11 +201,13 @@
> (bytes-fill! (cairo_image_surface_get_data s) 255)])
> (cairo_surface_mark_dirty s)
> s)
> - #f)]
> + #f
> + (* 1.0 scale))]
> [([(make-alts path-string? input-port?) filename]
> [bitmap-file-kind-symbol? [kind 'unknown]]
> [(make-or-false color%) [bg-color #f]]
> - [any? [complain-on-failure? #f]])
> + [any? [complain-on-failure? #f]]
> + [positive-real? [scale 1.0]])
> (let-values ([(s b&w?) (do-load-bitmap filename kind bg-color complain-on-failure?)]
> [(alpha?) (memq kind '(unknown/alpha gif/alpha jpeg/alpha
> png/alpha xbm/alpha xpm/alpha
> @@ -230,13 +239,14 @@
> (cairo_surface_mark_dirty s))))])
> (if s
> (values #f
> - (cairo_image_surface_get_width s)
> - (cairo_image_surface_get_height s)
> + (/i (cairo_image_surface_get_width s) scale)
> + (/i (cairo_image_surface_get_height s) scale)
> b&w?
> (and alpha? (not b&w?))
> s
> - mask-bm)
> - (values #f 0 0 #f #f #f #f))))]
> + mask-bm
> + (* 1.0 scale))
> + (values #f 0 0 #f #f #f #f (* 1.0 scale)))))]
> [([bytes? bstr]
> [exact-positive-integer? w]
> [exact-positive-integer? h])
> @@ -251,9 +261,20 @@
> (let ([s (* i bw)])
> (subbytes bstr s (+ s bw)))))])
> (install-bytes-rows s w h rows #t #f #f #t))
> - (values #f w h #t #f s #f)))]
> + (values #f w h #t #f s #f 1.0)))]
> (init-name 'bitmap%)))
>
> + (when (not (= backing-scale 1.0))
> + (when (or b&w? loaded-mask)
> + (error (init-name 'bitmap%)
> + (string-append
> + "~a must have a backing scale of 1.0\n"
> + " given scale: ~a")
> + (if b&w?
> + "black-and-white bitmap"
> + "bitmap with mask")
> + backing-scale)))
> +
> ;; Use for non-alpha color bitmaps when they are used as a mask:
> (define alpha-s #f)
> (define alpha-s-up-to-date? #f)
> @@ -281,7 +302,14 @@
> this)))
>
> (def/public (get-loaded-mask) loaded-mask)
> - (def/public (set-loaded-mask [(make-or-false bitmap%) m]) (set! loaded-mask m))
> + (def/public (set-loaded-mask [(make-or-false bitmap%) m])
> + (unless (= backing-scale 1)
> + (error (method-name 'bitmap% 'set-loaded-mask)
> + (string-append
> + "can only install a mask for a bitmap with backing scale of 1.0\n"
> + " backing scale: ~a")
> + backing-scale))
> + (set! loaded-mask m))
>
> (define/public (draw-bitmap-to cr sx sy dx dy w h alpha clipping)
> #f)
> @@ -304,6 +332,12 @@
> [bg #f]
> [complain-on-failure? #f])
> (check-alternate 'load-file)
> + (unless (= 1 backing-scale)
> + (error (method-name 'bitmap% 'load-file)
> + (string-append
> + "can only load a file in a bitmap with backing scale of 1.0\n"
> + " backing scale: ~a")
> + backing-scale))
> (release-bitmap-storage)
> (set!-values (s b&w?) (do-load-bitmap in kind bg complain-on-failure?))
> (set! width (if s (cairo_image_surface_get_width s) 0))
> @@ -501,19 +535,18 @@
> (unsafe-bytes-set! dest (fx+ pos B) (premult al (unsafe-bytes-ref r (fx+ spos 2))))))))))
> (cairo_surface_mark_dirty s)))
>
> - (define/private (call-with-alt-bitmap x y w h proc)
> + (define/private (call-with-alt-bitmap x y w h sc proc)
> (let* ([bm (make-object bitmap% w h #f #t)]
> [cr (cairo_create (send bm get-cairo-surface))])
> (let ([p (cairo_get_source cr)])
> (cairo_pattern_reference p)
> (cairo_set_source_surface cr (get-cairo-surface) (- x) (- y))
> - (let ([sc (get-cairo-device-scale)])
> - (unless (= sc 1)
> - (let ([m (make-cairo_matrix_t 0.0 0.0 0.0 0.0 0.0 0.0)])
> - (cairo_matrix_init_translate m 0 0)
> - (cairo_matrix_scale m sc sc)
> - (cairo_matrix_translate m x y)
> - (cairo_pattern_set_matrix (cairo_get_source cr) m))))
> + (unless (= sc 1)
> + (let ([m (make-cairo_matrix_t 0.0 0.0 0.0 0.0 0.0 0.0)])
> + (cairo_matrix_init_translate m 0 0)
> + (cairo_matrix_scale m sc sc)
> + (cairo_matrix_translate m x y)
> + (cairo_pattern_set_matrix (cairo_get_source cr) m)))
> (cairo_new_path cr)
> (cairo_rectangle cr 0 0 w h)
> (cairo_fill cr)
> @@ -523,12 +556,15 @@
> (proc bm)
> (send bm release-bitmap-storage)))
>
> - (define/public (save-file out [kind 'unknown] [quality 75])
> + (define/public (save-file out [kind 'unknown] [quality 75]
> + #:unscaled? [unscaled? #f])
> (and (ok?)
> (begin
> - (if alt?
> + (if (or alt?
> + (and (not unscaled?)
> + (not (= backing-scale 1))))
> (call-with-alt-bitmap
> - 0 0 width height
> + 0 0 width height (if unscaled? 1 backing-scale)
> (lambda (bm)
> (send bm save-file out kind quality)))
> (do-save-file out kind quality))
> @@ -570,8 +606,10 @@
> loaded-mask
> (= width (send loaded-mask get-width))
> (= height (send loaded-mask get-height)))
> - (let ([bstr (make-bytes (* width height 4))])
> - (get-argb-pixels 0 0 width height bstr)
> + (let* ([width (*i width backing-scale)]
> + [height (*i height backing-scale)]
> + [bstr (make-bytes (* width height 4))])
> + (get-argb-pixels 0 0 width height bstr #:unscaled? #t)
> (when loaded-mask
> (send loaded-mask get-argb-pixels 0 0 width height bstr #t))
> ;; PNG wants RGBA instead of ARGB...
> @@ -599,7 +637,9 @@
> proc
> (cairo_surface_write_to_png_stream s proc)))])]
> [(jpeg)
> - (let ([c (create-compress out)])
> + (let ([c (create-compress out)]
> + [width (*i width backing-scale)]
> + [height (*i height backing-scale)])
> (dynamic-wind
> void
> (lambda ()
> @@ -644,7 +684,7 @@
> alpha-s))
> (get-empty-surface)))
>
> - (define/public (get-cairo-device-scale) 1.0)
> + (define/public (get-cairo-device-scale) backing-scale)
>
> (define/public (get-backing-scale) (get-cairo-device-scale))
>
> @@ -652,19 +692,24 @@
>
> (define/public (get-argb-pixels x y w h bstr
> [get-alpha? #f]
> - [pre-mult? #f])
> + [pre-mult? #f]
> + #:unscaled? [unscaled? #f])
> (unless ((bytes-length bstr) . >= . (* w h 4))
> (raise-mismatch-error (method-name 'bitmap% 'get-argb-pixels)
> "byte string is too short: "
> bstr))
> (when (ok?)
> - (if alt?
> - (call-with-alt-bitmap
> - x y w h
> - (lambda (bm) (send bm get-argb-pixels 0 0 w h bstr get-alpha? pre-mult?)))
> - (do-get-argb-pixels x y w h bstr get-alpha? pre-mult?))))
> -
> - (define/private (do-get-argb-pixels x y w h bstr get-alpha? pre-mult?)
> + (unless (or (zero? w) (zero? h))
> + (if (or alt?
> + (and (not unscaled?)
> + (not (= backing-scale 1))))
> + (call-with-alt-bitmap
> + x y w h (if unscaled? 1 backing-scale)
> + (lambda (bm) (send bm get-argb-pixels 0 0 w h bstr get-alpha? pre-mult?)))
> + (do-get-argb-pixels x y w h bstr get-alpha? pre-mult?
> + (*i width backing-scale) (*i height backing-scale))))))
> +
> + (define/private (do-get-argb-pixels x y w h bstr get-alpha? pre-mult? width height)
> ;; Fill range that is beyond edge of picture:
> (if get-alpha?
> (for* ([i (in-range width (+ x w))]
> @@ -724,15 +769,40 @@
>
> (define/public (set-argb-pixels x y w h bstr
> [set-alpha? #f]
> - [pre-mult? #f])
> + [pre-mult? #f]
> + #:unscaled? [unscaled? #f])
> (unless ((bytes-length bstr) . >= . (* w h 4))
> (raise-mismatch-error (method-name 'bitmap% 'set-argb-pixels)
> "byte string is too short: "
> bstr))
> (check-alternate 'set-argb-pixels)
> - (when (ok?)
> + (cond
> + [(and (not unscaled?)
> + (not (= backing-scale 1)))
> + ;; scale input to match backing:
> + (define s backing-scale)
> + (define kw (max (*i 1 s) 1))
> + (define sw (+ kw (*i (sub1 w) s)))
> + (define sh (+ kw (*i (sub1 h) s)))
> + (define bstr2 (make-bytes (* sw sh 4)))
> + (for ([j (in-range h)])
> + (define sj (*i j s))
> + (for ([i (in-range w)])
> + (define si (*i i s))
> + (define p (+ (* j 4 w) (* i 4)))
> + (for* ([ik (in-range kw)]
> + [jk (in-range kw)])
> + (define p2 (+ (* (+ sj jk) 4 sw) (* (+ si ik) 4)))
> + (bytes-set! bstr2 p2 (bytes-ref bstr p))
> + (bytes-set! bstr2 (+ p2 1) (bytes-ref bstr (+ p 1)))
> + (bytes-set! bstr2 (+ p2 2) (bytes-ref bstr (+ p 2)))
> + (bytes-set! bstr2 (+ p2 3) (bytes-ref bstr (+ p 3))))))
> + (set-argb-pixels (*i x s) (*i y s) sw sh bstr2 set-alpha? pre-mult? #:unscaled? 1)]
> + [(ok?)
> ;; Set pixels:
> - (let-values ([(A R G B) (argb-indices)])
> + (let-values ([(A R G B) (argb-indices)]
> + [(width) (if unscaled? (*i width backing-scale) width)]
> + [(height) (if unscaled? (*i height backing-scale) height)])
> (when (not set-alpha?)
> (cairo_surface_flush s)
> (let ([data (cairo_image_surface_get_data s)]
> @@ -793,7 +863,7 @@
> (not alpha-channel?))
> ;; Set alphas:
> (set-alphas-as-mask x y w h bstr (* 4 w) 0)])
> - (drop-alpha-s)))
> + (drop-alpha-s)]))
>
> (define/public (get-alphas-as-mask x y w h bstr)
> (let ([data (cairo_image_surface_get_data (if (or b&w? alpha-channel?)
> @@ -869,20 +939,20 @@
> (bytes-set! data (+ q 1) vv)
> (bytes-set! data (+ q 2) vv)
> (bytes-set! data (+ q A) (if b&w? v 255)))))))
> - (cairo_surface_mark_dirty s))))
> -
> - ))
> + (cairo_surface_mark_dirty s))))))
>
> (define/top (make-bitmap [exact-positive-integer? w]
> [exact-positive-integer? h]
> - [any? [alpha? #t]])
> - (make-object bitmap% w h #f alpha?))
> + [any? [alpha? #t]]
> + #:backing-scale [nonnegative-real? [backing-scale 1.0]])
> + (make-object bitmap% w h #f alpha? backing-scale))
>
> (define/top (read-bitmap [(make-alts path-string? input-port?) filename]
> [bitmap-file-kind-symbol? [kind 'unknown/alpha]]
> [(make-or-false color%) [bg-color #f]]
> - [any? [complain-on-failure? #t]])
> - (make-object bitmap% filename kind bg-color complain-on-failure?))
> + [any? [complain-on-failure? #t]]
> + #:backing-scale [nonnegative-real? [backing-scale 1.0]])
> + (make-object bitmap% filename kind bg-color complain-on-failure? backing-scale))
>
> (define/top (make-monochrome-bitmap [exact-positive-integer? w]
> [exact-positive-integer? h]
> @@ -892,17 +962,18 @@
> (make-object bitmap% w h #t)))
>
> (define/top (make-platform-bitmap [exact-positive-integer? w]
> - [exact-positive-integer? h])
> + [exact-positive-integer? h]
> + #:backing-scale [nonnegative-real? [backing-scale 1.0]])
> (case (system-type)
> - [(macosx) (make-object quartz-bitmap% w h)]
> - [(windows) (make-object win32-no-hwnd-bitmap% w h)]
> - [(unix) (make-bitmap w h)]))
> + [(macosx) (make-object quartz-bitmap% w h #t backing-scale)]
> + [(windows) (make-object win32-no-hwnd-bitmap% w h backing-scale)]
> + [(unix) (make-bitmap w h #:backing-scale backing-scale)]))
>
> (define-local-member-name build-cairo-surface)
> (define win32-no-hwnd-bitmap%
> (class bitmap%
> - (init w h)
> - (super-make-object (make-alternate-bitmap-kind w h))
> + (init w h backing-scale)
> + (super-make-object (make-alternate-bitmap-kind w h backing-scale))
>
> (define s (build-cairo-surface w h))
> ;; erase the bitmap
> @@ -928,20 +999,11 @@
> (define quartz-bitmap%
> (class bitmap%
> (init w h [with-alpha? #t] [resolution 1.0] [dest-cg #f])
> - (super-make-object (make-alternate-bitmap-kind w h))
> -
> - (define cocoa-resolution resolution)
> -
> - (define/override (get-cairo-device-scale)
> - cocoa-resolution)
> + (super-make-object (make-alternate-bitmap-kind w h resolution))
>
> (define s
> - (let* ([sw (inexact->exact
> - (ceiling
> - (* cocoa-resolution w)))]
> - [sh (inexact->exact
> - (ceiling
> - (* cocoa-resolution h)))]
> + (let* ([sw (*i resolution w)]
> + [sh (*i resolution h)]
> [s (if dest-cg
> (cairo_quartz_surface_create_for_cg_context dest-cg sw sh)
> (cairo_quartz_surface_create (if with-alpha?
>
> pkgs/draw-pkgs/draw-lib/racket/draw/private/contract.rkt
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- OLD/pkgs/draw-pkgs/draw-lib/racket/draw/private/contract.rkt
> +++ NEW/pkgs/draw-pkgs/draw-lib/racket/draw/private/contract.rkt
> @@ -403,7 +403,7 @@
> exact-nonnegative-integer?
> exact-nonnegative-integer?
> (and/c bytes? (not/c immutable?)))
> - (any/c any/c)
> + (any/c any/c #:unscaled? any/c)
> void?))
> (get-depth (->m exact-nonnegative-integer?))
> (get-height (->m exact-nonnegative-integer?))
> @@ -424,7 +424,8 @@
> (ok? (->m boolean?))
> (save-file (->*m ((or/c path-string? output-port?)
> (or/c 'png 'jpeg 'xbm 'xpm 'bmp))
> - ((integer-in 0 100))
> + ((integer-in 0 100)
> + #:unscaled? any/c)
> boolean?))
> (set-argb-pixels (->*m
> (exact-nonnegative-integer?
> @@ -432,6 +433,6 @@
> exact-nonnegative-integer?
> exact-nonnegative-integer?
> bytes?)
> - (any/c any/c)
> + (any/c any/c #:unscaled? any/c)
> void?))
> (set-loaded-mask (->m (is-a?/c bitmap%) void?))))
>
> pkgs/draw-pkgs/draw-lib/racket/draw/private/record-dc.rkt
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- OLD/pkgs/draw-pkgs/draw-lib/racket/draw/private/record-dc.rkt
> +++ NEW/pkgs/draw-pkgs/draw-lib/racket/draw/private/record-dc.rkt
> @@ -292,7 +292,8 @@
> (send b get-width)
> (send b get-height)
> (not (send b is-color?))
> - (send b has-alpha-channel?))]
> + (send b has-alpha-channel?)
> + (send b get-backing-scale))]
> [dc (make-object bitmap-dc% new-b)])
> (send dc draw-bitmap b 0 0)
> (send dc set-bitmap #f)
> @@ -303,20 +304,30 @@
> (let ()
> (define w (send b get-width))
> (define h (send b get-height))
> - (define bstr (make-bytes (* 4 w h)))
> - (send b get-argb-pixels 0 0 w h bstr)
> - (list w h
> - (send b is-color?)
> - (send b has-alpha-channel?)
> - (bytes->immutable-bytes bstr)))))
> + (define s (send b get-backing-scale))
> + (define (scale v) (inexact->exact (ceiling (* s v))))
> + (define sw (scale w))
> + (define sh (scale h))
> + (define bstr (make-bytes (* 4 sw sh)))
> + (send b get-argb-pixels 0 0 sw sh bstr #:unscaled? #t)
> + (define l (list w h
> + (send b is-color?)
> + (send b has-alpha-channel?)
> + (bytes->immutable-bytes bstr)))
> + (if (= s 1)
> + l
> + (list* 'scale s l)))))
>
> (define (unconvert-bitmap l)
> (and l
> (let ()
> - (define-values (w h color? alpha? bstr)
> - (apply values l))
> - (define bm (make-object bitmap% w h (not color?) alpha?))
> - (send bm set-argb-pixels 0 0 w h bstr)
> + (define-values (s w h color? alpha? bstr)
> + (apply values (if (eq? (car l) 'scale)
> + (cdr l)
> + (cons 1.0 l))))
> + (define bm (make-object bitmap% w h (not color?) alpha? #:backing-scale s))
> + (define (scale v) (inexact->exact (ceiling (* s v))))
> + (send bm set-argb-pixels 0 0 (scale w) (scale h) bstr #:unscaled? #t)
> bm)))
>
> (define (convert-font f)
>
> pkgs/draw-pkgs/draw-lib/racket/draw/private/syntax.rkt
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- OLD/pkgs/draw-pkgs/draw-lib/racket/draw/private/syntax.rkt
> +++ NEW/pkgs/draw-pkgs/draw-lib/racket/draw/private/syntax.rkt
> @@ -6,7 +6,7 @@
> (provide defclass defclass*
> def/public def/pubment def/public-final def/override def/override-final define/top case-args
> def/public-unimplemented define-unimplemented
> - maybe-box? any? bool? nonnegative-real? make-or-false make-box make-list make-alts
> + maybe-box? any? bool? nonnegative-real? positive-real? make-or-false make-box make-list make-alts
> make-literal symbol-in integer-in real-in make-procedure
> method-name init-name
> let-boxes
> @@ -125,7 +125,9 @@
> (if (apply-pred pred val)
> #f
> (cons (predicate-name pred)
> - pos)))
> + (if (keyword? pos)
> + (list val)
> + pos))))
>
> (define (predicate-name pred)
> (cond
> @@ -141,6 +143,7 @@
> (define (any? v) #t)
> (define (bool? v) #t)
> (define (nonnegative-real? v) (and (real? v) (v . >= . 0)))
> +(define (positive-real? v) (and (real? v) (v . > . 0)))
>
> (define (method-of cls nam)
> (if cls
> @@ -149,21 +152,51 @@
>
> (define-syntax (def/thing stx)
> (syntax-case stx ()
> - [(_ define/orig (_ (id [arg-type arg] ...)))
> + [(_ define/orig (_ (id arg ...)))
> (raise-syntax-error #f "missing body" stx)]
> - [(_ define/orig (_ (id [arg-type arg] ...) . body))
> - (with-syntax ([(_ _ orig-stx) stx]
> - [(pos ...) (for/list ([i (in-range (length (syntax->list #'(arg ...))))])
> - i)]
> - [cname (syntax-parameter-value #'class-name)])
> - (syntax/loc #'orig-stx
> - (define/orig (id arg ...)
> - (let ([bad (or (check-arg (just-id arg) arg-type pos)
> - ...)])
> - (when bad
> - (raise-type-error (method-of 'cname 'id) (car bad) (cdr bad) (just-id arg) ...)))
> - (let ()
> - . body))))]))
> + [(_ define/orig (_ (id orig-arg ...) . body))
> + (let ([extract (lambda (keep-kw? mode)
> + (let loop ([args (syntax->list #'(orig-arg ...))]
> + [pos 0]
> + [prev-kw #f])
> + (cond
> + [(null? args) null]
> + [(keyword? (syntax-e (car args)))
> + (if keep-kw?
> + (cons (car args) (loop (cdr args) pos (car args)))
> + (loop (cdr args) pos (car args)))]
> + [else (cons (syntax-case (car args) ()
> + [[arg-type arg] (case mode
> + [(type) #'arg-type]
> + [(arg) #'arg]
> + [(id) (syntax-case #'arg ()
> + [[id val] #'id]
> + [_ #'arg])]
> + [(pos) (or prev-kw pos)])])
> + (loop (cdr args) (if prev-kw pos (add1 pos)) #f))])))])
> + (with-syntax ([(arg-id ...) (extract #f 'id)]
> + [(arg-rep ...) (extract #t 'id)]
> + [(arg ...) (extract #t 'arg)]
> + [(arg-type ...) (extract #f 'type)]
> + [(pos ...) (extract #f 'pos)])
> + (with-syntax ([(_ _ orig-stx) stx]
> + [cname (syntax-parameter-value #'class-name)])
> + (syntax/loc #'orig-stx
> + (define/orig (id arg ...)
> + (let ([bad (or (check-arg arg-id arg-type 'pos)
> + ...)])
> + (when bad
> + (type-error (method-of 'cname 'id) (car bad) (cdr bad) arg-rep ...)))
> + (let ()
> + . body))))))]))
> +
> +(define type-error
> + (make-keyword-procedure
> + (lambda (kws kw-args name expected pos . args)
> + (if (number? pos)
> + (raise-type-error name expected pos args)
> + (raise-type-error name expected (car pos))))))
> +
>
> (define-for-syntax lifted (make-hash))
> (define-syntax (lift-predicate stx)
>
> pkgs/gui-pkgs/gui-lib/mred/private/wx/cocoa/image.rkt
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- OLD/pkgs/gui-pkgs/gui-lib/mred/private/wx/cocoa/image.rkt
> +++ NEW/pkgs/gui-pkgs/gui-lib/mred/private/wx/cocoa/image.rkt
> @@ -65,9 +65,23 @@
> (free info))
>
> (define (bitmap->image bm)
> - (let* ([w (send bm get-width)]
> - [h (send bm get-height)]
> - [str (make-bytes (* w h 4) 255)])
> + (define w (send bm get-width))
> + (define h (send bm get-height))
> + (define s (send bm get-backing-scale))
> + (cond
> + [(= s 1) (bitmap->image* bm w h w h)]
> + [else
> + (define (scale v) (inexact->exact (ceiling (* s v))))
> + (define sw (scale w))
> + (define sh (scale h))
> + (define bm2 (make-bitmap sw sh))
> + (define dc (send bm2 make-dc))
> + (send dc set-scale s s)
> + (send dc draw-bitmap bm 0 0)
> + (bitmap->image* bm2 sw sh w h)]))
> +
> +(define (bitmap->image* bm w h iw ih)
> + (let ([str (make-bytes (* w h 4) 255)])
> (send bm get-argb-pixels 0 0 w h str #f)
> (let ([mask (send bm get-loaded-mask)])
> (when mask
> @@ -108,6 +122,7 @@
> (make-NSRect (make-NSPoint 0 0) size)
> image)
> (tellv i unlockFocus)
> + (tellv i setSize: #:type _NSSize (make-NSSize iw ih))
> i))))))
>
> (define (image->bitmap i)
>
> pkgs/gui-pkgs/gui-lib/mred/private/wx/gtk/dc.rkt
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- OLD/pkgs/gui-pkgs/gui-lib/mred/private/wx/gtk/dc.rkt
> +++ NEW/pkgs/gui-pkgs/gui-lib/mred/private/wx/gtk/dc.rkt
> @@ -45,7 +45,7 @@
> (define x11-bitmap%
> (class bitmap%
> (init w h gdk-win)
> - (super-make-object (make-alternate-bitmap-kind w h))
> + (super-make-object (make-alternate-bitmap-kind w h 1.0))
>
> (define pixmap (gdk_pixmap_new gdk-win
> (min (max 1 w) 32000)
>
> pkgs/gui-pkgs/gui-test/tests/gracket/dc.rktl
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- OLD/pkgs/gui-pkgs/gui-test/tests/gracket/dc.rktl
> +++ NEW/pkgs/gui-pkgs/gui-test/tests/gracket/dc.rktl
> @@ -751,6 +751,66 @@
>
> (test #t 'get-path-bounding-box (test-square-bounding-boxes))
>
> +;; -----------------------------------------------------------
> +;; Check pixel operations on a bitmap with a x2 backing scale
> +
> +(let ([bm (make-bitmap 10 11 #:backing-scale 2)])
> + (test 2.0 'scale (send bm get-backing-scale))
> + (test 10 'width (send bm get-width))
> + (test 11 'height (send bm get-height))
> +
> + (define dc (send bm make-dc))
> + (send dc set-pen "black" 0 'transparent)
> + (send dc set-brush (make-color 100 100 200) 'solid)
> + (send dc draw-rectangle 0 0 3 3)
> +
> + (let ([s (make-bytes 4)])
> + (send bm get-argb-pixels 2 2 1 1 s)
> + (test (list 255 100 100 200) 'scaled (bytes->list s))
> + (send bm get-argb-pixels 4 4 1 1 s)
> + (test 0 'scaled (bytes-ref s 0))
> + (send bm get-argb-pixels 2 2 1 1 s #:unscaled? #t)
> + (test (list 255 100 100 200) 'unscaled (bytes->list s))
> +
> + (send bm set-argb-pixels 0 0 2 1 #"\xff\x0\x0\x0\xff\x0\x0\x0"
> + #:unscaled? #t)
> + (send bm get-argb-pixels 0 0 1 1 s #:unscaled? #t)
> + (test (list 255 0 0 0) 'unscaled (bytes->list s))
> + ;; scaled is average of black and blue:
> + (send bm get-argb-pixels 0 0 1 1 s)
> + (test (list 255 50 50 100) 'scaled (bytes->list s))
> +
> + (send bm set-argb-pixels 0 0 2 1 #"\xff\x0\x0\x0\xff\x0\x0\x0")
> + (send bm get-argb-pixels 0 0 1 1 s)
> + (test (list 255 0 0 0) 'scaled (bytes->list s))))
> +
> +(let ([p (collection-file-path "sk.jpg" "icons")])
> + (let ([bm1 (read-bitmap p)]
> + [bm2 (read-bitmap p #:backing-scale 2)])
> + (test 2.0 'scale (send bm2 get-backing-scale))
> + (test (ceiling (* 1/2 (send bm1 get-width))) 'read-width (send bm2 get-width))
> + (test (ceiling (* 1/2 (send bm1 get-height))) 'read-height (send bm2 get-height))))
> +
> +(let ([p (collection-file-path "very-small-planet.png" "icons")])
> + (define-syntax-rule (test-fail rx body)
> + (test #t
> + 'error
> + (with-handlers ([exn? (lambda (e)
> + (regexp-match? rx (exn-message e)))])
> + body
> + #f)))
> + (test-fail "mask.*backing scale" (read-bitmap p
> + 'png/mask
> + #:backing-scale 2))
> + (test-fail "can only install a mask.*backing scale"
> + (send (read-bitmap p #:backing-scale 2)
> + set-loaded-mask
> + (read-bitmap p)))
> + (test-fail "can only load a file.*backing scale"
> + (send (read-bitmap p #:backing-scale 2)
> + load-file
> + p)))
> +
> ;; ----------------------------------------
>
> (report-errs)
>
> pkgs/gui-pkgs/gui-test/tests/gracket/draw.rkt
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- OLD/pkgs/gui-pkgs/gui-test/tests/gracket/draw.rkt
> +++ NEW/pkgs/gui-pkgs/gui-test/tests/gracket/draw.rkt
> @@ -225,6 +225,7 @@
> [use-bitmap? #f]
> [platform-bitmap? #f]
> [compat-bitmap? #f]
> + [scaled-bitmap? #f]
> [use-record? #f]
> [serialize-record? #f]
> [use-bad? #f]
> @@ -309,6 +310,8 @@
> (make-platform-bitmap w h)]
> [compat-bitmap?
> (send this make-bitmap w h)]
> + [scaled-bitmap?
> + (make-bitmap w h #:backing-scale 3.0)]
> [else
> (make-object bitmap% w h depth-one? c-gray?)])))
> #f)]
> @@ -1310,15 +1313,16 @@
> (super-new [parent parent][style '(hscroll vscroll)])
> (init-auto-scrollbars (* 2 DRAW-WIDTH) (* 2 DRAW-HEIGHT) 0 0))
> vp)])
> - (make-object choice% #f '("Canvas" "Pixmap" "Bitmap" "Platform" "Compatible" "Record" "Serialize" "Bad") hp0
> + (make-object choice% #f '("Canvas" "Pixmap" "Bitmap" "Platform" "Compatible" "Backing x3" "Record" "Serialize" "Bad") hp0
> (lambda (self event)
> (set! use-bitmap? (< 0 (send self get-selection)))
> (set! depth-one? (= 2 (send self get-selection)))
> (set! platform-bitmap? (= 3 (send self get-selection)))
> (set! compat-bitmap? (= 4 (send self get-selection)))
> - (set! use-record? (<= 5 (send self get-selection) 6))
> - (set! serialize-record? (= 6 (send self get-selection)))
> - (set! use-bad? (< 7 (send self get-selection)))
> + (set! scaled-bitmap? (= 5 (send self get-selection)))
> + (set! use-record? (<= 6 (send self get-selection) 6))
> + (set! serialize-record? (= 7 (send self get-selection)))
> + (set! use-bad? (< 8 (send self get-selection)))
> (send canvas refresh)))
> (make-object button% "PS" hp
> (lambda (self event)
>
> pkgs/images-pkgs/images-doc/images/scribblings/flomap.scrbl
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- OLD/pkgs/images-pkgs/images-doc/images/scribblings/flomap.scrbl
> +++ NEW/pkgs/images-pkgs/images-doc/images/scribblings/flomap.scrbl
> @@ -327,7 +327,7 @@ Like @racket[unsafe-flomap-ref], but returns an flvector containing all the comp
>
> @section{Conversion and Construction}
>
> - at defproc[(flomap->bitmap [fm flomap]) Any]{
> + at defproc[(flomap->bitmap [fm flomap] [#:backing-scale backing-scale (>/c 0.0)]) Any]{
> Converts a flomap to a @racket[bitmap%].
>
> The return type is imprecise because Typed Racket does not support the object system well yet.
>
> pkgs/images-pkgs/images-doc/images/scribblings/icons.scrbl
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- OLD/pkgs/images-pkgs/images-doc/images/scribblings/icons.scrbl
> +++ NEW/pkgs/images-pkgs/images-doc/images/scribblings/icons.scrbl
> @@ -143,6 +143,14 @@ Use @racket[(toolbar-icon-height)] as the @racket[height] argument for common ic
> If you cannot, as with the Macro Stepper, send a thinner icon as the @racket[alternate-bitmap] argument to a @racket[switchable-button%].)
> }
>
> + at doc-apply[default-icon-backing-scale]{
> +The backing scale of DrRacket icons.
> +
> +A backing scale of 2 means that the icon bitmap internally has two
> +pixels per drawing unit, so it it renders well a double resolution,
> +such as Retina display mode for Mac OS X.
> +}
> +
> @doc-apply[plastic-icon-material]
> @doc-apply[rubber-icon-material]
> @doc-apply[glass-icon-material]
>
> pkgs/images-pkgs/images-lib/images/compile-time.rkt
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- OLD/pkgs/images-pkgs/images-lib/images/compile-time.rkt
> +++ NEW/pkgs/images-pkgs/images-lib/images/compile-time.rkt
> @@ -9,17 +9,19 @@
> (begin-for-syntax
> (define (save-png bm)
> (define p (open-output-bytes))
> - (send bm save-file p 'png)
> + (send bm save-file p 'png #:unscaled? #t)
> (define bs (get-output-bytes p))
> ;(printf "Wrote PNG: ~v bytes~n" (bytes-length bs))
> bs)
>
> (define (save-jpeg bm quality)
> - (define w (send bm get-width))
> - (define h (send bm get-height))
> + (define s (send bm get-backing-scale))
> + (define (scale v) (inexact->exact (ceiling (* s v))))
> + (define w (scale (send bm get-width)))
> + (define h (scale (send bm get-height)))
> (define bs (make-bytes (* 4 w h)))
>
> - (send bm get-argb-pixels 0 0 w h bs #t)
> + (send bm get-argb-pixels 0 0 w h bs #t #:unscaled? #t)
> (for ([i (in-range 0 (* 4 w h) 4)])
> (define a (bytes-ref bs i))
> (bytes-set! bs i 255)
> @@ -50,19 +52,21 @@
> (unless (and (exact-integer? quality) (<= 0 quality 100))
> (raise-type-error 'make-3d-bitmap "(integer-in 0 100)" 1 bm quality))
> (cond [(= quality 100)
> - (with-syntax ([bs (datum->syntax ctxt (save-png bm))])
> - (syntax/loc ctxt (load-png bs)))]
> + (with-syntax ([bs (datum->syntax ctxt (save-png bm))]
> + [scale (send bm get-backing-scale)])
> + (syntax/loc ctxt (load-png bs scale)))]
> [else
> (define-values (alpha-bs rgb-bs) (save-jpeg bm quality))
> (with-syntax ([alpha-bs (datum->syntax ctxt alpha-bs)]
> - [rgb-bs (datum->syntax ctxt rgb-bs)])
> - (syntax/loc ctxt (load-jpeg alpha-bs rgb-bs)))]))
> + [rgb-bs (datum->syntax ctxt rgb-bs)]
> + [scale (send bm get-backing-scale)])
> + (syntax/loc ctxt (load-jpeg alpha-bs rgb-bs scale)))]))
> )
>
> -(define (load-png bs)
> - (read-bitmap (open-input-bytes bs) 'png/alpha))
> +(define (load-png bs scale)
> + (read-bitmap (open-input-bytes bs) 'png/alpha #:backing-scale scale))
>
> -(define (load-jpeg alpha-bs rgb-bs)
> +(define (load-jpeg alpha-bs rgb-bs scale)
> (define alpha-bm (read-bitmap (open-input-bytes alpha-bs) 'jpeg))
> (define rgb-bm (read-bitmap (open-input-bytes rgb-bs) 'jpeg))
> (define w (send rgb-bm get-width))
> @@ -77,8 +81,9 @@
> (define a (bytes-ref bs (+ i 2)))
> (bytes-set! new-bs i a))
>
> - (define new-bm (make-bitmap w h))
> - (send new-bm set-argb-pixels 0 0 w h new-bs #f)
> + (define (/* n d) (inexact->exact (ceiling (/ n d))))
> + (define new-bm (make-bitmap (/* w scale) (/* h scale) #:backing-scale scale))
> + (send new-bm set-argb-pixels 0 0 w h new-bs #f #:unscaled? #t)
> new-bm)
>
> (define-syntax (compiled-bitmap stx)
>
> pkgs/images-pkgs/images-lib/images/icons/arrow.rkt
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- OLD/pkgs/images-pkgs/images-lib/images/icons/arrow.rkt
> +++ NEW/pkgs/images-pkgs/images-lib/images/icons/arrow.rkt
> @@ -119,6 +119,7 @@
> ([#:color color (or/c string? (is-a?/c color%))]
> [#:height height (and/c rational? (>=/c 0)) (default-icon-height)]
> [#:material material deep-flomap-material-value? (default-icon-material)])
> + (height)
> [left-arrow-icon left-arrow-flomap]
> [right-arrow-icon right-arrow-flomap]
> [up-arrow-icon up-arrow-flomap]
>
> pkgs/images-pkgs/images-lib/images/icons/control.rkt
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- OLD/pkgs/images-pkgs/images-lib/images/icons/control.rkt
> +++ NEW/pkgs/images-pkgs/images-lib/images/icons/control.rkt
> @@ -181,6 +181,7 @@
> ([#:color color (or/c string? (is-a?/c color%))]
> [#:height height (and/c rational? (>=/c 0)) (default-icon-height)]
> [#:material material deep-flomap-material-value? (default-icon-material)])
> + (height)
> [play-icon play-flomap]
> [back-icon back-flomap]
> [fast-forward-icon fast-forward-flomap]
>
> pkgs/images-pkgs/images-lib/images/icons/file.rkt
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- OLD/pkgs/images-pkgs/images-lib/images/icons/file.rkt
> +++ NEW/pkgs/images-pkgs/images-lib/images/icons/file.rkt
> @@ -152,6 +152,7 @@
> ([#:color color (or/c string? (is-a?/c color%)) "slategray"]
> [#:height height (and/c rational? (>=/c 0)) (default-icon-height)]
> [#:material material deep-flomap-material-value? (default-icon-material)])
> + (height)
> [floppy-disk-icon floppy-disk-flomap])
>
> (define-icon-wrappers
> @@ -159,6 +160,7 @@
> [#:arrow-color arrow-color (or/c string? (is-a?/c color%)) syntax-icon-color]
> [#:height height (and/c rational? (>=/c 0)) (default-icon-height)]
> [#:material material deep-flomap-material-value? (default-icon-material)])
> + (height)
> [save-icon save-flomap]
> [load-icon load-flomap]
> [small-save-icon small-save-flomap]
>
> pkgs/images-pkgs/images-lib/images/icons/misc.rkt
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- OLD/pkgs/images-pkgs/images-lib/images/icons/misc.rkt
> +++ NEW/pkgs/images-pkgs/images-lib/images/icons/misc.rkt
> @@ -576,6 +576,7 @@
> [#:color color (or/c string? (is-a?/c color%))]
> [#:height height (and/c rational? (>=/c 0)) (default-icon-height)]
> [#:material material deep-flomap-material-value? (default-icon-material)])
> + (height)
> [regular-polygon-icon regular-polygon-flomap])
>
> (define-icon-wrappers
> @@ -584,6 +585,7 @@
> [#:face-color face-color (or/c string? (is-a?/c color%)) light-metal-icon-color]
> [#:hand-color hand-color (or/c string? (is-a?/c color%)) "firebrick"]
> [#:height height (and/c rational? (>=/c 0)) (default-icon-height)])
> + (height)
> [clock-icon clock-flomap]
> [stopwatch-icon stopwatch-flomap])
>
> @@ -591,6 +593,7 @@
> ([#:color color (or/c string? (is-a?/c color%)) halt-icon-color]
> [#:height height (and/c rational? (>=/c 0)) (default-icon-height)]
> [#:material material deep-flomap-material-value? (default-icon-material)])
> + (height)
> [stop-sign-icon stop-sign-flomap]
> [stop-signs-icon stop-signs-flomap])
>
> @@ -598,6 +601,7 @@
> ([#:color color (or/c string? (is-a?/c color%))]
> [#:height height (and/c rational? (>=/c 0)) (default-icon-height)]
> [#:material material deep-flomap-material-value? (default-icon-material)])
> + (height)
> [foot-icon foot-flomap])
>
> (define-icon-wrappers
> @@ -605,6 +609,7 @@
> [#:handle-color handle-color (or/c string? (is-a?/c color%)) "brown"]
> [#:height height (and/c rational? (>=/c 0)) (default-icon-height)]
> [#:material material deep-flomap-material-value? (default-icon-material)])
> + (height)
> [magnifying-glass-icon magnifying-glass-flomap]
> [left-magnifying-glass-icon left-magnifying-glass-flomap])
>
> @@ -613,6 +618,7 @@
> [#:bomb-color bomb-color (or/c string? (is-a?/c color%)) dark-metal-icon-color]
> [#:height height (and/c rational? (>=/c 0)) (default-icon-height)]
> [#:material material deep-flomap-material-value? (default-icon-material)])
> + (height)
> [bomb-icon bomb-flomap]
> [left-bomb-icon left-bomb-flomap])
>
> @@ -622,10 +628,12 @@
> [#:shackle-color shackle-color (or/c string? (is-a?/c color%)) light-metal-icon-color]
> [#:height height (and/c rational? (>=/c 0)) (default-icon-height)]
> [#:material material deep-flomap-material-value? (default-icon-material)])
> + (height)
> [lock-icon lock-flomap])
>
> (define-icon-wrappers
> ([#:color color (or/c string? (is-a?/c color%)) "black"]
> [#:height height (and/c rational? (>=/c 0)) (default-icon-height)])
> + (height)
> [stethoscope-icon stethoscope-flomap]
> [short-stethoscope-icon short-stethoscope-flomap])
>
> pkgs/images-pkgs/images-lib/images/icons/stickman.rkt
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- OLD/pkgs/images-pkgs/images-lib/images/icons/stickman.rkt
> +++ NEW/pkgs/images-pkgs/images-lib/images/icons/stickman.rkt
> @@ -319,6 +319,7 @@
> [#:head-color head-color (or/c string? (is-a?/c color%)) run-icon-color]
> [#:height height (and/c rational? (>=/c 0)) (default-icon-height)]
> [#:material material deep-flomap-material-value? (default-icon-material)])
> + (height)
> [standing-stickman-icon standing-stickman-flomap])
>
> (define-icon-wrappers
> @@ -328,6 +329,7 @@
> [#:head-color head-color (or/c string? (is-a?/c color%)) run-icon-color]
> [#:height height (and/c rational? (>=/c 0)) (default-icon-height)]
> [#:material material deep-flomap-material-value? (default-icon-material)])
> + (height)
> [running-stickman-icon running-stickman-flomap])
>
> #;; FOR TESTING ONLY: Do not let this find its way into the repo uncommented!
>
> pkgs/images-pkgs/images-lib/images/icons/style.rkt
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- OLD/pkgs/images-pkgs/images-lib/images/icons/style.rkt
> +++ NEW/pkgs/images-pkgs/images-lib/images/icons/style.rkt
> @@ -18,6 +18,7 @@
> metal-icon-material
> bitmap-render-icon
> (activate-contract-out
> + default-icon-backing-scale
> default-icon-height
> toolbar-icon-height
> default-icon-material
> @@ -42,6 +43,7 @@
> (defthing run-icon-color (or/c string? (is-a?/c color%)) #:document-value
> "lawngreen")
>
> +(defparam default-icon-backing-scale (and/c rational? (>/c 0)) 2)
> (defparam default-icon-height (and/c rational? (>=/c 0)) 24)
> (defparam toolbar-icon-height (and/c rational? (>=/c 0)) 16)
>
> @@ -175,10 +177,13 @@
>
> (define-syntax (define-icon-wrappers stx)
> (syntax-case stx ()
> - [(_ (arg ...) [icon-fun flomap-fun] ...)
> - (with-syntax ([(actual-args ...) (apply append (map arg-actual (syntax->list #'(arg ...))))])
> + [(_ (arg ...) (scale-arg ...) [icon-fun flomap-fun] ...)
> + (with-syntax ([(actual-args ...) (apply append (map arg-actual (syntax->list #'(arg ...))))]
> + [backing-arg #'[#:backing-scale backing-scale (and/c rational? (>/c 0.0))
> + (default-icon-backing-scale)]])
> (syntax/loc stx
> (begin
> - (defproc (icon-fun arg ...) (is-a?/c bitmap%)
> - (flomap->bitmap (flomap-fun actual-args ...)))
> + (defproc (icon-fun arg ... backing-arg) (is-a?/c bitmap%)
> + (let ([scale-arg (* scale-arg backing-scale)] ...)
> + (flomap->bitmap (flomap-fun actual-args ...) #:backing-scale backing-scale)))
> ...)))]))
>
> pkgs/images-pkgs/images-lib/images/icons/symbol.rkt
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- OLD/pkgs/images-pkgs/images-lib/images/icons/symbol.rkt
> +++ NEW/pkgs/images-pkgs/images-lib/images/icons/symbol.rkt
> @@ -285,34 +285,40 @@
> [#:height height (and/c rational? (>=/c 0)) (default-icon-height)]
> [#:material material deep-flomap-material-value? (default-icon-material)]
> [#:outline outline (and/c rational? (>=/c 0)) (/ height 32)])
> + (height outline)
> [text-icon text-flomap])
>
> (define-icon-wrappers
> ([#:color color (or/c string? (is-a?/c color%)) "forestgreen"]
> [#:height height (and/c rational? (>=/c 0)) (default-icon-height)]
> [#:material material deep-flomap-material-value? (default-icon-material)])
> + (height)
> [recycle-icon recycle-flomap])
>
> (define-icon-wrappers
> ([#:color color (or/c string? (is-a?/c color%)) halt-icon-color]
> [#:height height (and/c rational? (>=/c 0)) (default-icon-height)]
> [#:material material deep-flomap-material-value? (default-icon-material)])
> + (height)
> [x-icon x-flomap])
>
> (define-icon-wrappers
> ([#:color color (or/c string? (is-a?/c color%)) run-icon-color]
> [#:height height (and/c rational? (>=/c 0)) (default-icon-height)]
> [#:material material deep-flomap-material-value? (default-icon-material)])
> + (height)
> [check-icon check-flomap])
>
> (define-icon-wrappers
> ([#:color color (or/c string? (is-a?/c color%)) light-metal-icon-color]
> [#:height height (and/c rational? (>=/c 0)) (default-icon-height)]
> [#:material material deep-flomap-material-value? (default-icon-material)])
> + (height)
> [lambda-icon lambda-flomap])
>
> (define-icon-wrappers
> ([#:color color (or/c string? (is-a?/c color%)) "mediumseagreen"]
> [#:height height (and/c rational? (>=/c 0)) (default-icon-height)]
> [#:material material deep-flomap-material-value? (default-icon-material)])
> + (height)
> [hash-quote-icon hash-quote-flomap])
>
> pkgs/images-pkgs/images-lib/images/icons/tool.rkt
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- OLD/pkgs/images-pkgs/images-lib/images/icons/tool.rkt
> +++ NEW/pkgs/images-pkgs/images-lib/images/icons/tool.rkt
> @@ -93,6 +93,7 @@
> (define-icon-wrappers
> ([#:height height (and/c rational? (>=/c 0)) (toolbar-icon-height)]
> [#:material material deep-flomap-material-value? (default-icon-material)])
> + (height)
> [check-syntax-icon check-syntax-flomap]
> [small-check-syntax-icon small-check-syntax-flomap]
> [macro-stepper-icon macro-stepper-flomap]
>
> pkgs/images-pkgs/images-lib/images/logos.rkt
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- OLD/pkgs/images-pkgs/images-lib/images/logos.rkt
> +++ NEW/pkgs/images-pkgs/images-lib/images/logos.rkt
> @@ -408,11 +408,13 @@
>
> (define-icon-wrappers
> ([#:height height (and/c rational? (>=/c 0)) 256])
> + (height)
> [plt-logo plt-flomap]
> [racket-logo racket-flomap])
>
> (define-icon-wrappers
> ([#:height height (and/c rational? (>=/c 0)) 96])
> + (height)
> [planet-logo planet-flomap]
> [stepper-logo stepper-flomap]
> [macro-stepper-logo macro-stepper-logo-flomap])
>
> pkgs/images-pkgs/images-lib/images/private/flomap-convert.rkt
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- OLD/pkgs/images-pkgs/images-lib/images/private/flomap-convert.rkt
> +++ NEW/pkgs/images-pkgs/images-lib/images/private/flomap-convert.rkt
> @@ -39,7 +39,7 @@
> (unsafe-flround
> (unsafe-flmax 0.0 (unsafe-flmin 255.0 (unsafe-fl* x 255.0))))))
>
> -(define (flomap->bitmap fm)
> +(define (flomap->bitmap fm #:backing-scale [backing-scale 1.0])
> (match-define (flomap vs c w h) fm)
> (let* ([fm (case c
> [(0) (make-flomap 4 w h)]
> @@ -68,9 +68,10 @@
> (unsafe-bytes-set! bs i2 (unsafe-fl->byte g))
> (unsafe-bytes-set! bs i3 (unsafe-fl->byte b)))
>
> - (define bm (make-bitmap w h))
> - (send bm set-argb-pixels 0 0 w h bs #t #t)
> - (send bm set-argb-pixels 0 0 w h bs #f #t)
> + (define (scale d) (inexact->exact (ceiling (/ d backing-scale))))
> + (define bm (make-bitmap (scale w) (scale h) #:backing-scale backing-scale))
> + (send bm set-argb-pixels 0 0 w h bs #t #t #:unscaled? #t)
> + (send bm set-argb-pixels 0 0 w h bs #f #t #:unscaled? #t)
> bm))
>
> (define (draw-flomap draw-proc w h)
>
> pkgs/images-pkgs/images-lib/images/private/flomap.rkt
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- OLD/pkgs/images-pkgs/images-lib/images/private/flomap.rkt
> +++ NEW/pkgs/images-pkgs/images-lib/images/private/flomap.rkt
> @@ -20,17 +20,17 @@
> [get-height (-> Integer)]
> [get-argb-pixels
> (case->
> - (Integer Integer Integer Integer Bytes
> + (Integer Integer Integer Integer Bytes [#:unscaled? Boolean]
> -> Void)
> - (Integer Integer Integer Integer Bytes Boolean
> + (Integer Integer Integer Integer Bytes Boolean [#:unscaled? Boolean]
> -> Void)
> - (Integer Integer Integer Integer Bytes Boolean Boolean
> + (Integer Integer Integer Integer Bytes Boolean Boolean [#:unscaled? Boolean]
> -> Void))])))
>
> (require/typed
> "flomap-convert.rkt"
> [bitmap->flomap ((Instance Bitmap%) -> flomap)]
> - [flomap->bitmap (flomap -> (Instance Bitmap%))]
> + [flomap->bitmap (flomap [#:backing-scale Positive-Real] -> (Instance Bitmap%))]
> [draw-flomap ((Any -> Any) Integer Integer -> flomap)])
>
> (provide (all-from-out "flomap-struct.rkt"
>
![[logo]](/logo.png){kind=logo}