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

Add immutable constructors for color%, brush%, pen%

Browse Source 
- Make set-immutable a local method and document
    is-immutable? as a public method
  - Add some racket/draw tests
This commit is contained in:
Asumu Takikawa 2012-05-01 20:31:31 -04:00
parent 466ffadb12
commit 8db45eb557
11 changed files with 197 additions and 10 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
collects/mred/private/wx/cocoa/canvas.rkt
View File

@ -4,7 +4,8 @@
racket/class
racket/draw
racket/draw/private/gl-context
(except-in racket/draw/private/color color%)
(except-in racket/draw/private/color
color% make-immutable-color)
(only-in racket/draw/private/bitmap quartz-bitmap%)
"pool.rkt"
"utils.rkt"

3
collects/mred/private/wx/gtk/canvas.rkt
View File

@ -3,7 +3,8 @@
racket/class
racket/draw
ffi/unsafe/alloc
(except-in racket/draw/private/color color%)
(except-in racket/draw/private/color
color% make-immutable-color)
racket/draw/private/local
"../common/backing-dc.rkt"
"../common/canvas-mixin.rkt"

5
collects/racket/draw.rkt
View File

@ -55,4 +55,7 @@
[region% region%/c]
[dc-path% dc-path%/c]
[gl-config% gl-config%/c]
[bitmap% bitmap%/c])
[bitmap% bitmap%/c]
[make-immutable-color make-immutable-color/c]
[make-immutable-pen make-immutable-pen/c]
[make-immutable-brush make-immutable-brush/c])

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

