suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

racket/draw gradient support

Browse Source
This commit is contained in:
Kevin Tew 2010-12-18 11:48:06 -07:00
parent ed114c0750
commit b88ff89837
10 changed files with 299 additions and 5 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
collects/racket/draw.rkt
View File

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

4
collects/racket/draw/draw-sig.rkt
View File

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

16
collects/racket/draw/private/brush.rkt
View File

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

25
collects/racket/draw/private/dc.rkt
View File

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

75
collects/racket/draw/private/gradient.rkt Normal file
View File

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

36
collects/racket/draw/unsafe/cairo.rkt
View File

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

23
collects/scribblings/draw/brush-class.scrbl
View File

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

2
collects/scribblings/draw/draw.scrbl
View File

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

56
collects/scribblings/draw/linear-gradient-class.scrbl Normal file
View File

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

62
collects/scribblings/draw/radial-gradient-class.scrbl Normal file
View File

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