[racket-dev] [plt] Push #28005: master branch updated

From: Matthew Flatt (mflatt at cs.utah.edu)
Date: Fri Jan 3 19:42:59 EST 2014

I think `draw-bitmap` should effectively turn on smoothing when drawing
a bitmap with a backing scale other than 1.0. I'll make that change.

Thanks!

At Fri, 03 Jan 2014 17:35:59 -0700, Neil Toronto wrote:
> 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"
> >


Posted on the dev mailing list.