@ -11,6 +11,7 @@
"transform.rkt")
(provide brush%
make-immutable-brush
brush-list% the-brush-list
brush-style-symbol?)
@ -25,7 +26,8 @@
(define-local-member-name
s-set-key
set-surface-handle-info)
set-surface-handle-info
set-immutable)
(defclass brush% object%
(define key #f)
@ -131,6 +133,17 @@
(set! surface-handle h)
(set! transformation t)))
;; color style stipple gradient transformation -> brush%
;; produce an immutable brush% object
(define (make-immutable-brush [color "black"]
[style 'solid]
[stipple #f]
[gradient #f]
[transformation #f])
(define brush (make-object brush% color style stipple gradient transformation))
(send brush set-immutable)
brush)
;; unsafe (and so exported by `racket/draw/unsafe/brush'):
(provide (protect-out make-handle-brush))
(define (make-handle-brush handle width height [t #f]

17
collects/racket/draw/private/color.rkt
View File

@ -3,6 +3,7 @@
"syntax.rkt")
(provide color%
make-immutable-color
color-red
color-green
color-blue
@ -12,7 +13,8 @@
color->immutable-color)
(define-local-member-name
r g b a)
r g b a
set-immutable)
(defclass color% object%
(field [r 0]
@ -64,9 +66,9 @@
(set! b rb)
(set! a (exact->inexact ra)))))
(def/public (ok?) #t)
(def/public (is-immutable?) immutable?)
(def/public (set-immutable) (set! immutable? #t))
(define/public (ok?) #t)
(define/public (is-immutable?) immutable?)
(define/public (set-immutable) (set! immutable? #t))
(define/public (copy-from c)
(if immutable?
@ -79,6 +81,13 @@
(define color-blue (class-field-accessor color% b))
(define color-alpha (class-field-accessor color% a))
;; byte byte byte real -> color%
;; produce an immutable color% object
(define (make-immutable-color [r 0] [g 0] [b 0] [a 1.0])
(define color (make-object color% r g b a))
(send color set-immutable)
color)
(define (color->immutable-color c)
(if (send c is-immutable?)
c

28
collects/racket/draw/private/contract.rkt
View File

@ -49,6 +49,34 @@
(vector/c (vector/c real? real? real? real? real? real?)
real? real? real? real? real?))
(define make-immutable-color/c
(->* ()
((integer-in 0 255)
(integer-in 0 255)
(integer-in 0 255)
(real-in 0 1))
(is-a?/c color%)))
(define make-immutable-brush/c
(->* ()
((or/c string? (is-a?/c color%))
brush-style/c
(or/c #f (is-a?/c bitmap%))
(or/c #f
(is-a?/c linear-gradient%)
(is-a?/c radial-gradient%))
(or/c #f transformation-vector/c))
(is-a?/c brush%)))
(define make-immutable-pen/c
(->* ()
((or/c string? (is-a?/c color%))
(real-in 0 255)
pen-style/c
pen-cap-style/c
pen-join-style/c
(or/c #f (is-a?/c bitmap%)))
(is-a?/c pen%)))
(define dc<%>/c
(class/c

17
collects/racket/draw/private/pen.rkt
View File

@ -7,6 +7,7 @@
"bitmap.rkt")
(provide pen%
make-immutable-pen
pen-list% the-pen-list
pen-width?
pen-style-symbol?)
@ -30,7 +31,9 @@
(define black (send the-color-database find-color "black"))
(define-local-member-name s-set-key)
(define-local-member-name
s-set-key
set-immutable)
(defclass pen% object%
(define key #f)
@ -129,6 +132,18 @@
(check-immutable 'set-stipple)
(set! stipple s)))
;; color width style cap join stipple -> pen%
;; produce an immutable pen% object
(define (make-immutable-pen [color "black"]
[width 0]
[style 'solid]
[cap 'round]
[join 'round]
[stipple #f])
(define pen (make-object pen% color width style cap join stipple))
(send pen set-immutable)
pen)
;; ----------------------------------------
(defclass pen-list% object%

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

@ -104,7 +104,8 @@ To avoid creating multiple brushes with the same characteristics, use
#f]
[transformation (or/c #f (vector/c (vector/c real? real? real?
real? real? real?)
real? real? real? real? real?))])]{
real? real? real? real? real?))
#f])]{
Creates a brush with the given color, @tech{brush style}, @tech{brush
stipple}, @tech{gradient}, and @tech{brush transformation} (which is
@ -113,6 +114,28 @@ Creates a brush with the given color, @tech{brush style}, @tech{brush
@racket[color-database<%>] for information about color names; if the
name is not known, the brush's color is black.}
@defproc[(make-immutable-brush
[color (or/c string? (is-a?/c color%)) "black"]
[style (or/c 'transparent 'solid 'opaque
'xor 'hilite 'panel
'bdiagonal-hatch 'crossdiag-hatch
'fdiagonal-hatch 'cross-hatch
'horizontal-hatch 'vertical-hatch)
'solid]
[stipple (or/c #f (is-a?/c bitmap%))
#f]
[gradient (or/c #f
(is-a?/c linear-gradient%)
(is-a?/c radial-gradient%))
#f]
[transformation (or/c #f (vector/c (vector/c real? real? real?
real? real? real?)
real? real? real? real? real?))
#f])
(is-a?/c brush%)]{
Creates a new immutable brush with the given initialization values.
}
@defmethod[(get-color)
(is-a?/c color%)]{
@ -163,6 +186,14 @@ target drawing context's transformation; otherwise, the target drawing
context's transformation applies to stipple and gradient coordinates.}
@defmethod[(is-immutable?)
boolean?]{
Returns @racket[#t] if the brush object is immutable.
}
@defmethod*[([(set-color [color (is-a?/c color%)])
void?]
[(set-color [color-name string?])

17
collects/scribblings/draw/color-class.scrbl
View File

@ -29,6 +29,16 @@ Creates a new color with the given RGB values and alpha, or matching
}
@defproc[(make-immutable-color
[red (integer-in 0 255)]
[green (integer-in 0 255)]
[blue (integer-in 0 255)]
[alpha (real-in 0 1) 1.0])
(is-a?/c color%)]{
Creates a new immutable color with the given RGB values and alpha.
}
@defmethod[(alpha)
(real-in 0 1)]{
@ -58,6 +68,13 @@ Returns the green component of the color.
}
@defmethod[(is-immutable?)
boolean?]{
Returns @racket[#t] if the color object is immutable.
}
@defmethod[(ok?)
boolean?]{

26
collects/scribblings/draw/pen-class.scrbl
View File

@ -87,6 +87,25 @@ Creates a pen with the given color, width, @tech{pen style}, @tech{cap style}, @
}
@defproc[(make-immutable-pen
[color (or/c string? (is-a?/c color%)) "black"]
[width (real-in 0 255) 0]
[style (or/c 'transparent 'solid 'xor 'hilite
'dot 'long-dash 'short-dash 'dot-dash
'xor-dot 'xor-long-dash 'xor-short-dash
'xor-dot-dash)
'solid]
[cap (or/c 'round 'projecting 'butt)
'round]
[join (or/c 'round 'bevel 'miter)
'round]
[stipple (or/c #f (is-a?/c bitmap%))
#f])
(is-a?/c pen%)]{
Creates a new immutable pen with the given initialization values.
}
@defmethod[(get-cap)
(or/c 'round 'projecting 'butt)]{
@ -220,6 +239,13 @@ Returns the pen width.
}
@defmethod[(is-immutable?)
boolean?]{
Returns @racket[#t] if the pen object is immutable.
}
@defmethod[(set-cap [cap-style (or/c 'round 'projecting 'butt)])
void?]{

43
collects/tests/racket/draw.rktl Normal file
View File

@ -0,0 +1,43 @@
(load-relative "loadtest.rktl")
(Section 'draw)
(require racket/draw)
;; ----------------------------------------
(let ([color (new color%)])
(test #f (λ (c) (send c is-immutable?)) color)
(test 0 (λ (c) (send c red)) color)
(test 0 (λ (c) (send c green)) color)
(test 0 (λ (c) (send c blue)) color)
(test 1.0 (λ (c) (send c alpha)) color))
(let ([color (make-immutable-color 101 102 103 0.9)])
(test #t (λ (c) (send c is-immutable?)) color)
(test 101 (λ (c) (send c red)) color)
(test 102 (λ (c) (send c green)) color)
(test 103 (λ (c) (send c blue)) color)
(test 0.9 (λ (c) (send c alpha)) color))
(let ([color (make-immutable-color)])
(test #t (λ (c) (send c is-immutable?)) color)
(test 0 (λ (c) (send c red)) color)
(test 0 (λ (c) (send c green)) color)
(test 0 (λ (c) (send c blue)) color)
(test 1.0 (λ (c) (send c alpha)) color))
;; ----------------------------------------
(let ([brush (new brush%)])
(test #f (λ (b) (send b is-immutable?)) brush))
(let ([brush (make-immutable-brush)])
(test #t (λ (b) (send b is-immutable?)) brush))
;; ----------------------------------------
(let ([pen (new pen%)])
(test #f (λ (p) (send p is-immutable?)) pen))
(let ([pen (make-immutable-pen)])
(test #t (λ (p) (send p is-immutable?)) pen))