racket/draw gradient support

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<%>

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

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]) 

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)])

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))
+

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)

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)

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"]

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)

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)
+
+