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

Points renderers fill color option

Browse Source
This commit is contained in:
Neil Toronto 2011-11-22 23:44:53 -07:00
parent 192539259c
commit bf77e525cc
6 changed files with 92 additions and 39 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
collects/plot/common/legend.rkt
View File

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

42
collects/plot/common/plot-device.rkt
View File

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

53
collects/plot/plot2d/decoration.rkt
View File

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

13
collects/plot/plot2d/point.rkt
View File

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

14
collects/plot/plot3d/point.rkt
View File

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

5
collects/plot/tests/tick-tests.rkt
View File

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