add alpha value to `color%'
This commit is contained in:
Matthew Flatt
parent
6fec1bcaf9
commit
a974dad8bf
|
|
@ -59,18 +59,27 @@
|
|||
'unsmoothed
|
||||
s))
|
||||
|
||||
(define/override (install-color cr c a)
|
||||
(define/override (install-color cr c a bg?)
|
||||
(if b&w?
|
||||
(begin
|
||||
(cairo_set_operator cr CAIRO_OPERATOR_SOURCE)
|
||||
(if (zero? a)
|
||||
(super install-color cr c a)
|
||||
(if (and (= (color-red c) 255)
|
||||
(= (color-green c) 255)
|
||||
(= (color-blue c) 255))
|
||||
(if (or (zero? a)
|
||||
(zero? (color-alpha c)))
|
||||
(super install-color cr c a bg?)
|
||||
(if (if bg?
|
||||
;; Background: all non-black to white
|
||||
(not (and (= (color-red c) 0)
|
||||
(= (color-green c) 0)
|
||||
(= (color-blue c) 0)
|
||||
(= (color-alpha c) 1.0)))
|
||||
;; Foreground: all non-white to black:
|
||||
(and (= (color-red c) 255)
|
||||
(= (color-green c) 255)
|
||||
(= (color-blue c) 255)
|
||||
(= (color-alpha c) 1.0)))
|
||||
(cairo_set_source_rgba cr 1.0 1.0 1.0 0.0)
|
||||
(cairo_set_source_rgba cr 0.0 0.0 0.0 1.0))))
|
||||
(super install-color cr c a)))
|
||||
(super install-color cr c a bg?)))
|
||||
|
||||
(define/override (collapse-bitmap-b&w?) b&w?)
|
||||
|
||||
|
|
|
|||
|
|
@ -116,6 +116,7 @@
|
|||
_style)]
|
||||
(method-name 'find-or-create-brush 'brush-list%))])
|
||||
(let ([key (vector (send col red) (send col green) (send col blue)
|
||||
(send col alpha)
|
||||
s)])
|
||||
(start-atomic)
|
||||
(begin0
|
||||
|
|
|
|||
|
|
@ -6,6 +6,7 @@
|
|||
color-red
|
||||
color-green
|
||||
color-blue
|
||||
color-alpha
|
||||
color-database<%> the-color-database
|
||||
color->immutable-color)
|
||||
|
||||
|
|
@ -15,7 +16,8 @@
|
|||
(defclass color% object%
|
||||
(field [r 0]
|
||||
[g 0]
|
||||
[b 0])
|
||||
[b 0]
|
||||
[a 1.0])
|
||||
(define immutable? #f)
|
||||
|
||||
(init-rest args)
|
||||
|
|
@ -34,24 +36,32 @@
|
|||
[([color% c])
|
||||
(set! r (color-red c))
|
||||
(set! g (color-green c))
|
||||
(set! b (color-blue c))]
|
||||
[([byte? _r][byte? _g][byte? _b])
|
||||
(set! b (color-blue c))
|
||||
(set! a (color-alpha c))]
|
||||
[([byte? _r] [byte? _g] [byte? _b])
|
||||
(set! r _r)
|
||||
(set! g (cadr args))
|
||||
(set! b (caddr args))]
|
||||
(set! g _g)
|
||||
(set! b _b)]
|
||||
[([byte? _r] [byte? _g] [byte? _b] [(real-in 0 1) _a])
|
||||
(set! r _r)
|
||||
(set! g _g)
|
||||
(set! b _b)
|
||||
(set! a (exact->inexact _a))]
|
||||
(init-name 'color%))
|
||||
|
||||
(def/public (red) r)
|
||||
(def/public (green) g)
|
||||
(def/public (blue) b)
|
||||
(def/public (alpha) a)
|
||||
|
||||
(def/public (set [byte? rr] [byte? rg] [byte? rb])
|
||||
(def/public (set [byte? rr] [byte? rg] [byte? rb] [(real-in 0 1) [ra 1.0]])
|
||||
(if immutable?
|
||||
(error (method-name 'color% 'set) "object is immutable")
|
||||
(begin
|
||||
(set! r rr)
|
||||
(set! g rg)
|
||||
(set! b rb))))
|
||||
(set! b rb)
|
||||
(set! a (exact->inexact ra)))))
|
||||
|
||||
(def/public (ok?) #t)
|
||||
(def/public (is-immutable?) immutable?)
|
||||
|
|
@ -60,11 +70,12 @@
|
|||
(def/public (copy-from [color% c])
|
||||
(if immutable?
|
||||
(error (method-name 'color% 'copy-from) "object is immutable")
|
||||
(set (send c red) (send c green) (send c blue)))))
|
||||
(set (color-red c) (color-green c) (color-blue c) (color-alpha c)))))
|
||||
|
||||
(define color-red (class-field-accessor color% r))
|
||||
(define color-green (class-field-accessor color% g))
|
||||
(define color-blue (class-field-accessor color% b))
|
||||
(define color-alpha (class-field-accessor color% a))
|
||||
|
||||
(define (color->immutable-color c)
|
||||
(if (send c is-immutable?)
|
||||
|
|
|
|||
|
|
@ -42,14 +42,7 @@
|
|||
(if (string? c)
|
||||
(or (send the-color-database find-color c)
|
||||
black)
|
||||
(if (send c is-immutable?)
|
||||
c
|
||||
(let ([c (make-object color%
|
||||
(color-red c)
|
||||
(color-green c)
|
||||
(color-blue c))])
|
||||
(send c set-immutable)
|
||||
c))))
|
||||
(color->immutable-color c)))
|
||||
|
||||
(define -bitmap-dc% #f)
|
||||
(define (install-bitmap-dc-class! v) (set! -bitmap-dc% v))
|
||||
|
|
@ -128,6 +121,13 @@
|
|||
;; Used to keep smoothing disabled for b&w contexts
|
||||
dc-adjust-smoothing
|
||||
|
||||
;; install-color : cairo_t color<%> alpha boolean? -> void
|
||||
;;
|
||||
;; Installs a color, which a monochrome context might reduce
|
||||
;; to black or white. The boolean argument indicates whether
|
||||
;; the color is for a background.
|
||||
install-color
|
||||
|
||||
;; The public get-size method:
|
||||
get-size
|
||||
|
||||
|
|
@ -185,13 +185,13 @@
|
|||
|
||||
(define/public (dc-adjust-smoothing s) s)
|
||||
|
||||
(define/public (install-color cr c a)
|
||||
(define/public (install-color cr c a bg?)
|
||||
(let ([norm (lambda (v) (/ v 255.0))])
|
||||
(cairo_set_source_rgba cr
|
||||
(norm (color-red c))
|
||||
(norm (color-green c))
|
||||
(norm (color-blue c))
|
||||
a)))
|
||||
(* a (color-alpha c)))))
|
||||
|
||||
(define/public (collapse-bitmap-b&w?) #f)
|
||||
|
||||
|
|
@ -216,8 +216,7 @@
|
|||
|
||||
(super-new)))
|
||||
|
||||
(define hilite-color (send the-color-database find-color "black"))
|
||||
(define hilite-alpha 0.3)
|
||||
(define hilite-color (make-object color% 0 0 0 0.3))
|
||||
|
||||
(define-local-member-name
|
||||
draw-bitmap-section/mask-offset)
|
||||
|
|
@ -629,7 +628,7 @@
|
|||
255
|
||||
0)])
|
||||
(send dest set v v v))
|
||||
(send dest set (color-red c) (color-green c) (color-blue c))))
|
||||
(send dest copy-from c)))
|
||||
|
||||
(define clipping-region #f)
|
||||
|
||||
|
|
@ -683,7 +682,7 @@
|
|||
(with-cr
|
||||
(check-ok 'erase)
|
||||
cr
|
||||
(install-color cr bg 1.0)
|
||||
(install-color cr bg alpha #t)
|
||||
(cairo_paint cr)))
|
||||
|
||||
(define/override (erase)
|
||||
|
|
@ -714,7 +713,7 @@
|
|||
CAIRO_CONTENT_COLOR_ALPHA
|
||||
12 12)]
|
||||
[cr2 (cairo_create s)])
|
||||
(install-color cr2 col alpha)
|
||||
(install-color cr2 col alpha #f)
|
||||
(cairo_set_line_width cr2 1)
|
||||
(cairo_set_line_cap cr CAIRO_LINE_CAP_ROUND)
|
||||
(cairo_set_antialias cr2 (case (dc-adjust-smoothing smoothing)
|
||||
|
|
@ -738,7 +737,8 @@
|
|||
(eq? mode 'solid)
|
||||
(and (= 0 (color-red col))
|
||||
(= 0 (color-green col))
|
||||
(= 0 (color-blue col))))
|
||||
(= 0 (color-blue col))
|
||||
(= 1.0 (color-alpha col))))
|
||||
(put (send st get-cairo-surface))]
|
||||
[(collapse-bitmap-b&w?)
|
||||
(put (send (bitmap-to-b&w-bitmap
|
||||
|
|
@ -825,7 +825,8 @@
|
|||
[else
|
||||
(install-color cr
|
||||
(if (eq? s 'hilite) hilite-color col)
|
||||
(if (eq? s 'hilite) hilite-alpha alpha))]))))
|
||||
alpha
|
||||
#f)]))))
|
||||
(cairo_fill_preserve cr))))
|
||||
(when pen?
|
||||
(let ([s (send pen get-style)])
|
||||
|
|
@ -838,7 +839,8 @@
|
|||
(lambda (v) (set! pen-stipple-s v) v))
|
||||
(install-color cr
|
||||
(if (eq? s 'hilite) hilite-color col)
|
||||
(if (eq? s 'hilite) hilite-alpha alpha))))
|
||||
alpha
|
||||
#f)))
|
||||
(cairo_set_line_width cr (let* ([v (send pen get-width)]
|
||||
[v (if (aligned? smoothing)
|
||||
(/ (floor (* effective-scale-x v)) effective-scale-x)
|
||||
|
|
@ -1164,12 +1166,12 @@
|
|||
(when (eq? text-mode 'solid)
|
||||
(unless rotate?
|
||||
(let-values ([(w h d a) (do-text cr #f s 0 0 font combine? 0 0.0)])
|
||||
(install-color cr text-bg alpha)
|
||||
(install-color cr text-bg alpha #f)
|
||||
(cairo_new_path cr)
|
||||
(cairo_rectangle cr x y w h)
|
||||
(cairo_fill cr))))
|
||||
(cairo_new_path cr) ; important for underline mode
|
||||
(install-color cr text-fg alpha))
|
||||
(install-color cr text-fg alpha #f))
|
||||
(when rotate?
|
||||
(cairo_save cr)
|
||||
(cairo_translate cr x y)
|
||||
|
|
@ -1501,7 +1503,8 @@
|
|||
(let ([black? (or (not color)
|
||||
(and (= 0 (color-red color))
|
||||
(= 0 (color-green color))
|
||||
(= 0 (color-blue color))))])
|
||||
(= 0 (color-blue color))
|
||||
(= 1.0 (color-alpha color))))])
|
||||
(cond
|
||||
[(and (collapse-bitmap-b&w?)
|
||||
(or (send src is-color?)
|
||||
|
|
@ -1597,11 +1600,11 @@
|
|||
(cairo_pattern_destroy s))]
|
||||
[else
|
||||
(when (eq? style 'opaque)
|
||||
(install-color cr bg alpha)
|
||||
(install-color cr bg alpha #f)
|
||||
(cairo_new_path cr)
|
||||
(cairo_rectangle cr a-dest-x a-dest-y a-dest-w a-dest-h)
|
||||
(cairo_fill cr))
|
||||
(install-color cr color alpha)
|
||||
(install-color cr color alpha #f)
|
||||
(stamp-pattern src a-src-x a-src-y)])
|
||||
(when clip-mask
|
||||
(cairo_restore cr))
|
||||
|
|
|
|||
|
|
@ -159,6 +159,7 @@
|
|||
_width _style _cap _join)]
|
||||
(method-name 'find-or-create-pen 'pen-list%))])
|
||||
(let ([key (vector (send col red) (send col green) (send col blue)
|
||||
(send col alpha)
|
||||
w s c j)])
|
||||
(start-atomic)
|
||||
(begin0
|
||||
|
|
|
|||
|
|
@ -29,9 +29,9 @@
|
|||
(make-object point% (point-x p) (point-y p)))
|
||||
|
||||
(define (clone-color c)
|
||||
(if (send c is-immutable?)
|
||||
c
|
||||
(make-object color% c)))
|
||||
(if (string? c)
|
||||
(string->immutable-string c)
|
||||
(color->immutable-color c)))
|
||||
|
||||
(define (clone-pen p)
|
||||
(let ([s (send p get-stipple)])
|
||||
|
|
|
|||
|
|
@ -4,10 +4,12 @@
|
|||
@defclass/title[color% object% ()]{
|
||||
|
||||
A color is an object representing a red-green-blue (RGB) combination
|
||||
of primary colors, and is used to determine drawing colors. Each red,
|
||||
green, or blue component of the color is in the range 0 to 255,
|
||||
inclusive. For example, (0, 0, 0) is black, (255, 255, 255) is
|
||||
white, and (255, 0, 0) is red.
|
||||
of primary colors plus an ``alpha'' for opacity. Each red, green, or
|
||||
blue component of the color is an exact integer in the range 0 to
|
||||
255, inclusive, and the alpha value is a real number between 0 and 1,
|
||||
inclusive. For example, (0, 0, 0, 1.0) is solid black, (255, 255,
|
||||
255, 1.0) is solid white, (255, 0, 0, 1.0) is solid red, and (255, 0,
|
||||
0, 0.5) is translucent red.
|
||||
|
||||
See @scheme[color-database<%>] for information about obtaining a color
|
||||
object using a color name.
|
||||
|
|
@ -16,13 +18,21 @@ object using a color name.
|
|||
@defconstructor*/make[(()
|
||||
([red (integer-in 0 255)]
|
||||
[green (integer-in 0 255)]
|
||||
[blue (integer-in 0 255)])
|
||||
[blue (integer-in 0 255)]
|
||||
[alpha (real-in 0 1)])
|
||||
([color-name string?]))]{
|
||||
|
||||
Creates a new color with the given RGB values, or matching the given
|
||||
color name (using ``black'' if no color is given or if the name is
|
||||
not recognized). See @scheme[color-database<%>] for more information
|
||||
on color names.
|
||||
Creates a new color with the given RGB values and alpha, or matching
|
||||
the given color name (using ``black'' if no color is given or if the
|
||||
name is not recognized). See @scheme[color-database<%>] for more
|
||||
information on color names.
|
||||
|
||||
}
|
||||
|
||||
@defmethod[(alpha)
|
||||
(real-in 0 1)]{
|
||||
|
||||
Returns the alpha component (i.e., opacity) of the color.
|
||||
|
||||
}
|
||||
|
||||
|
|
@ -64,9 +74,10 @@ Returns the red component of the color.
|
|||
|
||||
@defmethod[(set [red (integer-in 0 255)]
|
||||
[green (integer-in 0 255)]
|
||||
[blue (integer-in 0 255)])
|
||||
[blue (integer-in 0 255)]
|
||||
[alpha (real-in 0 1) 1.0])
|
||||
void?]{
|
||||
|
||||
Sets the three (red, green, and blue) component values of the color.
|
||||
Sets the four (red, green, blue, and alpha) component values of the color.
|
||||
}}
|
||||
|
||||
|
|
|
|||
|
|
@ -130,12 +130,13 @@ The effect of @racket[mask] on drawing depends on the type of the
|
|||
The current brush, current pen, and current text for the DC have no
|
||||
effect on how the bitmap is drawn, but the bitmap is scaled if the DC
|
||||
has a scale, and the DC's alpha setting determines the opacity of the
|
||||
drawn pixels (in combination with an alpha channel of @racket[source]
|
||||
and any given @racket[mask]).
|
||||
drawn pixels (in combination with an alpha channel of @racket[source],
|
||||
any given @racket[mask], and the alpha component of @racket[color]
|
||||
when @racket[source] is monochrome).
|
||||
|
||||
For @scheme[post-script-dc%] and @racket[pdf-dc%] output, opacity from
|
||||
an alpha channel in @racket[source] or from @racket[mask] is
|
||||
rounded to full transparency or opacity.
|
||||
an alpha channel in @racket[source], from @racket[mask], or from
|
||||
@racket[color] is rounded to full transparency or opacity.
|
||||
|
||||
The result is @scheme[#t] if the bitmap is successfully drawn,
|
||||
@scheme[#f] otherwise (possibly because the bitmap's @method[bitmap%
|
||||
|
|
@ -466,7 +467,7 @@ For printer or PostScript output, an exception is raised if
|
|||
void?]{
|
||||
|
||||
Erases the drawing region by filling it with white and, for a drawing
|
||||
context that keeps an alpha channels, sets all alphas to zero.
|
||||
context that keeps an alpha channel, sets all alphas to zero.
|
||||
|
||||
}
|
||||
|
||||
|
|
@ -799,13 +800,16 @@ rotation settings have their identity values.
|
|||
|
||||
}
|
||||
|
||||
|
||||
@defmethod[(set-alpha [opacity (real-in 0 1)])
|
||||
void?]{
|
||||
|
||||
Determines the opacity of drawing. A value of @scheme[0.0] corresponds
|
||||
to completely transparent (i.e., invisible) drawing, and @scheme[1.0]
|
||||
corresponds to completely opaque drawing. For intermediate values,
|
||||
drawing is blended with the existing content of the drawing context.}
|
||||
drawing is blended with the existing content of the drawing context.
|
||||
A color (e.g. for a brush) also has an alpha value; it is combined
|
||||
with the drawing context's alpha by multiplying.}
|
||||
|
||||
|
||||
@defmethod[(set-background [color (is-a?/c color%)])
|
||||
|
|
|
|||
|
|
@ -84,7 +84,9 @@ See also
|
|||
[style (one-of/c 'normal 'italic 'slant) 'normal]
|
||||
[weight (one-of/c 'normal 'bold 'light) 'normal]
|
||||
[underline? any/c #f]
|
||||
[smoothing (one-of/c 'default 'partly-smoothed 'smoothed 'unsmoothed) 'default]
|
||||
[smoothing (one-of/c 'default 'partly-smoothed
|
||||
'smoothed 'unsmoothed)
|
||||
'default]
|
||||
[size-in-pixels? any/c #f])
|
||||
([size (integer-in 1 255)]
|
||||
[face string?]
|
||||
|
|
@ -93,7 +95,9 @@ See also
|
|||
[style (one-of/c 'normal 'italic 'slant) 'normal]
|
||||
[weight (one-of/c 'normal 'bold 'light) 'normal]
|
||||
[underline? any/c #f]
|
||||
[smoothing (one-of/c 'default 'partly-smoothed 'smoothed 'unsmoothed) 'default]
|
||||
[smoothing (one-of/c 'default 'partly-smoothed
|
||||
'smoothed 'unsmoothed)
|
||||
'default]
|
||||
[size-in-pixels? any/c #f]))]{
|
||||
|
||||
When no arguments are provided, creates an instance of the default
|
||||
|
|
|
|||
|
|
@ -920,6 +920,14 @@
|
|||
100 310)
|
||||
p))
|
||||
|
||||
(let ([p (send dc get-pen)])
|
||||
(send dc set-pen (make-object color% 0 0 0 0.1) 1 'solid)
|
||||
(send dc set-brush (make-object color% 255 0 200 0.5) 'solid)
|
||||
(send dc draw-rectangle 250 310 20 20)
|
||||
(send dc set-brush (make-object color% 0 255 200 0.5) 'solid)
|
||||
(send dc draw-rectangle 260 320 20 20)
|
||||
(send dc set-pen p))
|
||||
|
||||
(send dc draw-line 130 310 150 310)
|
||||
(send dc draw-line 130 312.5 150 312.5)
|
||||
(send dc draw-line 130 314.3 150 314.3)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user