From 8db45eb55788d63383334c93694e8e26a2e1108c Mon Sep 17 00:00:00 2001 From: Asumu Takikawa Date: Tue, 1 May 2012 20:31:31 -0400 Subject: [PATCH] Add immutable constructors for color%, brush%, pen% - Make set-immutable a local method and document is-immutable? as a public method - Add some racket/draw tests --- collects/mred/private/wx/cocoa/canvas.rkt | 3 +- collects/mred/private/wx/gtk/canvas.rkt | 3 +- collects/racket/draw.rkt | 5 ++- collects/racket/draw/private/brush.rkt | 15 ++++++- collects/racket/draw/private/color.rkt | 17 ++++++-- collects/racket/draw/private/contract.rkt | 28 ++++++++++++++ collects/racket/draw/private/pen.rkt | 17 +++++++- collects/scribblings/draw/brush-class.scrbl | 33 +++++++++++++++- collects/scribblings/draw/color-class.scrbl | 17 ++++++++ collects/scribblings/draw/pen-class.scrbl | 26 +++++++++++++ collects/tests/racket/draw.rktl | 43 +++++++++++++++++++++ 11 files changed, 197 insertions(+), 10 deletions(-) create mode 100644 collects/tests/racket/draw.rktl diff --git a/collects/mred/private/wx/cocoa/canvas.rkt b/collects/mred/private/wx/cocoa/canvas.rkt index e023ebe73e..434c113d92 100644 --- a/collects/mred/private/wx/cocoa/canvas.rkt +++ b/collects/mred/private/wx/cocoa/canvas.rkt @@ -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" diff --git a/collects/mred/private/wx/gtk/canvas.rkt b/collects/mred/private/wx/gtk/canvas.rkt index fc8b44ff17..80adf564f6 100644 --- a/collects/mred/private/wx/gtk/canvas.rkt +++ b/collects/mred/private/wx/gtk/canvas.rkt @@ -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" diff --git a/collects/racket/draw.rkt b/collects/racket/draw.rkt index 4a366400ad..83195ce490 100644 --- a/collects/racket/draw.rkt +++ b/collects/racket/draw.rkt @@ -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]) diff --git a/collects/racket/draw/private/brush.rkt b/collects/racket/draw/private/brush.rkt index db8d1e95c8..7dcbc7ccb5 100644 --- a/collects/racket/draw/private/brush.rkt +++ b/collects/racket/draw/private/brush.rkt @@ -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] diff --git a/collects/racket/draw/private/color.rkt b/collects/racket/draw/private/color.rkt index d716750eba..219fda2841 100644 --- a/collects/racket/draw/private/color.rkt +++ b/collects/racket/draw/private/color.rkt @@ -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 diff --git a/collects/racket/draw/private/contract.rkt b/collects/racket/draw/private/contract.rkt index ae2bc3f397..356bc42cb4 100644 --- a/collects/racket/draw/private/contract.rkt +++ b/collects/racket/draw/private/contract.rkt @@ -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 diff --git a/collects/racket/draw/private/pen.rkt b/collects/racket/draw/private/pen.rkt index 0f4f916319..32dc7d4aea 100644 --- a/collects/racket/draw/private/pen.rkt +++ b/collects/racket/draw/private/pen.rkt @@ -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% diff --git a/collects/scribblings/draw/brush-class.scrbl b/collects/scribblings/draw/brush-class.scrbl index d82fc02498..14af4b86de 100644 --- a/collects/scribblings/draw/brush-class.scrbl +++ b/collects/scribblings/draw/brush-class.scrbl @@ -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?]) diff --git a/collects/scribblings/draw/color-class.scrbl b/collects/scribblings/draw/color-class.scrbl index acdc3d82b7..7350cf4f1b 100644 --- a/collects/scribblings/draw/color-class.scrbl +++ b/collects/scribblings/draw/color-class.scrbl @@ -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?]{ diff --git a/collects/scribblings/draw/pen-class.scrbl b/collects/scribblings/draw/pen-class.scrbl index dacf50a258..33a6b8e634 100644 --- a/collects/scribblings/draw/pen-class.scrbl +++ b/collects/scribblings/draw/pen-class.scrbl @@ -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?]{ diff --git a/collects/tests/racket/draw.rktl b/collects/tests/racket/draw.rktl new file mode 100644 index 0000000000..a7be1a9975 --- /dev/null +++ b/collects/tests/racket/draw.rktl @@ -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)) \ No newline at end of file