From a974dad8bfb63679ac5af1fd819e7c7c67ee75e5 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 30 Dec 2010 06:40:05 -0700 Subject: [PATCH] add alpha value to `color%' --- collects/racket/draw/private/bitmap-dc.rkt | 23 +++++++--- collects/racket/draw/private/brush.rkt | 1 + collects/racket/draw/private/color.rkt | 27 ++++++++---- collects/racket/draw/private/dc.rkt | 49 +++++++++++---------- collects/racket/draw/private/pen.rkt | 1 + collects/racket/draw/private/record-dc.rkt | 6 +-- collects/scribblings/draw/color-class.scrbl | 33 +++++++++----- collects/scribblings/draw/dc-intf.scrbl | 16 ++++--- collects/scribblings/draw/font-class.scrbl | 8 +++- collects/tests/gracket/draw.rkt | 8 ++++ 10 files changed, 112 insertions(+), 60 deletions(-) diff --git a/collects/racket/draw/private/bitmap-dc.rkt b/collects/racket/draw/private/bitmap-dc.rkt index 8aa16dbad5..f7098100f5 100644 --- a/collects/racket/draw/private/bitmap-dc.rkt +++ b/collects/racket/draw/private/bitmap-dc.rkt @@ -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?) diff --git a/collects/racket/draw/private/brush.rkt b/collects/racket/draw/private/brush.rkt index 0d10846f5a..a3f8f9cb6f 100644 --- a/collects/racket/draw/private/brush.rkt +++ b/collects/racket/draw/private/brush.rkt @@ -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 diff --git a/collects/racket/draw/private/color.rkt b/collects/racket/draw/private/color.rkt index 25a56c4d3a..e594dd20c3 100644 --- a/collects/racket/draw/private/color.rkt +++ b/collects/racket/draw/private/color.rkt @@ -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?) diff --git a/collects/racket/draw/private/dc.rkt b/collects/racket/draw/private/dc.rkt index c017387cd3..0c41f9eb19 100644 --- a/collects/racket/draw/private/dc.rkt +++ b/collects/racket/draw/private/dc.rkt @@ -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)) diff --git a/collects/racket/draw/private/pen.rkt b/collects/racket/draw/private/pen.rkt index 085ab8a80c..e9ab1550f0 100644 --- a/collects/racket/draw/private/pen.rkt +++ b/collects/racket/draw/private/pen.rkt @@ -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 diff --git a/collects/racket/draw/private/record-dc.rkt b/collects/racket/draw/private/record-dc.rkt index fa42000784..45b164f2ee 100644 --- a/collects/racket/draw/private/record-dc.rkt +++ b/collects/racket/draw/private/record-dc.rkt @@ -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)]) diff --git a/collects/scribblings/draw/color-class.scrbl b/collects/scribblings/draw/color-class.scrbl index 07eb8a6582..66a6adae1c 100644 --- a/collects/scribblings/draw/color-class.scrbl +++ b/collects/scribblings/draw/color-class.scrbl @@ -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. }} diff --git a/collects/scribblings/draw/dc-intf.scrbl b/collects/scribblings/draw/dc-intf.scrbl index 5cc24d62b0..7a1a3fab2b 100644 --- a/collects/scribblings/draw/dc-intf.scrbl +++ b/collects/scribblings/draw/dc-intf.scrbl @@ -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%)]) diff --git a/collects/scribblings/draw/font-class.scrbl b/collects/scribblings/draw/font-class.scrbl index 5f5c04d60e..7f275fb5c0 100644 --- a/collects/scribblings/draw/font-class.scrbl +++ b/collects/scribblings/draw/font-class.scrbl @@ -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 diff --git a/collects/tests/gracket/draw.rkt b/collects/tests/gracket/draw.rkt index f885c00e8d..ae31b0c954 100644 --- a/collects/tests/gracket/draw.rkt +++ b/collects/tests/gracket/draw.rkt @@ -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)