[racket-dev] [plt] Push #28005: master branch updated
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"
> >
![[logo]](/logo.png){kind=logo}