From 876995d52cb734b361fde899636dcfd56e2b41a6 Mon Sep 17 00:00:00 2001 From: Neil Toronto Date: Fri, 4 Oct 2013 13:56:56 -0600 Subject: [PATCH] Added `point-label3d', notion of layers (back, area, front) to 3D plots --- pkgs/plot/contracted/plot-element.rkt | 6 ++- pkgs/plot/doc.rkt | 6 ++- pkgs/plot/main.rkt | 3 ++ pkgs/plot/plot3d/decoration.rkt | 66 ++++++++++++++++++++++++++ pkgs/plot/plot3d/plot-area.rkt | 60 +++++++++++++---------- pkgs/plot/plot3d/shape.rkt | 18 ++++--- pkgs/plot/scribblings/renderer3d.scrbl | 6 +++ pkgs/plot/tests/plot3d-tests.rkt | 5 ++ pkgs/plot/typed/main.rkt | 3 ++ pkgs/plot/typed/plot3d/decoration.rkt | 25 ++++++++++ 10 files changed, 164 insertions(+), 34 deletions(-) create mode 100644 pkgs/plot/plot3d/decoration.rkt create mode 100644 pkgs/plot/typed/plot3d/decoration.rkt diff --git a/pkgs/plot/contracted/plot-element.rkt b/pkgs/plot/contracted/plot-element.rkt index a2e9dfacd1..1b35b99fcb 100644 --- a/pkgs/plot/contracted/plot-element.rkt +++ b/pkgs/plot/contracted/plot-element.rkt @@ -33,4 +33,8 @@ (activate-contract-out default-ticks-fun function-bounds-fun function-interval-bounds-fun inverse-bounds-fun inverse-interval-bounds-fun - surface3d-bounds-fun)) + surface3d-bounds-fun) + plot3d-back-layer + plot3d-area-layer + plot3d-front-layer + ) diff --git a/pkgs/plot/doc.rkt b/pkgs/plot/doc.rkt index 46d505a472..1a46dca6c2 100644 --- a/pkgs/plot/doc.rkt +++ b/pkgs/plot/doc.rkt @@ -67,7 +67,8 @@ "plot3d/line.rkt" "plot3d/point.rkt" "plot3d/isosurface.rkt" - "plot3d/rectangle.rkt") + "plot3d/rectangle.rkt" + "plot3d/decoration.rkt") (provide (only-doc-out (combine-out (all-from-out "plot3d/plot.rkt") @@ -76,7 +77,8 @@ (all-from-out "plot3d/line.rkt") (all-from-out "plot3d/point.rkt") (all-from-out "plot3d/isosurface.rkt") - (all-from-out "plot3d/rectangle.rkt")))) + (all-from-out "plot3d/rectangle.rkt") + (all-from-out "plot3d/decoration.rkt")))) ;; =================================================================================================== ;; Deprecated functions diff --git a/pkgs/plot/main.rkt b/pkgs/plot/main.rkt index 7afc1e75da..745804f132 100644 --- a/pkgs/plot/main.rkt +++ b/pkgs/plot/main.rkt @@ -78,6 +78,9 @@ (require "plot3d/rectangle.rkt") (provide (activate-contract-out rectangles3d discrete-histogram3d stacked-histogram3d)) +(require "plot3d/decoration.rkt") +(provide (activate-contract-out point-label3d)) + ;; =================================================================================================== ;; Deprecated functions diff --git a/pkgs/plot/plot3d/decoration.rkt b/pkgs/plot/plot3d/decoration.rkt new file mode 100644 index 0000000000..fcf49ee5bf --- /dev/null +++ b/pkgs/plot/plot3d/decoration.rkt @@ -0,0 +1,66 @@ +#lang racket/base + +;; Renderers for plot decorations: labeled points only so far + +(require racket/contract racket/class racket/match racket/list + unstable/latent-contract/defthing + unstable/contract + plot/utils + "../common/utils.rkt" + ) + +(provide (all-defined-out)) + +;; =================================================================================================== +;; Labeled points + +(define (format-coordinate3d v area) + (match-define (vector x y z) v) + (match-define (vector (ivl x-min x-max) (ivl y-min y-max) (ivl z-min z-max)) + (send area get-bounds-rect)) + (match-define (list x-str) (format-tick-labels (plot-x-ticks) x-min x-max (list x))) + (match-define (list y-str) (format-tick-labels (plot-y-ticks) y-min y-max (list y))) + (match-define (list z-str) (format-tick-labels (plot-z-ticks) z-min z-max (list z))) + (format "(~a,~a,~a)" x-str y-str z-str)) + +(define ((label3d-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-coordinate3d v area))]) + (send area put-alpha alpha) + ; label + (send area put-text-foreground color) + (send area put-font size family) + (send area put-text (string-append " " label " ") v anchor angle (* 1/2 point-size) + #:outline? #t #:layer plot3d-front-layer) + ; point + (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 #:layer plot3d-front-layer)) + + empty) + +(defproc (point-label3d + [v (sequence/c real?)] [label (or/c string? #f) #f] + [#:color color plot-color/c (plot-foreground)] + [#:size size (>=/c 0) (plot-font-size)] + [#: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)] + ) renderer3d? + (let ([v (sequence-head-vector 'point-label3d v 3)]) + (match-define (vector x y z) v) + (renderer3d (vector (ivl x x) (ivl y y) (ivl z z)) #f #f + (label3d-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)))) diff --git a/pkgs/plot/plot3d/plot-area.rkt b/pkgs/plot/plot3d/plot-area.rkt index 91262e5da2..075b135596 100644 --- a/pkgs/plot/plot3d/plot-area.rkt +++ b/pkgs/plot/plot3d/plot-area.rkt @@ -15,7 +15,15 @@ "shape.rkt" "clip.rkt") -(provide (all-defined-out)) +(provide (all-defined-out) + plot3d-back-layer + plot3d-area-layer + plot3d-front-layer + ) + +(define plot3d-back-layer 2) +(define plot3d-area-layer 1) +(define plot3d-front-layer 0) (define plot3d-subdivisions (make-parameter 0)) @@ -643,12 +651,12 @@ (send pd set-alpha (shape-alpha s)) (match s ;; shapes - [(shapes alpha _ ss) (draw-shapes ss)] + [(shapes alpha _ _ ss) (draw-shapes ss)] ;; polygon - [(polygon alpha _ vs normal pen-color pen-width pen-style brush-color brush-style) + [(polygon alpha _ _ vs normal pen-color pen-width pen-style brush-color brush-style) (draw-polygon alpha center vs normal pen-color pen-width pen-style brush-color brush-style)] ;; rectangle - [(rectangle alpha _ r pen-color pen-width pen-style brush-color brush-style) + [(rectangle alpha _ _ r pen-color pen-width pen-style brush-color brush-style) (for ([face (in-list (rect-visible-faces r theta))]) (match face [(list normal vs ...) (draw-polygon alpha center vs @@ -656,25 +664,25 @@ brush-color brush-style)] [_ (void)]))] ;; line - [(line alpha _ v1 v2 pen-color pen-width pen-style) + [(line alpha _ _ v1 v2 pen-color pen-width pen-style) (send pd set-pen pen-color pen-width pen-style) (send pd draw-line (norm->dc v1) (norm->dc v2))] ;; text - [(text alpha _ anchor angle dist str font-size font-family color) + [(text alpha _ _ anchor angle dist str font-size font-family color outline?) (send pd set-font font-size font-family) (send pd set-text-foreground color) - (send pd draw-text str (view->dc center) anchor angle dist)] + (send pd draw-text str (view->dc center) anchor angle dist #:outline? outline?)] ;; glyph - [(glyph alpha _ symbol size pen-color pen-width pen-style brush-color brush-style) + [(glyph alpha _ _ symbol size pen-color pen-width pen-style brush-color brush-style) (send pd set-pen pen-color pen-width pen-style) (send pd set-brush brush-color brush-style) (send pd draw-glyphs (list (view->dc center)) symbol size)] ;; tick glyph - [(tick-glyph alpha _ radius angle pen-color pen-width pen-style) + [(tick-glyph alpha _ _ radius angle pen-color pen-width pen-style) (send pd set-pen pen-color pen-width pen-style) (send pd draw-tick (view->dc center) radius angle)] ;; arrow glyph - [(arrow-glyph alpha _ v1 v2 pen-color pen-width pen-style) + [(arrow-glyph alpha _ _ v1 v2 pen-color pen-width pen-style) (send pd set-pen pen-color pen-width pen-style) (send pd draw-arrow (norm->dc v1) (norm->dc v2))] [_ (error 'draw-shapes "shape not implemented: ~e" s)])) @@ -829,12 +837,14 @@ (values v1 v2))]) (unless (and v1 v2) (return (void))) (cond [identity-transforms? - (add-shape! (line alpha (plot->norm c) (plot->norm v1) (plot->norm v2) + (add-shape! (line alpha (plot->norm c) plot3d-area-layer + (plot->norm v1) (plot->norm v2) pen-color pen-width pen-style))] [else (define vs (subdivide-line plot->dc v1 v2)) (for ([v1 (in-list vs)] [v2 (in-list (rest vs))]) - (add-shape! (line alpha (plot->norm c) (plot->norm v1) (plot->norm v2) + (add-shape! (line alpha (plot->norm c) plot3d-area-layer + (plot->norm v1) (plot->norm v2) pen-color pen-width pen-style)))])))) (define/public (put-lines vs) @@ -856,7 +866,7 @@ vs)] [vs (if identity-transforms? vs (subdivide-polygon plot->dc vs))]) (when (empty? vs) (return lst)) - (cons (polygon alpha (plot->norm c) (map plot->norm vs) + (cons (polygon alpha (plot->norm c) plot3d-area-layer (map plot->norm vs) normal pen-color pen-width pen-style brush-color brush-style) lst)))) @@ -868,7 +878,7 @@ #:when (not (empty? vs))) (add-polygon lst vs (vcenter vs)))) (when (not (empty? lst)) - (add-shape! (shapes alpha (plot->norm c) lst)))) + (add-shape! (shapes alpha (plot->norm c) plot3d-area-layer lst)))) (define/public (put-rect r [c (rect-center r)]) (when (rect-rational? r) @@ -876,35 +886,37 @@ (match-define (vector (ivl x-min x-max) (ivl y-min y-max) (ivl z-min z-max)) r) (match-let ([(vector x-min y-min z-min) (plot->norm (vector x-min y-min z-min))] [(vector x-max y-max z-max) (plot->norm (vector x-max y-max z-max))]) - (add-shape! (rectangle alpha (plot->norm c) + (add-shape! (rectangle alpha (plot->norm c) plot3d-area-layer (vector (ivl x-min x-max) (ivl y-min y-max) (ivl z-min z-max)) pen-color pen-width pen-style brush-color brush-style)))))) - (define/public (put-text str v [anchor 'center] [angle 0] [dist 0]) + (define/public (put-text str v [anchor 'center] [angle 0] [dist 0] + #:outline? [outline? #f] + #:layer [layer plot3d-area-layer]) (when (and (vrational? v) (in-bounds? v)) - (add-shape! (text alpha (plot->norm v) anchor angle dist str - font-size font-family text-foreground)))) + (add-shape! (text alpha (plot->norm v) layer anchor angle dist str + font-size font-family text-foreground outline?)))) - (define/public (put-glyphs vs symbol size) + (define/public (put-glyphs vs symbol size #:layer [layer plot3d-area-layer]) (for ([v (in-list vs)]) (when (and (vrational? v) (in-bounds? v)) (add-shape! - (glyph alpha (plot->norm v) symbol size + (glyph alpha (plot->norm v) layer symbol size pen-color pen-width pen-style brush-color brush-style))))) (define/public (put-arrow v1 v2 [c (v* (v+ v1 v2) 1/2)]) (when (and (vrational? v1) (vrational? v2) (in-bounds? v1)) (cond [(in-bounds? v2) (add-shape! - (arrow-glyph alpha (plot->norm c) (plot->norm v1) (plot->norm v2) + (arrow-glyph alpha (plot->norm c) plot3d-area-layer (plot->norm v1) (plot->norm v2) (->brush-color (plot-background)) (+ 2 pen-width) 'solid)) (add-shape! - (arrow-glyph alpha (plot->norm c) (plot->norm v1) (plot->norm v2) + (arrow-glyph alpha (plot->norm c) plot3d-area-layer (plot->norm v1) (plot->norm v2) pen-color pen-width pen-style))] [else (put-line v1 v2)]))) - (define/public (put-tick v radius angle) + (define/public (put-tick v radius angle #:layer [layer plot3d-area-layer]) (when (and (vrational? v) (in-bounds? v)) - (add-shape! (tick-glyph alpha (plot->norm v) radius angle + (add-shape! (tick-glyph alpha (plot->norm v) layer radius angle pen-color pen-width pen-style)))) )) ; end class diff --git a/pkgs/plot/plot3d/shape.rkt b/pkgs/plot/plot3d/shape.rkt index ca2a68f773..4344677b95 100644 --- a/pkgs/plot/plot3d/shape.rkt +++ b/pkgs/plot/plot3d/shape.rkt @@ -5,12 +5,12 @@ (provide (all-defined-out)) -(struct shape (alpha center) #:transparent) +(struct shape (alpha center layer) #:transparent) (struct polygon shape (vs normal pen-color pen-width pen-style brush-color brush-style) #:transparent) (struct rectangle shape (rect pen-color pen-width pen-style brush-color brush-style) #:transparent) (struct line shape (v1 v2 pen-color pen-width pen-style) #:transparent) -(struct text shape (anchor angle dist str font-size font-family color) #:transparent) +(struct text shape (anchor angle dist str font-size font-family color outline?) #:transparent) (struct glyph shape (symbol size pen-color pen-width pen-style brush-color brush-style) #:transparent) (struct tick-glyph shape (radius angle pen-color pen-width pen-style) #:transparent) (struct arrow-glyph shape (start end pen-color pen-width pen-style) #:transparent) @@ -19,11 +19,15 @@ (define (draw-before? cs1 cs2) (match-define (cons s1 (vector x1 y1 z1)) cs1) (match-define (cons s2 (vector x2 y2 z2)) cs2) - (or (y1 . > . y2) - (and (y1 . = . y2) - (if (z1 . = . z2) - (and (polygon? s1) (not (polygon? s2))) - (z1 . < . z2))))) + (define l1 (shape-layer s1)) + (define l2 (shape-layer s2)) + (or (l1 . > . l2) + (and (l1 . = . l2) + (or (y1 . > . y2) + (and (y1 . = . y2) + (if (z1 . = . z2) + (and (polygon? s1) (not (polygon? s2))) + (z1 . < . z2))))))) (define (depth-sort s+cs) (sort s+cs draw-before?)) diff --git a/pkgs/plot/scribblings/renderer3d.scrbl b/pkgs/plot/scribblings/renderer3d.scrbl index 1acfedc7f3..e704069e3e 100644 --- a/pkgs/plot/scribblings/renderer3d.scrbl +++ b/pkgs/plot/scribblings/renderer3d.scrbl @@ -202,3 +202,9 @@ Think of it as a version of @racket[discrete-histogram] that allows multiple val (plot3d (stacked-histogram3d data #:labels '("Red" #f "Blue") #:alphas '(2/3 1 2/3)))] } + +@doc-apply[point-label3d]{ +Returns a renderer that draws a labeled point. +If @(racket label) is @(racket #f), the point is labeled with its position. +Analogous to @racket[point-label]. +} diff --git a/pkgs/plot/tests/plot3d-tests.rkt b/pkgs/plot/tests/plot3d-tests.rkt index 65252103c6..4b4f398c0c 100644 --- a/pkgs/plot/tests/plot3d-tests.rkt +++ b/pkgs/plot/tests/plot3d-tests.rkt @@ -249,3 +249,8 @@ (time (plot3d (contour-intervals3d (λ (x y) (- (sqr x) (sqr y))) -min.0 +min.0 -min.0 +min.0))) + +(time + (define (f x y) (* (sin x) (cos y))) + (plot3d (list (contour-intervals3d f -3 3 -3 3) + (point-label3d (list -1 1 (f -1 1)))))) diff --git a/pkgs/plot/typed/main.rkt b/pkgs/plot/typed/main.rkt index d61a4ef2a5..b35d56bf4b 100644 --- a/pkgs/plot/typed/main.rkt +++ b/pkgs/plot/typed/main.rkt @@ -74,3 +74,6 @@ (require "plot3d/rectangle.rkt") (provide (all-from-out "plot3d/rectangle.rkt")) + +(require "plot3d/decoration.rkt") +(provide (all-from-out "plot3d/decoration.rkt")) diff --git a/pkgs/plot/typed/plot3d/decoration.rkt b/pkgs/plot/typed/plot3d/decoration.rkt new file mode 100644 index 0000000000..c9fbf83024 --- /dev/null +++ b/pkgs/plot/typed/plot3d/decoration.rkt @@ -0,0 +1,25 @@ +#lang typed/racket/base + +(require "../common/types.rkt" + "../syntax.rkt") + +(provide point-label3d) + +(require/typed* + plot + + [point-label3d (((Sequenceof Real)) + ((Option String) + [#:color Plot-Color] + [#:size Real] + [#:family Font-Family] + [#:anchor Anchor] + [#:angle Real] + [#:point-color Plot-Color] + [#:point-fill-color (U Plot-Color 'auto)] + [#:point-size Real] + [#:point-line-width Real] + [#:point-sym Point-Sym] + [#:alpha Real]) + ->* renderer3d)] + )