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

racket/draw: add a backing-scale argument to bitmap constructors

Browse Source 
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).
This commit is contained in:
Matthew Flatt 2014-01-02 15:03:11 -07:00
parent 4f86f1de62
commit 5e903441a4
10 changed files with 349 additions and 143 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

87
pkgs/draw-pkgs/draw-doc/scribblings/draw/bitmap-class.scrbl
View File

@ -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]), @xmethod[canvas% make-bitmap] (from
@racketmodname[racket/gui/base]), and @secref["Portability"]. @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 A bitmap is convertible to @racket['png-bytes] through the
@racketmodname[file/convertible] protocol. @racketmodname[file/convertible] protocol.
@ -17,7 +25,8 @@ A bitmap is convertible to @racket['png-bytes] through the
@defconstructor*/make[(([width exact-positive-integer?] @defconstructor*/make[(([width exact-positive-integer?]
[height exact-positive-integer?] [height exact-positive-integer?]
[monochrome? any/c #f] [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?)] ([in (or/c path-string? input-port?)]
[kind (or/c 'unknown 'unknown/mask 'unknown/alpha [kind (or/c 'unknown 'unknown/mask 'unknown/alpha
'gif 'gif/mask 'gif/alpha 'gif 'gif/mask 'gif/alpha
@ -27,7 +36,8 @@ A bitmap is convertible to @racket['png-bytes] through the
'bmp 'bmp/alpha) 'bmp 'bmp/alpha)
'unknown] 'unknown]
[bg-color (or/c (is-a?/c color%) #f) #f] [bg-color (or/c (is-a?/c color%) #f) #f]
[complain-on-failure? any/c #f]) [complain-on-failure? any/c #f]
[backing-scale (>/c 0.0) 1.0])
([bits bytes?] ([bits bytes?]
[width exact-positive-integer?] [width exact-positive-integer?]
[height 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 bitmap. If @racket[monochrome?] is true, the bitmap is monochrome; if
@racket[monochrome?] is @racket[#f] and @racket[alpha?] is true, the @racket[monochrome?] is @racket[#f] and @racket[alpha?] is true, the
bitmap has an alpha channel; otherwise, the bitmap is color without 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. zero alpha in the case of a bitmap with an alpha channel.
When @racket[in] is provided: Creates a bitmap from a file format, When @racket[in] is provided: Creates a bitmap from a file format,
where @racket[kind] specifies the format. See @method[bitmap% 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 When a @racket[bits] byte string is provided: Creates a monochrome
bitmap from an array of bit values, where each byte in @racket[bits] 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], @racket[height] is larger than 8 times the length of @racket[bits],
@|MismatchExn|. @|MismatchExn|.
} }
@defmethod[(get-argb-pixels [x real?] @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?] [height exact-nonnegative-integer?]
[pixels (and/c bytes? (not/c immutable?))] [pixels (and/c bytes? (not/c immutable?))]
[just-alpha? any/c #f] [just-alpha? any/c #f]
[pre-multiplied? any/c #f]) [pre-multiplied? any/c #f]
[#:unscaled? unscaled? any/c #f])
void?]{ void?]{
Produces the same result as @xmethod[bitmap-dc% get-argb-pixels], but the Produces the same result as @xmethod[bitmap-dc% get-argb-pixels] when
bitmap does not have to be selected into the DC (and this method works even if @racket[unscaled?] is @racket[#f], but the bitmap does not have to be
the bitmap is selected into another DC, attached as a button label, etc.). 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
@racket[unscaled?] is true, then the result corresponds to the
bitmap's pixels ignoring the @tech{backing scale}. In that case,
@racket[x], @racket[y], @racket[width], and @racket[height] are
effectively in pixels instead of drawing units.}
}
@defmethod[(get-backing-scale) @defmethod[(get-backing-scale)
(>/c 0.0)]{ (>/c 0.0)]{
Gets the number of pixels that correspond to a drawing unit for the Returns the bitmap's @tech{backing scale}.}
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].}
@defmethod[(get-depth) @defmethod[(get-depth)
@ -109,9 +127,9 @@ image surface.}
@defmethod[(get-height) @defmethod[(get-height)
exact-positive-integer?]{ 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) @defmethod[(get-loaded-mask)
(or/c (is-a?/c bitmap%) #f)]{ (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) @defmethod[(get-width)
exact-positive-integer?]{ 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?) @defmethod[(has-alpha-channel?)
boolean?]{ 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 variable if it is defined. If the preference and environment variable
are both undefined, a platform-specific default is used. 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) @defmethod[(make-dc)
(is-a?/c bitmap-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?)] @defmethod[(save-file [name (or/c path-string? output-port?)]
[kind (or/c 'png 'jpeg 'xbm 'xpm 'bmp)] [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?]{ boolean?]{
Writes a bitmap to the named file or output stream. 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%] @method[bitmap% load-file], creates a monochrome @racket[bitmap%]
object.) 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?] @defmethod[(set-argb-pixels [x real?]
[y real?] [y real?]
@ -315,13 +339,20 @@ A monochrome bitmap saved as @racket['png] without a mask bitmap
[height exact-nonnegative-integer?] [height exact-nonnegative-integer?]
[pixels bytes?] [pixels bytes?]
[just-alpha? any/c #f] [just-alpha? any/c #f]
[pre-multiplied? any/c #f]) [pre-multiplied? any/c #f]
[#:unscaled? unscaled? any/c #f])
void?]{ void?]{
The same as @xmethod[bitmap-dc% set-argb-pixels], but the The same as @xmethod[bitmap-dc% set-argb-pixels] when
bitmap does not have to be selected into the DC. @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
@racket[unscaled?] is true, then pixel values are installed ignoring
the @tech{backing scale}. In that case, @racket[x], @racket[y],
@racket[width], and @racket[height] are effectively in pixels instead
of drawing units.}
}
@defmethod[(set-loaded-mask [mask (is-a?/c bitmap%)]) @defmethod[(set-loaded-mask [mask (is-a?/c bitmap%)])
void?]{ void?]{

15
pkgs/draw-pkgs/draw-doc/scribblings/draw/bitmap-dc-class.scrbl
View File

@ -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 are scaled by the corresponding alpha value (i.e., multiplied by the
alpha value and then divided by 255). alpha value and then divided by 255).
If the bitmap has a backing scale (see @xmethod[bitmap% If the bitmap has a @tech{backing scale} other than @racket[1.0], the
get-backing-scale]) other than @racket[1.0], the the result of result of @method[bitmap-dc% get-argb-pixels] is as if the bitmap is
@method[bitmap-dc% get-argb-pixels] is as if the bitmap is drawn to a drawn to a bitmap with a backing scale of @racket[1.0] and the pixels
bitmap with a backing scale of @racket[1.0] and the pixels of the of the target bitmap are returned.}
target bitmap are returned.}
@defmethod[(get-bitmap) @defmethod[(get-bitmap)
@ -127,7 +126,6 @@ result is @racket[#f].
[pre-multiplied? any/c #f]) [pre-multiplied? any/c #f])
void?]{ void?]{
Sets a rectangle of pixels in the bitmap, unless Sets a rectangle of pixels in the bitmap, unless
the DC's current bitmap was produced by @racket[make-screen-bitmap] or the DC's current bitmap was produced by @racket[make-screen-bitmap] or
@xmethod[canvas% make-bitmap] (in which case @|MismatchExn|). @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 is not possible if the value is properly scaled), then it is effectively
reduced to the alpha value. 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)]) @defmethod[(set-bitmap [bitmap (or/c (is-a?/c bitmap%) #f)])
void?]{ void?]{

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

@ -38,12 +38,13 @@ See @racket[font%] for information about @racket[family].}
@defproc[(make-bitmap [width exact-positive-integer?] @defproc[(make-bitmap [width exact-positive-integer?]
[height 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%)]{ (is-a?/c bitmap%)]{
Returns @racket[(make-object bitmap% width height #f alpha?)], but Returns @racket[(make-object bitmap% width height #f alpha?
this procedure is preferred because it defaults @racket[alpha?] in a backing-scale)], but this procedure is preferred because it defaults
more useful way. @racket[alpha?] in a more useful way.
See also @racket[make-platform-bitmap] and @secref["Portability"]. 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?] @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%)]{ (is-a?/c bitmap%)]{
Creates a bitmap that uses platform-specific drawing operations 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) 'bmp 'bmp/alpha)
'unknown/alpha] 'unknown/alpha]
[bg-color (or/c (is-a?/c color%) #f) #f] [bg-color (or/c (is-a?/c color%) #f) #f]
[complain-on-failure? any/c #t]) [complain-on-failure? any/c #t]
[#:backing-scale backing-scale (>/c 0.0) 1.0])
(is-a?/c bitmap%)]{ (is-a?/c bitmap%)]{
Returns @racket[(make-object bitmap% in kind bg-color Returns @racket[(make-object bitmap% in kind bg-color
complain-on-failure?)], but this procedure is preferred because it complain-on-failure? backing-scale)], but this procedure is preferred
defaults @racket[kind] and @racket[complain-on-failure?] in a more because it defaults @racket[kind] and @racket[complain-on-failure?] in
useful way.} a more useful way.}
@defproc[(recorded-datum->procedure [datum any/c]) ((is-a?/c dc<%>) . -> . void?)]{ @defproc[(recorded-datum->procedure [datum any/c]) ((is-a?/c dc<%>) . -> . void?)]{

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

@ -35,7 +35,7 @@
;; FIXME: there must be some way to abstract over all many of the ;; FIXME: there must be some way to abstract over all many of the
;; ARGB/RGBA/BGRA iterations. ;; ARGB/RGBA/BGRA iterations.
(define-struct alternate-bitmap-kind (width height)) (define-struct alternate-bitmap-kind (width height scale))
(define-local-member-name (define-local-member-name
get-alphas-as-mask get-alphas-as-mask
@ -141,6 +141,9 @@
(define (get-empty-surface) (define (get-empty-surface)
(cairo_image_surface_create CAIRO_FORMAT_ARGB32 1 1)) (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% (define bitmap%
(class* object% (png-convertible<%>) (class* object% (png-convertible<%>)
@ -162,25 +165,29 @@
(init-rest args) (init-rest args)
(super-new) (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 (case-args
args args
[([alternate-bitmap-kind? a]) [([alternate-bitmap-kind? a])
(values #t (values #t
(alternate-bitmap-kind-width a) (alternate-bitmap-kind-width a)
(alternate-bitmap-kind-height 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? w]
[exact-positive-integer? h] [exact-positive-integer? h]
[any? [b&w? #f]] [any? [b&w? #f]]
[any? [alpha? #f]]) [any? [alpha? #f]]
[positive-real? [scale 1.0]])
(values (values
#f #f
w w
h h
(and b&w? #t) (and b&w? #t)
(and alpha? (not b&w?)) (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) (cairo_surface_flush s)
(cond (cond
[b&w? [b&w?
@ -194,11 +201,13 @@
(bytes-fill! (cairo_image_surface_get_data s) 255)]) (bytes-fill! (cairo_image_surface_get_data s) 255)])
(cairo_surface_mark_dirty s) (cairo_surface_mark_dirty s)
s) s)
#f)] #f
(* 1.0 scale))]
[([(make-alts path-string? input-port?) filename] [([(make-alts path-string? input-port?) filename]
[bitmap-file-kind-symbol? [kind 'unknown]] [bitmap-file-kind-symbol? [kind 'unknown]]
[(make-or-false color%) [bg-color #f]] [(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?)] (let-values ([(s b&w?) (do-load-bitmap filename kind bg-color complain-on-failure?)]
[(alpha?) (memq kind '(unknown/alpha gif/alpha jpeg/alpha [(alpha?) (memq kind '(unknown/alpha gif/alpha jpeg/alpha
png/alpha xbm/alpha xpm/alpha png/alpha xbm/alpha xpm/alpha
@ -230,13 +239,14 @@
(cairo_surface_mark_dirty s))))]) (cairo_surface_mark_dirty s))))])
(if s (if s
(values #f (values #f
(cairo_image_surface_get_width s) (/i (cairo_image_surface_get_width s) scale)
(cairo_image_surface_get_height s) (/i (cairo_image_surface_get_height s) scale)
b&w? b&w?
(and alpha? (not b&w?)) (and alpha? (not b&w?))
s s
mask-bm) mask-bm
(values #f 0 0 #f #f #f #f))))] (* 1.0 scale))
(values #f 0 0 #f #f #f #f (* 1.0 scale)))))]
[([bytes? bstr] [([bytes? bstr]
[exact-positive-integer? w] [exact-positive-integer? w]
[exact-positive-integer? h]) [exact-positive-integer? h])
@ -251,9 +261,20 @@
(let ([s (* i bw)]) (let ([s (* i bw)])
(subbytes bstr s (+ s bw)))))]) (subbytes bstr s (+ s bw)))))])
(install-bytes-rows s w h rows #t #f #f #t)) (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%))) (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: ;; Use for non-alpha color bitmaps when they are used as a mask:
(define alpha-s #f) (define alpha-s #f)
(define alpha-s-up-to-date? #f) (define alpha-s-up-to-date? #f)
@ -281,7 +302,14 @@
this))) this)))
(def/public (get-loaded-mask) loaded-mask) (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) (define/public (draw-bitmap-to cr sx sy dx dy w h alpha clipping)
#f) #f)
@ -304,6 +332,12 @@
[bg #f] [bg #f]
[complain-on-failure? #f]) [complain-on-failure? #f])
(check-alternate 'load-file) (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) (release-bitmap-storage)
(set!-values (s b&w?) (do-load-bitmap in kind bg complain-on-failure?)) (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)) (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)))))))))) (unsafe-bytes-set! dest (fx+ pos B) (premult al (unsafe-bytes-ref r (fx+ spos 2))))))))))
(cairo_surface_mark_dirty s))) (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)] (let* ([bm (make-object bitmap% w h #f #t)]
[cr (cairo_create (send bm get-cairo-surface))]) [cr (cairo_create (send bm get-cairo-surface))])
(let ([p (cairo_get_source cr)]) (let ([p (cairo_get_source cr)])
(cairo_pattern_reference p) (cairo_pattern_reference p)
(cairo_set_source_surface cr (get-cairo-surface) (- x) (- y)) (cairo_set_source_surface cr (get-cairo-surface) (- x) (- y))
(let ([sc (get-cairo-device-scale)])
(unless (= sc 1) (unless (= sc 1)
(let ([m (make-cairo_matrix_t 0.0 0.0 0.0 0.0 0.0 0.0)]) (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_init_translate m 0 0)
(cairo_matrix_scale m sc sc) (cairo_matrix_scale m sc sc)
(cairo_matrix_translate m x y) (cairo_matrix_translate m x y)
(cairo_pattern_set_matrix (cairo_get_source cr) m)))) (cairo_pattern_set_matrix (cairo_get_source cr) m)))
(cairo_new_path cr) (cairo_new_path cr)
(cairo_rectangle cr 0 0 w h) (cairo_rectangle cr 0 0 w h)
(cairo_fill cr) (cairo_fill cr)
@ -523,12 +556,15 @@
(proc bm) (proc bm)
(send bm release-bitmap-storage))) (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?) (and (ok?)
(begin (begin
(if alt? (if (or alt?
(and (not unscaled?)
(not (= backing-scale 1))))
(call-with-alt-bitmap (call-with-alt-bitmap
0 0 width height 0 0 width height (if unscaled? 1 backing-scale)
(lambda (bm) (lambda (bm)
(send bm save-file out kind quality))) (send bm save-file out kind quality)))
(do-save-file out kind quality)) (do-save-file out kind quality))
@ -570,8 +606,10 @@
loaded-mask loaded-mask
(= width (send loaded-mask get-width)) (= width (send loaded-mask get-width))
(= height (send loaded-mask get-height))) (= height (send loaded-mask get-height)))
(let ([bstr (make-bytes (* width height 4))]) (let* ([width (*i width backing-scale)]
(get-argb-pixels 0 0 width height bstr) [height (*i height backing-scale)]
[bstr (make-bytes (* width height 4))])
(get-argb-pixels 0 0 width height bstr #:unscaled? #t)
(when loaded-mask (when loaded-mask
(send loaded-mask get-argb-pixels 0 0 width height bstr #t)) (send loaded-mask get-argb-pixels 0 0 width height bstr #t))
;; PNG wants RGBA instead of ARGB... ;; PNG wants RGBA instead of ARGB...
@ -599,7 +637,9 @@
proc proc
(cairo_surface_write_to_png_stream s proc)))])] (cairo_surface_write_to_png_stream s proc)))])]
[(jpeg) [(jpeg)
(let ([c (create-compress out)]) (let ([c (create-compress out)]
[width (*i width backing-scale)]
[height (*i height backing-scale)])
(dynamic-wind (dynamic-wind
void void
(lambda () (lambda ()
@ -644,7 +684,7 @@
alpha-s)) alpha-s))
(get-empty-surface))) (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)) (define/public (get-backing-scale) (get-cairo-device-scale))
@ -652,19 +692,24 @@
(define/public (get-argb-pixels x y w h bstr (define/public (get-argb-pixels x y w h bstr
[get-alpha? #f] [get-alpha? #f]
[pre-mult? #f]) [pre-mult? #f]
#:unscaled? [unscaled? #f])
(unless ((bytes-length bstr) . >= . (* w h 4)) (unless ((bytes-length bstr) . >= . (* w h 4))
(raise-mismatch-error (method-name 'bitmap% 'get-argb-pixels) (raise-mismatch-error (method-name 'bitmap% 'get-argb-pixels)
"byte string is too short: " "byte string is too short: "
bstr)) bstr))
(when (ok?) (when (ok?)
(if alt? (unless (or (zero? w) (zero? h))
(if (or alt?
(and (not unscaled?)
(not (= backing-scale 1))))
(call-with-alt-bitmap (call-with-alt-bitmap
x y w h 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?))) (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?)))) (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?) (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: ;; Fill range that is beyond edge of picture:
(if get-alpha? (if get-alpha?
(for* ([i (in-range width (+ x w))] (for* ([i (in-range width (+ x w))]
@ -724,15 +769,40 @@
(define/public (set-argb-pixels x y w h bstr (define/public (set-argb-pixels x y w h bstr
[set-alpha? #f] [set-alpha? #f]
[pre-mult? #f]) [pre-mult? #f]
#:unscaled? [unscaled? #f])
(unless ((bytes-length bstr) . >= . (* w h 4)) (unless ((bytes-length bstr) . >= . (* w h 4))
(raise-mismatch-error (method-name 'bitmap% 'set-argb-pixels) (raise-mismatch-error (method-name 'bitmap% 'set-argb-pixels)
"byte string is too short: " "byte string is too short: "
bstr)) bstr))
(check-alternate 'set-argb-pixels) (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: ;; 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?) (when (not set-alpha?)
(cairo_surface_flush s) (cairo_surface_flush s)
(let ([data (cairo_image_surface_get_data s)] (let ([data (cairo_image_surface_get_data s)]
@ -793,7 +863,7 @@
(not alpha-channel?)) (not alpha-channel?))
;; Set alphas: ;; Set alphas:
(set-alphas-as-mask x y w h bstr (* 4 w) 0)]) (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) (define/public (get-alphas-as-mask x y w h bstr)
(let ([data (cairo_image_surface_get_data (if (or b&w? alpha-channel?) (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 1) vv)
(bytes-set! data (+ q 2) vv) (bytes-set! data (+ q 2) vv)
(bytes-set! data (+ q A) (if b&w? v 255))))))) (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] (define/top (make-bitmap [exact-positive-integer? w]
[exact-positive-integer? h] [exact-positive-integer? h]
[any? [alpha? #t]]) [any? [alpha? #t]]
(make-object bitmap% w h #f alpha?)) #: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] (define/top (read-bitmap [(make-alts path-string? input-port?) filename]
[bitmap-file-kind-symbol? [kind 'unknown/alpha]] [bitmap-file-kind-symbol? [kind 'unknown/alpha]]
[(make-or-false color%) [bg-color #f]] [(make-or-false color%) [bg-color #f]]
[any? [complain-on-failure? #t]]) [any? [complain-on-failure? #t]]
(make-object bitmap% filename kind bg-color complain-on-failure?)) #: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] (define/top (make-monochrome-bitmap [exact-positive-integer? w]
[exact-positive-integer? h] [exact-positive-integer? h]
@ -892,17 +962,18 @@
(make-object bitmap% w h #t))) (make-object bitmap% w h #t)))
(define/top (make-platform-bitmap [exact-positive-integer? w] (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) (case (system-type)
[(macosx) (make-object quartz-bitmap% w h)] [(macosx) (make-object quartz-bitmap% w h #t backing-scale)]
[(windows) (make-object win32-no-hwnd-bitmap% w h)] [(windows) (make-object win32-no-hwnd-bitmap% w h backing-scale)]
[(unix) (make-bitmap w h)])) [(unix) (make-bitmap w h #:backing-scale backing-scale)]))
(define-local-member-name build-cairo-surface) (define-local-member-name build-cairo-surface)
(define win32-no-hwnd-bitmap% (define win32-no-hwnd-bitmap%
(class bitmap% (class bitmap%
(init w h) (init w h backing-scale)
(super-make-object (make-alternate-bitmap-kind w h)) (super-make-object (make-alternate-bitmap-kind w h backing-scale))
(define s (build-cairo-surface w h)) (define s (build-cairo-surface w h))
;; erase the bitmap ;; erase the bitmap
@ -928,20 +999,11 @@
(define quartz-bitmap% (define quartz-bitmap%
(class bitmap% (class bitmap%
(init w h [with-alpha? #t] [resolution 1.0] [dest-cg #f]) (init w h [with-alpha? #t] [resolution 1.0] [dest-cg #f])
(super-make-object (make-alternate-bitmap-kind w h)) (super-make-object (make-alternate-bitmap-kind w h resolution))
(define cocoa-resolution resolution)
(define/override (get-cairo-device-scale)
cocoa-resolution)
(define s (define s
(let* ([sw (inexact->exact (let* ([sw (*i resolution w)]
(ceiling [sh (*i resolution h)]
(* cocoa-resolution w)))]
[sh (inexact->exact
(ceiling
(* cocoa-resolution h)))]
[s (if dest-cg [s (if dest-cg
(cairo_quartz_surface_create_for_cg_context dest-cg sw sh) (cairo_quartz_surface_create_for_cg_context dest-cg sw sh)
(cairo_quartz_surface_create (if with-alpha? (cairo_quartz_surface_create (if with-alpha?

7
pkgs/draw-pkgs/draw-lib/racket/draw/private/contract.rkt
View File

@ -403,7 +403,7 @@
exact-nonnegative-integer? exact-nonnegative-integer?
exact-nonnegative-integer? exact-nonnegative-integer?
(and/c bytes? (not/c immutable?))) (and/c bytes? (not/c immutable?)))
(any/c any/c) (any/c any/c #:unscaled? any/c)
void?)) void?))
(get-depth (->m exact-nonnegative-integer?)) (get-depth (->m exact-nonnegative-integer?))
(get-height (->m exact-nonnegative-integer?)) (get-height (->m exact-nonnegative-integer?))
@ -424,7 +424,8 @@
(ok? (->m boolean?)) (ok? (->m boolean?))
(save-file (->*m ((or/c path-string? output-port?) (save-file (->*m ((or/c path-string? output-port?)
(or/c 'png 'jpeg 'xbm 'xpm 'bmp)) (or/c 'png 'jpeg 'xbm 'xpm 'bmp))
((integer-in 0 100)) ((integer-in 0 100)
#:unscaled? any/c)
boolean?)) boolean?))
(set-argb-pixels (->*m (set-argb-pixels (->*m
(exact-nonnegative-integer? (exact-nonnegative-integer?
@ -432,6 +433,6 @@
exact-nonnegative-integer? exact-nonnegative-integer?
exact-nonnegative-integer? exact-nonnegative-integer?
bytes?) bytes?)
(any/c any/c) (any/c any/c #:unscaled? any/c)
void?)) void?))
(set-loaded-mask (->m (is-a?/c bitmap%) void?)))) (set-loaded-mask (->m (is-a?/c bitmap%) void?))))

29
pkgs/draw-pkgs/draw-lib/racket/draw/private/record-dc.rkt
View File

@ -292,7 +292,8 @@
(send b get-width) (send b get-width)
(send b get-height) (send b get-height)
(not (send b is-color?)) (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)]) [dc (make-object bitmap-dc% new-b)])
(send dc draw-bitmap b 0 0) (send dc draw-bitmap b 0 0)
(send dc set-bitmap #f) (send dc set-bitmap #f)
@ -303,20 +304,30 @@
(let () (let ()
(define w (send b get-width)) (define w (send b get-width))
(define h (send b get-height)) (define h (send b get-height))
(define bstr (make-bytes (* 4 w h))) (define s (send b get-backing-scale))
(send b get-argb-pixels 0 0 w h bstr) (define (scale v) (inexact->exact (ceiling (* s v))))
(list w h (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 is-color?)
(send b has-alpha-channel?) (send b has-alpha-channel?)
(bytes->immutable-bytes bstr))))) (bytes->immutable-bytes bstr)))
(if (= s 1)
l
(list* 'scale s l)))))
(define (unconvert-bitmap l) (define (unconvert-bitmap l)
(and l (and l
(let () (let ()
(define-values (w h color? alpha? bstr) (define-values (s w h color? alpha? bstr)
(apply values l)) (apply values (if (eq? (car l) 'scale)
(define bm (make-object bitmap% w h (not color?) alpha?)) (cdr l)
(send bm set-argb-pixels 0 0 w h bstr) (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))) bm)))
(define (convert-font f) (define (convert-font f)

51
pkgs/draw-pkgs/draw-lib/racket/draw/private/syntax.rkt
View File

@ -6,7 +6,7 @@
(provide defclass defclass* (provide defclass defclass*
def/public def/pubment def/public-final def/override def/override-final define/top case-args def/public def/pubment def/public-final def/override def/override-final define/top case-args
def/public-unimplemented define-unimplemented 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 make-literal symbol-in integer-in real-in make-procedure
method-name init-name method-name init-name
let-boxes let-boxes
@ -125,7 +125,9 @@
(if (apply-pred pred val) (if (apply-pred pred val)
#f #f
(cons (predicate-name pred) (cons (predicate-name pred)
pos))) (if (keyword? pos)
(list val)
pos))))
(define (predicate-name pred) (define (predicate-name pred)
(cond (cond
@ -141,6 +143,7 @@
(define (any? v) #t) (define (any? v) #t)
(define (bool? v) #t) (define (bool? v) #t)
(define (nonnegative-real? v) (and (real? v) (v . >= . 0))) (define (nonnegative-real? v) (and (real? v) (v . >= . 0)))
(define (positive-real? v) (and (real? v) (v . > . 0)))
(define (method-of cls nam) (define (method-of cls nam)
(if cls (if cls
@ -149,21 +152,51 @@
(define-syntax (def/thing stx) (define-syntax (def/thing stx)
(syntax-case stx () (syntax-case stx ()
[(_ define/orig (_ (id [arg-type arg] ...))) [(_ define/orig (_ (id arg ...)))
(raise-syntax-error #f "missing body" stx)] (raise-syntax-error #f "missing body" stx)]
[(_ define/orig (_ (id [arg-type arg] ...) . 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] (with-syntax ([(_ _ orig-stx) stx]
[(pos ...) (for/list ([i (in-range (length (syntax->list #'(arg ...))))])
i)]
[cname (syntax-parameter-value #'class-name)]) [cname (syntax-parameter-value #'class-name)])
(syntax/loc #'orig-stx (syntax/loc #'orig-stx
(define/orig (id arg ...) (define/orig (id arg ...)
(let ([bad (or (check-arg (just-id arg) arg-type pos) (let ([bad (or (check-arg arg-id arg-type 'pos)
...)]) ...)])
(when bad (when bad
(raise-type-error (method-of 'cname 'id) (car bad) (cdr bad) (just-id arg) ...))) (type-error (method-of 'cname 'id) (car bad) (cdr bad) arg-rep ...)))
(let () (let ()
. body))))])) . 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-for-syntax lifted (make-hash))
(define-syntax (lift-predicate stx) (define-syntax (lift-predicate stx)

2
pkgs/gui-pkgs/gui-lib/mred/private/wx/gtk/dc.rkt
View File

@ -45,7 +45,7 @@
(define x11-bitmap% (define x11-bitmap%
(class bitmap% (class bitmap%
(init w h gdk-win) (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 (define pixmap (gdk_pixmap_new gdk-win
(min (max 1 w) 32000) (min (max 1 w) 32000)

60
pkgs/gui-pkgs/gui-test/tests/gracket/dc.rktl
View File

@ -751,6 +751,66 @@
(test #t 'get-path-bounding-box (test-square-bounding-boxes)) (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) (report-errs)

12
pkgs/gui-pkgs/gui-test/tests/gracket/draw.rkt
View File

@ -225,6 +225,7 @@
[use-bitmap? #f] [use-bitmap? #f]
[platform-bitmap? #f] [platform-bitmap? #f]
[compat-bitmap? #f] [compat-bitmap? #f]
[scaled-bitmap? #f]
[use-record? #f] [use-record? #f]
[serialize-record? #f] [serialize-record? #f]
[use-bad? #f] [use-bad? #f]
@ -309,6 +310,8 @@
(make-platform-bitmap w h)] (make-platform-bitmap w h)]
[compat-bitmap? [compat-bitmap?
(send this make-bitmap w h)] (send this make-bitmap w h)]
[scaled-bitmap?
(make-bitmap w h #:backing-scale 3.0)]
[else [else
(make-object bitmap% w h depth-one? c-gray?)]))) (make-object bitmap% w h depth-one? c-gray?)])))
#f)] #f)]
@ -1310,15 +1313,16 @@
(super-new [parent parent][style '(hscroll vscroll)]) (super-new [parent parent][style '(hscroll vscroll)])
(init-auto-scrollbars (* 2 DRAW-WIDTH) (* 2 DRAW-HEIGHT) 0 0)) (init-auto-scrollbars (* 2 DRAW-WIDTH) (* 2 DRAW-HEIGHT) 0 0))
vp)]) 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) (lambda (self event)
(set! use-bitmap? (< 0 (send self get-selection))) (set! use-bitmap? (< 0 (send self get-selection)))
(set! depth-one? (= 2 (send self get-selection))) (set! depth-one? (= 2 (send self get-selection)))
(set! platform-bitmap? (= 3 (send self get-selection))) (set! platform-bitmap? (= 3 (send self get-selection)))
(set! compat-bitmap? (= 4 (send self get-selection))) (set! compat-bitmap? (= 4 (send self get-selection)))
(set! use-record? (<= 5 (send self get-selection) 6)) (set! scaled-bitmap? (= 5 (send self get-selection)))
(set! serialize-record? (= 6 (send self get-selection))) (set! use-record? (<= 6 (send self get-selection) 6))
(set! use-bad? (< 7 (send self get-selection))) (set! serialize-record? (= 7 (send self get-selection)))
(set! use-bad? (< 8 (send self get-selection)))
(send canvas refresh))) (send canvas refresh)))
(make-object button% "PS" hp (make-object button% "PS" hp
(lambda (self event) (lambda (self event)