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).
This commit is contained in:
Matthew Flatt
parent
4f86f1de62
commit
5e903441a4
|
|
@ -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
|
||||
@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
|
||||
@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)
|
||||
(>/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,
|
||||
@racket[make-screen-bitmap] returns a bitmap whose backing scale is
|
||||
@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
|
||||
@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%)])
|
||||
void?]{
|
||||
|
|
|
|||
|
|
@ -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?]{
|
||||
|
|
|
|||
|
|
@ -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
|
||||
@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?)]{
|
||||
|
|
|
|||
|
|
@ -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?))))
|
||||
(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?)
|
||||
(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?
|
||||
|
|
|
|||
|
|
@ -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?))))
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user