From b88ff8983710da79e8f4b2fc05748b08fc5e92cd Mon Sep 17 00:00:00 2001 From: Kevin Tew Date: Sat, 18 Dec 2010 11:48:06 -0700 Subject: [PATCH] racket/draw gradient support --- collects/racket/draw.rkt | 5 ++ collects/racket/draw/draw-sig.rkt | 4 + collects/racket/draw/private/brush.rkt | 16 +++- collects/racket/draw/private/dc.rkt | 25 ++++++- collects/racket/draw/private/gradient.rkt | 75 +++++++++++++++++++ collects/racket/draw/unsafe/cairo.rkt | 36 +++++++++ collects/scribblings/draw/brush-class.scrbl | 23 +++++- collects/scribblings/draw/draw.scrbl | 2 + .../draw/linear-gradient-class.scrbl | 56 ++++++++++++++ .../draw/radial-gradient-class.scrbl | 62 +++++++++++++++ 10 files changed, 299 insertions(+), 5 deletions(-) create mode 100644 collects/racket/draw/private/gradient.rkt create mode 100644 collects/scribblings/draw/linear-gradient-class.scrbl create mode 100644 collects/scribblings/draw/radial-gradient-class.scrbl diff --git a/collects/racket/draw.rkt b/collects/racket/draw.rkt index 16e3134691..09970b1a65 100644 --- a/collects/racket/draw.rkt +++ b/collects/racket/draw.rkt @@ -5,6 +5,7 @@ "draw/private/font-dir.rkt" "draw/private/pen.rkt" "draw/private/brush.rkt" + "draw/private/gradient.rkt" "draw/private/region.rkt" "draw/private/bitmap.rkt" "draw/private/dc-path.rkt" @@ -22,6 +23,10 @@ font-name-directory<%> the-font-name-directory pen% pen-list% the-pen-list brush% brush-list% the-brush-list + linear-gradient% + radial-gradient% + make-linear-gradient + make-radial-gradient region% dc-path% dc<%> diff --git a/collects/racket/draw/draw-sig.rkt b/collects/racket/draw/draw-sig.rkt index 0d29b7c2a0..e2afb135e4 100644 --- a/collects/racket/draw/draw-sig.rkt +++ b/collects/racket/draw/draw-sig.rkt @@ -16,14 +16,18 @@ get-face-list get-family-builtin-face gl-config% gl-context<%> +linear-gradient% make-bitmap +make-linear-gradient make-monochrome-bitmap +make-radial-gradient pdf-dc% pen% pen-list% point% post-script-dc% ps-setup% +radial-gradient% region% the-brush-list the-color-database diff --git a/collects/racket/draw/private/brush.rkt b/collects/racket/draw/private/brush.rkt index d861f9dc6a..8a7ff6e550 100644 --- a/collects/racket/draw/private/brush.rkt +++ b/collects/racket/draw/private/brush.rkt @@ -4,7 +4,8 @@ "color.ss" "syntax.ss" "local.ss" - "bitmap.ss") + "bitmap.ss" + "gradient.rkt") (provide brush% brush-list% the-brush-list @@ -31,7 +32,8 @@ (init [(_color color) black] [(_style style) 'solid] - [(_stipple stipple) #f]) + [(_stipple stipple) #f] + [(_gradient gradient) #f]) (set! color (cond @@ -53,6 +55,15 @@ (define immutable? #f) (define lock-count 0) (define stipple #f) + (define gradient #f) + + (when _gradient + (unless (or (_gradient . is-a? . linear-gradient%) + (_gradient . is-a? . radial-gradient%)) + (raise-type-error (init-name 'brush%) + "gradient<%> or #f" + _gradient)) + (set! gradient _gradient)) (when _stipple (unless (_stipple . is-a? . bitmap%) @@ -87,6 +98,7 @@ (method-name 'brush% 'set-color))) (define/public (get-color) color) + (define/public (get-gradient) gradient) (def/public (get-stipple) stipple) (def/public (set-stipple [(make-or-false bitmap%) s]) diff --git a/collects/racket/draw/private/dc.rkt b/collects/racket/draw/private/dc.rkt index 60b6a6efe3..bdb94dc78a 100644 --- a/collects/racket/draw/private/dc.rkt +++ b/collects/racket/draw/private/dc.rkt @@ -14,6 +14,7 @@ "color.ss" "pen.ss" "brush.ss" + "gradient.ss" "font.ss" "bitmap.ss" "region.ss" @@ -728,6 +729,23 @@ (cairo_set_source cr p) (cairo_pattern_destroy p)))) + (define/private (make-gradient-pattern cr gradient) + (define p + (if (is-a? gradient linear-gradient%) + (call-with-values (lambda () (send gradient get-line)) cairo_pattern_create_linear) + (call-with-values (lambda () (send gradient get-circles)) cairo_pattern_create_radial))) + (for ([st (send gradient get-stops)]) + (let* ([offset (car st)] + [c (cadr st)] + [norm (lambda (v) (/ v 255.0))] + [r (norm (color-red c))] + [g (norm (color-green c))] + [b (norm (color-blue c))] + [a (color-alpha c)]) + (cairo_pattern_add_color_stop_rgba p offset r g b a))) + (cairo_set_source cr p) + (cairo_pattern_destroy p)) + ;; Stroke, fill, and flush the current path (define/private (draw cr brush? pen?) (define (install-stipple st col mode get put) @@ -767,7 +785,10 @@ (let ([s (send brush get-style)]) (unless (eq? 'transparent s) (let ([st (send brush get-stipple)] - [col (send brush get-color)]) + [col (send brush get-color)] + [gradient (send brush get-gradient)]) + (if gradient + (make-gradient-pattern cr gradient) (if st (install-stipple st col s (lambda () brush-stipple-s) @@ -826,7 +847,7 @@ (install-color cr (if (eq? s 'hilite) hilite-color col) alpha - #f)])))) + #f)]))))) (cairo_fill_preserve cr)))) (when pen? (let ([s (send pen get-style)]) diff --git a/collects/racket/draw/private/gradient.rkt b/collects/racket/draw/private/gradient.rkt new file mode 100644 index 0000000000..5dc9b0257f --- /dev/null +++ b/collects/racket/draw/private/gradient.rkt @@ -0,0 +1,75 @@ +#lang racket/base +(require racket/class + "syntax.rkt" + "color.rkt") + +(provide linear-gradient% + radial-gradient% + make-linear-gradient + make-radial-gradient) + +;(define gradient<%> +; (interface () +; get-stops)) + +(define (check-reals name lst) + (for ([x lst]) + (unless (real? x) + (raise-type-error (init-name name) "Coordinate must be a real? ~a" x)))) + +(define (check-radius name lst) + (for ([x lst]) + (unless (and (real? x) (not (negative? x))) + (raise-type-error (init-name name) "Radius must be a real? ~a" x)))) + +(define (check-stops name stops) + (unless (list? stops) (error name "Stops must be a list ~a" stops)) + (for ([x stops]) + (unless (list? x) (error name "A stop must be a list ~a" x)) + (unless (= (length x) 2) (error name "A stop must be a element list ~a" x)) + (unless (and (real? (car x)) (<= 0.0 (car x) 1.0)) + (error name "First element of a stop must be a real between 0.0 and 1.0 ~a" (car x))) + (unless (is-a? (cadr x) color%) + (error name "Second element of a stop must be a color% ~a" (cdr x))))) + +;(define linear-gradient% (class* object% (gradient<%>) +(define linear-gradient% (class object% + (init-field [x0 0] + [y0 0] + [x1 0] + [y1 0] + [stops null]) + + (check-reals 'linear-gradient% (list x0 y0 x1 y1)) + (check-stops 'linear-gradient% stops) + + (super-new) + + (define/public (get-line) (values x0 y0 x1 y1)) + (define/public (get-stops) stops))) + +;(define radial-gradient% (class* object% (gradient<%>) +(define radial-gradient% (class object% + (init-field [x0 0] + [y0 0] + [r0 0] + [x1 0] + [y1 0] + [r1 0] + [stops null]) + + (check-reals 'radial-gradient% (list x0 y0 x1 y1)) + (check-radius 'radial-gradient% (list r0 r1)) + (check-stops 'radial-gradient% stops) + + (super-new) + + (define/public (get-circles) (values x0 y0 r0 x1 y1 r1)) + (define/public (get-stops) stops))) + +(define (make-linear-gradient x0 y0 x1 y1 stopslst) + (make-object linear-gradient% x0 y0 x1 y1 stopslst)) + +(define (make-radial-gradient x0 y0 r0 x1 y1 r1 stopslst) + (make-object radial-gradient% x0 y0 r0 x1 y1 r1 stopslst)) + diff --git a/collects/racket/draw/unsafe/cairo.rkt b/collects/racket/draw/unsafe/cairo.rkt index 8dcdfed668..7be76da5ae 100644 --- a/collects/racket/draw/unsafe/cairo.rkt +++ b/collects/racket/draw/unsafe/cairo.rkt @@ -182,6 +182,7 @@ (define-cairo cairo_show_page (_fun _cairo_t -> _void)) +;; Patterns (define-cairo cairo_set_source (_fun _cairo_t _cairo_pattern_t -> _void)) (define-cairo cairo_get_source (_fun _cairo_t -> _cairo_pattern_t)) ;; not an allocator (define-cairo cairo_set_source_surface (_fun _cairo_t _cairo_surface_t _double* _double* -> _void)) @@ -196,6 +197,34 @@ (define-cairo cairo_pattern_set_matrix (_fun _cairo_pattern_t _cairo_matrix_t-pointer -> _void)) (define-cairo cairo_pattern_set_extend (_fun _cairo_pattern_t _int -> _void)) +;; Gradients +(define-cairo cairo_pattern_add_color_stop_rgb (_fun _cairo_pattern_t _double* _double* _double* _double* -> _void)) +(define-cairo cairo_pattern_add_color_stop_rgba (_fun _cairo_pattern_t _double* _double* _double* _double* _double* -> _void)) +(define-cairo cairo_pattern_get_color_stop_count (_fun _cairo_pattern_t (_ptr o _int) -> _int)) +(define-cairo cairo_pattern_get_color_stop_rgba (_fun _cairo_pattern_t _int (_ptr o _double*) (_ptr o _double*) (_ptr o _double*) (_ptr o _double*) (_ptr o _double*) -> _int)) + +(define-cairo cairo_pattern_create_rgb (_fun _double* _double* _double* -> _cairo_pattern_t) + #:wrap (allocator cairo_pattern_destroy)) +(define-cairo cairo_pattern_create_rgba (_fun _double* _double* _double* _double* -> _cairo_pattern_t) + #:wrap (allocator cairo_pattern_destroy)) +(define-cairo cairo_pattern_get_rgba (_fun _cairo_pattern_t (_ptr o _double*) (_ptr o _double*) (_ptr o _double*) (_ptr o _double*) -> _int)) ;; not an allocator +(define-cairo cairo_pattern_get_surface (_fun _cairo_pattern_t (_ptr o _cairo_surface_t) -> _int)) ;; not an allocator + +(define-cairo cairo_pattern_create_linear (_fun _double* _double* _double* _double* -> _cairo_pattern_t) + #:wrap (allocator cairo_pattern_destroy)) +(define-cairo cairo_pattern_get_linear_points (_fun _cairo_pattern_t (_ptr o _double*) (_ptr o _double*) (_ptr o _double*) (_ptr o _double*) -> _int)) +(define-cairo cairo_pattern_create_radial (_fun _double* _double* _double* _double* _double* _double* -> _cairo_pattern_t) + #:wrap (allocator cairo_pattern_destroy)) +(define-cairo cairo_pattern_get_radial_circles (_fun _cairo_pattern_t (_ptr o _double*) (_ptr o _double*) (_ptr o _double*) (_ptr o _double*) (_ptr o _double*) (_ptr o _double*) -> _int)) +(define-cairo cairo_pattern_status (_fun _cairo_pattern_t -> _int)) + +(define-cairo cairo_pattern_get_extend (_fun _cairo_pattern_t -> _int)) +(define-cairo cairo_pattern_set_filter (_fun _cairo_pattern_t _int -> _void)) +(define-cairo cairo_pattern_get_filter (_fun _cairo_pattern_t -> _int)) +(define-cairo cairo_pattern_get_matrix (_fun _cairo_pattern_t _cairo_matrix_t-pointer -> _void)) +(define-cairo cairo_pattern_get_type (_fun _cairo_pattern_t -> _int)) + + ;; Surfaces (define-cairo cairo_surface_finish (_fun _cairo_surface_t -> _void)) (define-cairo cairo_surface_flush (_fun _cairo_surface_t -> _void)) @@ -316,4 +345,11 @@ CAIRO_HINT_METRICS_OFF CAIRO_HINT_METRICS_ON) +(define-enum + 0 + CAIRO_PATTERN_TYPE_SOLID + CAIRO_PATTERN_TYPE_SURFACE + CAIRO_PATTERN_TYPE_LINEAR + CAIRO_PATTERN_TYPE_RADIAL) + (define/provide CAIRO_CONTENT_COLOR_ALPHA #x3000) diff --git a/collects/scribblings/draw/brush-class.scrbl b/collects/scribblings/draw/brush-class.scrbl index ecac49f23c..e9ced9ed43 100644 --- a/collects/scribblings/draw/brush-class.scrbl +++ b/collects/scribblings/draw/brush-class.scrbl @@ -1,6 +1,9 @@ #lang scribble/doc -@(require "common.ss") +@(require "common.ss" + scribble/eval) +@(define class-eval (make-base-eval)) +@(interaction-eval #:eval class-eval (require racket/class racket/draw)) @defclass/title[brush% object% ()]{ A brush is a drawing tool with a color and a style that is used for @@ -12,6 +15,15 @@ In addition to its color and style, a brush can have a stipple bitmap. stipple brush is similar to calling @method[dc<%> draw-bitmap] with the stipple bitmap in the filled region. +A brush can also be constructed as a @racket[linear-gradient%] or +@racket[radial-gradient%]. + +@examples[ #:eval class-eval +(new brush% [gradient (make-object linear-gradient% 0 0 10 10 + (list (list 0 (make-object color% 255 0 0)) + (list 0.5 (make-object color% 0 255 0)) + (list 1 (make-object color% 0 0 255))))])] + A brush's style is one of the following: @itemize[ @@ -98,6 +110,14 @@ Gets the stipple bitmap, or @scheme[#f] if the brush has no stipple. } +@defmethod[(get-gradient) + (or/c (is-a?/c gradient<%>) false/c)]{ + +Gets the gradient, or @scheme[#f] if the brush has no gradient. + +} + + @defmethod[(get-style) (one-of/c 'transparent 'solid 'opaque 'xor 'hilite 'panel @@ -158,3 +178,4 @@ A brush cannot be modified if it was obtained from a }} +@(close-eval class-eval) diff --git a/collects/scribblings/draw/draw.scrbl b/collects/scribblings/draw/draw.scrbl index 0d7bc3c38f..81e967d2fe 100644 --- a/collects/scribblings/draw/draw.scrbl +++ b/collects/scribblings/draw/draw.scrbl @@ -29,12 +29,14 @@ interface, and procedure bindings defined in this manual.} @include-section["font-name-directory-intf.scrbl"] @include-section["gl-config-class.scrbl"] @include-section["gl-context-intf.scrbl"] +@include-section["linear-gradient-class.scrbl"] @include-section["pdf-dc-class.scrbl"] @include-section["pen-class.scrbl"] @include-section["pen-list-class.scrbl"] @include-section["point-class.scrbl"] @include-section["post-script-dc-class.scrbl"] @include-section["ps-setup-class.scrbl"] +@include-section["radial-gradient-class.scrbl"] @include-section["region-class.scrbl"] @include-section["draw-funcs.scrbl"] @include-section["draw-unit.scrbl"] diff --git a/collects/scribblings/draw/linear-gradient-class.scrbl b/collects/scribblings/draw/linear-gradient-class.scrbl new file mode 100644 index 0000000000..f65dbfcf40 --- /dev/null +++ b/collects/scribblings/draw/linear-gradient-class.scrbl @@ -0,0 +1,56 @@ +#lang scribble/doc +@(require "common.ss" + scribble/eval) + +@(define class-eval (make-base-eval)) +@(interaction-eval #:eval class-eval (require racket/class racket/draw)) + +@defclass/title[linear-gradient% object% ()]{ + +A linear gradient is a pattern tool that is used for + filling in areas, such as the interior of a rectangle or ellipse. + +A linear gradient has a control vector and color stops along the line. + +@defconstructor[([x0 real? 0] + [y0 real? 0] + [x1 real? 0] + [y1 real? 0] + [stops (listof/c (list/c (real-in 0 1) (is-a?/c color%))) null])]{ + +Creates a linear gradient with the given line and color stops. +The gradients control vector is defined by its start point (x0, y0) and end point (x1, y1). +A color stop is a list containing an offset value between 0.0 and 1.0 and a @racket[color%]. + +} + +@defmethod[(get-line) + (values real? real? real? real?)]{ + +Returns the gradient's control line. + +} + +@defmethod[(get-stops) + (listof/c (list/c (real-in/c 0 1) (is-a?/c color%)))]{ + +Returns the gradient's list of color stops. + +} + +} +@examples[ #:eval class-eval + (define grad (new linear-gradient% + [x0 0] [y0 100] [x1 300] [y1 100] + [stops + (list (list 0 (make-object color% 0 0 255)) + (list 0.5 (make-object color% 0 255 0)) + (list 1 (make-object color% 255 0 0)))])) + + (define grad2 (make-object linear-gradient% 0 0 100 300 + (list (list 0 (make-object color% 0 0 255)) + (list 0.5 (make-object color% 0 255 0)) + (list 1 (make-object color% 255 0 0)))))] + + +@(close-eval class-eval) diff --git a/collects/scribblings/draw/radial-gradient-class.scrbl b/collects/scribblings/draw/radial-gradient-class.scrbl new file mode 100644 index 0000000000..0133db2e0e --- /dev/null +++ b/collects/scribblings/draw/radial-gradient-class.scrbl @@ -0,0 +1,62 @@ +#lang scribble/doc +@(require "common.ss" + scribble/eval) + +@(define class-eval (make-base-eval)) +@(interaction-eval #:eval class-eval (require racket/class racket/draw)) + +@defclass/title[radial-gradient% object% ()]{ + +A radial gradient is a pattern tool that is used for + filling in areas, such as the interior of a circle or ellipse. + +A radial gradient has two circles boundaries and color stops between the circles. + +@defconstructor[([x0 real? 0] + [y0 real? 0] + [r0 real? 0] + [x1 real? 0] + [y1 real? 0] + [r1 real? 0] + [stops (listof/c (list/c (real-in 0 1) (is-a?/c color%))) null])]{ + +Creates a radial gradient with the given circles boundaries and color stops. +Point (x0, y0) and radius r0 define the start bounding circle, while +point (x1, y1) and radius r1 define the end bounding circle. +The gradient's control vector extends from any point on the start circle to the +corresponding point on the end circle. +A color stop is a list containing an offset value between 0.0 and 1.0 and a @racket[color%]. + +} + +@defmethod[(get-circles) + (values real? real? real? real? real? real?)]{ + +Returns the gradient's boundary circles. + +} + +@defmethod[(get-stops) + (listof/c (list/c (real-in 0 1) (is-a?/c color%)))])]{ + +Returns the gradient's list of color stops. + +} + +} +@examples[ #:eval class-eval + (define grad (new radial-gradient% + [x0 0] [y0 100] [r0 10] [x1 300] [y1 100] [r1 100] + [stops + (list (list 0 (make-object color% 0 0 255)) + (list 0.5 (make-object color% 0 255 0)) + (list 1 (make-object color% 255 0 0)))])) + + (define grad2 (make-object radial-gradient% 150 150 0 150 150 100 + (list (list 0 (make-object color% 0 0 255)) + (list 0.5 (make-object color% 0 255 0)) + (list 1 (make-object color% 255 0 0)))))] + +@(close-eval class-eval) + +