From bf77e525cc0f8865bbd962f29b0b0b4430178a60 Mon Sep 17 00:00:00 2001 From: Neil Toronto Date: Tue, 22 Nov 2011 23:44:53 -0700 Subject: [PATCH] Points renderers fill color option --- collects/plot/common/legend.rkt | 4 ++- collects/plot/common/plot-device.rkt | 42 ++++++++++++---------- collects/plot/plot2d/decoration.rkt | 53 +++++++++++++++++++++++----- collects/plot/plot2d/point.rkt | 13 ++++--- collects/plot/plot3d/point.rkt | 14 +++++--- collects/plot/tests/tick-tests.rkt | 5 +-- 6 files changed, 92 insertions(+), 39 deletions(-) diff --git a/collects/plot/common/legend.rkt b/collects/plot/common/legend.rkt index b95855a169..2e43757c9b 100644 --- a/collects/plot/common/legend.rkt +++ b/collects/plot/common/legend.rkt @@ -159,9 +159,11 @@ ;; Point legends (defproc (point-legend-entry [label string?] [sym point-sym/c] - [color plot-color/c] [size (>=/c 0)] [line-width (>=/c 0)]) legend-entry? + [color plot-color/c] [fill-color plot-color/c] + [size (>=/c 0)] [line-width (>=/c 0)]) legend-entry? (legend-entry label (λ (pd x-size y-size) (send pd set-pen color line-width 'solid) + (send pd set-brush fill-color 'solid) (send pd set-alpha 1) (send pd draw-glyphs (list (vector (* 1/2 x-size) (* 1/2 y-size))) sym size)))) diff --git a/collects/plot/common/plot-device.rkt b/collects/plot/common/plot-device.rkt index 81def5c73c..730d27ba18 100644 --- a/collects/plot/common/plot-device.rkt +++ b/collects/plot/common/plot-device.rkt @@ -144,15 +144,19 @@ (define pen-hash (make-hash)) (define transparent-pen (make-pen% 0 0 0 1 'transparent)) + (define pen-color (->pen-color (plot-foreground))) + (define pen-width (plot-line-width)) (define pen-style 'solid) ;; Sets the pen, using a hash table to avoid making duplicate objects. At time of writing (and for ;; the forseeable future) this is much faster than using a pen-list%, because it doesn't have to ;; synchronize access. It's also not thread-safe. (define/public (set-pen color width style) + (set! pen-color (->pen-color color)) (match-define (list (app real->color-byte r) (app real->color-byte g) (app real->color-byte b)) - (->pen-color color)) + pen-color) (set! pen-style (->pen-style style)) + (set! pen-width width) (let ([style (if (eq? style 'transparent) 'transparent 'solid)]) (send dc set-pen (hash-ref! pen-hash (vector r g b width style) (λ () (make-pen% r g b width style)))))) @@ -167,10 +171,13 @@ (define brush-hash (make-hash)) + (define brush-color (->brush-color (plot-background))) + ;; Sets the brush. Same idea as set-pen. (define/public (set-brush color style) + (set! brush-color (->brush-color color)) (match-define (list (app real->color-byte r) (app real->color-byte g) (app real->color-byte b)) - (->brush-color color)) + brush-color) (let ([style (->brush-style style)]) (send dc set-brush (hash-ref! brush-hash (vector r g b style) (λ () (make-brush% r g b style)))))) @@ -429,23 +436,20 @@ (define/public (draw-glyphs vs sym size) (let-values ([(real-sym size) (translate-glyph-sym+size sym size)]) - (define pen (send dc get-pen)) - (define color (send pen get-color)) - (define width (send pen get-width)) - (define style (send pen get-style)) (define draw-glyph (cond [(string? real-sym) (set-font-size (* 2 size)) - (set-text-foreground color) + (set-text-foreground pen-color) (make-draw-text-glyph real-sym)] [(symbol? real-sym) (define r (* 1/2 size)) (define line-sym - (cond [(hash-has-key? full-glyph-hash real-sym) (set-pen color width 'transparent) - (set-brush color 'solid) - (hash-ref full-glyph-hash real-sym)] - [else (set-pen color width 'solid) - (set-brush color 'transparent) + (cond [(hash-has-key? full-glyph-hash real-sym) + (when (eq? pen-color brush-color) + (set-pen pen-color 1 'transparent) + (set-brush brush-color 'solid)) + (hash-ref full-glyph-hash real-sym)] + [else (set-brush brush-color 'transparent) real-sym])) (case line-sym ; circles @@ -460,23 +464,23 @@ [(triangleleft) (make-draw-polygon-glyph r 3 pi)] [(triangleright) (make-draw-polygon-glyph r 3 0)] ; dots - [(point pixel dot) (set-pen color (* 1/2 r) 'solid) + [(point pixel dot) (set-pen pen-color (* 1/2 r) 'solid) (λ (v) (draw-point v))] - [(odot) (set-pen color 1 'solid) - (mix-draw-glyph (make-draw-circle-glyph (+ width r)) + [(odot) (set-pen pen-color 1 'solid) + (mix-draw-glyph (make-draw-circle-glyph (+ pen-width r)) (λ (v) (draw-point v)))] ; flares [(plus) (make-draw-flare-glyph r 4 0)] [(times) (make-draw-flare-glyph r 4 (* 1/4 pi))] [(5asterisk) (make-draw-flare-glyph r 5 (* -1/2 pi))] [(asterisk) (make-draw-flare-glyph r 6 (* -1/2 pi))] - [(oplus) (mix-draw-glyph (make-draw-circle-glyph (+ width r)) + [(oplus) (mix-draw-glyph (make-draw-circle-glyph (+ pen-width r)) (make-draw-flare-glyph r 4 0))] - [(otimes) (mix-draw-glyph (make-draw-circle-glyph (+ width r)) + [(otimes) (mix-draw-glyph (make-draw-circle-glyph (+ pen-width r)) (make-draw-flare-glyph r 4 (* 1/4 pi)))] - [(o5asterisk) (mix-draw-glyph (make-draw-circle-glyph (+ width r)) + [(o5asterisk) (mix-draw-glyph (make-draw-circle-glyph (+ pen-width r)) (make-draw-flare-glyph r 5 (* -1/2 pi)))] - [(oasterisk) (mix-draw-glyph (make-draw-circle-glyph (+ width r)) + [(oasterisk) (mix-draw-glyph (make-draw-circle-glyph (+ pen-width r)) (make-draw-flare-glyph r 6 (* -1/2 pi)))] ; arrows [(rightarrow) (make-draw-arrow-glyph (+ 1 r) 0)] diff --git a/collects/plot/plot2d/decoration.rkt b/collects/plot/plot2d/decoration.rkt index bc4355178c..102075e69c 100644 --- a/collects/plot/plot2d/decoration.rkt +++ b/collects/plot/plot2d/decoration.rkt @@ -204,7 +204,10 @@ (match-define (list y-str) ((ticks-format (plot-y-ticks)) y-min y-max (list (pre-tick y #t)))) (format "(~a,~a)" x-str y-str)) -(define ((label-render-proc label v color size family anchor angle point-size alpha) area) +(define ((label-render-proc label v color size family anchor angle + point-color point-fill-color point-size point-line-width point-sym + alpha) + area) (let ([label (if label label (format-coordinate v area))]) (send area put-alpha alpha) ; label @@ -212,8 +215,9 @@ (send area put-font size family) (send area put-text (string-append " " label " ") v anchor angle (* 1/2 point-size) #:outline? #t) ; point - (send area put-pen color 1 'solid) - (send area put-glyphs (list v) 'fullcircle point-size)) + (send area put-pen point-color point-line-width 'solid) + (send area put-brush point-fill-color 'solid) + (send area put-glyphs (list v) point-sym point-size)) empty) @@ -224,12 +228,21 @@ [#:family family font-family/c (plot-font-family)] [#:anchor anchor anchor/c (label-anchor)] [#:angle angle real? (label-angle)] + [#:point-color point-color plot-color/c (point-color)] + [#:point-fill-color point-fill-color (or/c plot-color/c 'auto) 'auto] [#:point-size point-size (>=/c 0) (label-point-size)] + [#:point-line-width point-line-width (>=/c 0) (point-line-width)] + [#:point-sym point-sym point-sym/c 'fullcircle] [#:alpha alpha (real-in 0 1) (label-alpha)] ) renderer2d? (match-define (vector x y) v) (renderer2d (vector (ivl x x) (ivl y y)) #f #f - (label-render-proc label v color size family anchor angle point-size alpha))) + (label-render-proc + label v color size family anchor angle + point-color (cond [(eq? point-fill-color 'auto) (->pen-color point-color)] + [else point-fill-color]) + point-size point-line-width point-sym + alpha))) (defproc (parametric-label [f (real? . -> . (vector/c real? real?))] @@ -239,14 +252,20 @@ [#:family family font-family/c (plot-font-family)] [#:anchor anchor anchor/c (label-anchor)] [#:angle angle real? (label-angle)] + [#:point-color point-color plot-color/c (point-color)] + [#:point-fill-color point-fill-color (or/c plot-color/c 'auto) 'auto] [#:point-size point-size (>=/c 0) (label-point-size)] + [#:point-line-width point-line-width (>=/c 0) (point-line-width)] + [#:point-sym point-sym point-sym/c 'fullcircle] [#:alpha alpha (real-in 0 1) (label-alpha)] ) renderer2d? (point-label (match f [(vector fx fy) (vector (fx t) (fy t))] [(? procedure?) (f t)]) label #:color color #:size size #:family family #:anchor anchor #:angle angle - #:point-size point-size #:alpha alpha)) + #:point-color point-color #:point-fill-color point-fill-color #:point-size point-size + #:point-line-width point-line-width #:point-sym point-sym + #:alpha alpha)) (defproc (polar-label [f (real? . -> . real?)] [θ real?] [label (or/c string? #f) #f] @@ -255,12 +274,18 @@ [#:family family font-family/c (plot-font-family)] [#:anchor anchor anchor/c (label-anchor)] [#:angle angle real? (label-angle)] + [#:point-color point-color plot-color/c (point-color)] + [#:point-fill-color point-fill-color (or/c plot-color/c 'auto) 'auto] [#:point-size point-size (>=/c 0) (label-point-size)] + [#:point-line-width point-line-width (>=/c 0) (point-line-width)] + [#:point-sym point-sym point-sym/c 'fullcircle] [#:alpha alpha (real-in 0 1) (label-alpha)] ) renderer2d? (point-label (polar->cartesian θ (f θ)) label #:color color #:size size #:family family #:anchor anchor #:angle angle - #:point-size point-size #:alpha alpha)) + #:point-color point-color #:point-fill-color point-fill-color #:point-size point-size + #:point-line-width point-line-width #:point-sym point-sym + #:alpha alpha)) (defproc (function-label [f (real? . -> . real?)] [x real?] [label (or/c string? #f) #f] @@ -269,12 +294,18 @@ [#:family family font-family/c (plot-font-family)] [#:anchor anchor anchor/c (label-anchor)] [#:angle angle real? (label-angle)] + [#:point-color point-color plot-color/c (point-color)] + [#:point-fill-color point-fill-color (or/c plot-color/c 'auto) 'auto] [#:point-size point-size (>=/c 0) (label-point-size)] + [#:point-line-width point-line-width (>=/c 0) (point-line-width)] + [#:point-sym point-sym point-sym/c 'fullcircle] [#:alpha alpha (real-in 0 1) (label-alpha)] ) renderer2d? (point-label (vector x (f x)) label #:color color #:size size #:family family #:anchor anchor #:angle angle - #:point-size point-size #:alpha alpha)) + #:point-color point-color #:point-fill-color point-fill-color #:point-size point-size + #:point-line-width point-line-width #:point-sym point-sym + #:alpha alpha)) (defproc (inverse-label [f (real? . -> . real?)] [y real?] [label (or/c string? #f) #f] @@ -283,9 +314,15 @@ [#:family family font-family/c (plot-font-family)] [#:anchor anchor anchor/c (label-anchor)] [#:angle angle real? (label-angle)] + [#:point-color point-color plot-color/c (point-color)] + [#:point-fill-color point-fill-color (or/c plot-color/c 'auto) 'auto] [#:point-size point-size (>=/c 0) (label-point-size)] + [#:point-line-width point-line-width (>=/c 0) (point-line-width)] + [#:point-sym point-sym point-sym/c 'fullcircle] [#:alpha alpha (real-in 0 1) (label-alpha)] ) renderer2d? (point-label (vector (f y) y) label #:color color #:size size #:family family #:anchor anchor #:angle angle - #:point-size point-size #:alpha alpha)) + #:point-color point-color #:point-fill-color point-fill-color #:point-size point-size + #:point-line-width point-line-width #:point-sym point-sym + #:alpha alpha)) diff --git a/collects/plot/plot2d/point.rkt b/collects/plot/plot2d/point.rkt index cf7b6a3255..746401981e 100644 --- a/collects/plot/plot2d/point.rkt +++ b/collects/plot/plot2d/point.rkt @@ -11,18 +11,20 @@ ;; =================================================================================================== ;; Points (scatter plots) -(define ((points-render-fun vs sym color size line-width alpha label) area) +(define ((points-render-fun vs sym color fill-color size line-width alpha label) area) (send area put-alpha alpha) (send area put-pen color line-width 'solid) + (send area put-brush fill-color 'solid) (send area put-glyphs vs sym size) - (if label (point-legend-entry label sym color size line-width) empty)) + (if label (point-legend-entry label sym color fill-color size line-width) empty)) (defproc (points [vs (listof (vector/c real? real?))] [#:x-min x-min (or/c rational? #f) #f] [#:x-max x-max (or/c rational? #f) #f] [#:y-min y-min (or/c rational? #f) #f] [#:y-max y-max (or/c rational? #f) #f] [#:sym sym point-sym/c (point-sym)] [#:color color plot-color/c (point-color)] + [#:fill-color fill-color (or/c plot-color/c 'auto) 'auto] [#:size size (>=/c 0) (point-size)] [#:line-width line-width (>=/c 0) (point-line-width)] [#:alpha alpha (real-in 0 1) (point-alpha)] @@ -36,8 +38,11 @@ [x-max (if x-max x-max (apply max* xs))] [y-min (if y-min y-min (apply min* ys))] [y-max (if y-max y-max (apply max* ys))]) - (renderer2d (vector (ivl x-min x-max) (ivl y-min y-max)) #f default-ticks-fun - (points-render-fun vs sym color size line-width alpha label)))]))) + (renderer2d + (vector (ivl x-min x-max) (ivl y-min y-max)) #f default-ticks-fun + (points-render-fun vs sym color (cond [(eq? fill-color 'auto) (->pen-color color)] + [else fill-color]) + size line-width alpha label)))]))) ;; =================================================================================================== ;; Vector fields diff --git a/collects/plot/plot3d/point.rkt b/collects/plot/plot3d/point.rkt index 0820985827..29ca66c869 100644 --- a/collects/plot/plot3d/point.rkt +++ b/collects/plot/plot3d/point.rkt @@ -8,12 +8,13 @@ ;; =================================================================================================== -(define ((points3d-render-proc vs sym color size line-width alpha label) area) +(define ((points3d-render-proc vs sym color fill-color size line-width alpha label) area) (send area put-alpha alpha) (send area put-pen color line-width 'solid) + (send area put-brush fill-color 'solid) (send area put-glyphs vs sym size) - (cond [label (point-legend-entry label sym color size line-width)] + (cond [label (point-legend-entry label sym color fill-color size line-width)] [else empty])) (defproc (points3d @@ -23,6 +24,7 @@ [#:z-min z-min (or/c rational? #f) #f] [#:z-max z-max (or/c rational? #f) #f] [#:sym sym point-sym/c (point-sym)] [#:color color plot-color/c (point-color)] + [#:fill-color fill-color (or/c plot-color/c 'auto) 'auto] [#:size size (>=/c 0) (point-size)] [#:line-width line-width (>=/c 0) (point-line-width)] [#:alpha alpha (real-in 0 1) (point-alpha)] @@ -38,9 +40,11 @@ [y-max (if y-max y-max (apply max* ys))] [z-min (if z-min z-min (apply min* zs))] [z-max (if z-max z-max (apply max* zs))]) - (renderer3d (vector (ivl x-min x-max) (ivl y-min y-max) (ivl z-min z-max)) #f - default-ticks-fun - (points3d-render-proc vs sym color size line-width alpha label)))]))) + (renderer3d + (vector (ivl x-min x-max) (ivl y-min y-max) (ivl z-min z-max)) #f default-ticks-fun + (points3d-render-proc vs sym color (cond [(eq? fill-color 'auto) (->pen-color color)] + [else fill-color]) + size line-width alpha label)))]))) ;; =================================================================================================== diff --git a/collects/plot/tests/tick-tests.rkt b/collects/plot/tests/tick-tests.rkt index ada896ea20..7af955b663 100644 --- a/collects/plot/tests/tick-tests.rkt +++ b/collects/plot/tests/tick-tests.rkt @@ -185,8 +185,9 @@ (plot (list (function temp/time-trend 0 180 #:style 'long-dash #:color 3 #:label "Trend") (lines data #:color 2 #:width 2) - (points data #:color 1 #:line-width 2 #:label "Measurement") - (map (λ (d) (point-label d #:anchor 'bottom-right)) + (points data #:color 2 #:line-width 2 #:fill-color 0 #:sym 'fullcircle + #:label "Measurement") + (map (λ (d) (point-label d #:anchor 'bottom-right #:point-color 2 #:point-size 7)) above-data)) #:y-min -25 #:x-label "Time" #:y-label "Temp." #:title "Temp./Time With Applied Heat (Measurement and Trend)")))