From 5bd8481aa78030e7b811317e791e4cbad2a838ec Mon Sep 17 00:00:00 2001 From: Neil Toronto Date: Mon, 7 Nov 2011 15:47:46 -0700 Subject: [PATCH] 2D stacked histograms, grouped histograms, collapse indistinguishable ticks, doc tests, fixes --- collects/plot/common/axis-transform.rkt | 4 +- collects/plot/common/contract-doc.rkt | 8 +- collects/plot/common/contract.rkt | 53 ++++-- collects/plot/common/draw.rkt | 5 - collects/plot/common/legend.rkt | 124 ++++++------ collects/plot/common/parameters.rkt | 57 +++--- collects/plot/common/ticks.rkt | 33 ++-- collects/plot/common/utils.rkt | 8 +- collects/plot/contracted/draw.rkt | 3 +- collects/plot/contracted/legend.rkt | 1 - collects/plot/contracted/parameters.rkt | 10 +- collects/plot/contracted/ticks.rkt | 2 +- collects/plot/deprecated/renderers.rkt | 2 +- collects/plot/main.rkt | 10 +- collects/plot/plot2d/contour.rkt | 209 +++++++++++---------- collects/plot/plot2d/plot-area.rkt | 18 +- collects/plot/plot2d/rectangle.rkt | 53 +++++- collects/plot/plot3d/contour.rkt | 205 +++++++++++--------- collects/plot/plot3d/isosurface.rkt | 178 +++++++++--------- collects/plot/plot3d/plot-area.rkt | 65 ++++--- collects/plot/plot3d/point.rkt | 68 +++++++ collects/plot/plot3d/shape.rkt | 1 + collects/plot/scribblings/renderer2d.scrbl | 8 - collects/plot/scribblings/renderer3d.scrbl | 14 +- collects/plot/tests/doc-tests.rkt | 31 +++ collects/plot/tests/isosurface-tests.rkt | 4 +- collects/plot/tests/plot2d-tests.rkt | 25 ++- collects/plot/tests/plot3d-tests.rkt | 4 + 28 files changed, 719 insertions(+), 484 deletions(-) create mode 100644 collects/plot/tests/doc-tests.rkt diff --git a/collects/plot/common/axis-transform.rkt b/collects/plot/common/axis-transform.rkt index 3b45d7bc3d..72d67857fa 100644 --- a/collects/plot/common/axis-transform.rkt +++ b/collects/plot/common/axis-transform.rkt @@ -26,8 +26,8 @@ (defproc (apply-axis-transform [t axis-transform/c] [x-min real?] [x-max real?]) invertible-function? (t x-min x-max id-function)) -;; Turns any total, surjective, monotone flonum op and its inverse into an axis transform -(defproc (make-axis-transform [f axis-transform/c] [g axis-transform/c]) axis-transform/c +;; Turns any total, surjective, monotone real function and its inverse into an axis transform +(defproc (make-axis-transform [f (real? . -> . real?)] [g (real? . -> . real?)]) axis-transform/c (λ (x-min x-max old-function) (define fx-min (f x-min)) (define fx-scale (/ (- x-max x-min) (- (f x-max) fx-min))) diff --git a/collects/plot/common/contract-doc.rkt b/collects/plot/common/contract-doc.rkt index 21d4b4d5ea..c252a3a560 100644 --- a/collects/plot/common/contract-doc.rkt +++ b/collects/plot/common/contract-doc.rkt @@ -22,9 +22,11 @@ ;; A define-with-value form for scribble documentation (define (def/value def val . pre-flows) - (apply s.nested (s.tabular #:style def/value-table-style - (list (list (s.nested def) 'cont) - (list "=" val))) + (apply s.nested + (s.tabular #:style (s.style 'boxed '()) + (list (list (s.nested def)) + (list (s.tabular #:style def/value-table-style + (list (list "=" val)))))) pre-flows)) (define def/value-table-style diff --git a/collects/plot/common/contract.rkt b/collects/plot/common/contract.rkt index be93e9a1e7..16fc964022 100644 --- a/collects/plot/common/contract.rkt +++ b/collects/plot/common/contract.rkt @@ -1,16 +1,28 @@ #lang racket/base -(require racket/contract racket/draw racket/class unstable/latent-contract +(require racket/contract racket/draw racket/class unstable/latent-contract unstable/contract "contract-doc.rkt") -(provide (except-out (all-defined-out) treeof) - (activate-contract-out treeof)) +(provide (except-out (all-defined-out) + treeof + maybe-function/c maybe-apply + plot-colors/c pen-widths/c plot-pen-styles/c plot-brush-styles/c alphas/c + labels/c) + (activate-contract-out + treeof + maybe-function/c maybe-apply + plot-colors/c pen-widths/c plot-pen-styles/c plot-brush-styles/c alphas/c + labels/c) + nat/c pos/c truth/c) ;; =================================================================================================== ;; Convenience -(defcontract (treeof [ct (or/c contract? (any/c . -> . any/c))]) - (or/c ct (listof (recursive-contract (treeof ct))))) +(defcontract contract/c (or/c contract? (any/c . -> . any/c))) + +(defcontract (treeof [elem-contract contract/c]) + (or/c elem-contract + (listof (recursive-contract (treeof elem-contract))))) ;; =================================================================================================== ;; Plot-specific contracts @@ -61,17 +73,28 @@ (defcontract point-sym/c (or/c char? string? integer? (apply one-of/c known-point-symbols))) -(defcontract plot-colors/c (or/c (listof plot-color/c) - ((listof real?) . -> . (listof plot-color/c)))) +(defcontract (maybe-function/c [in-contract contract/c] [out-contract contract/c]) + (or/c out-contract (in-contract . -> . out-contract))) -(defcontract pen-widths/c (or/c (listof (>=/c 0)) - ((listof real?) . -> . (listof (>=/c 0))))) +(defproc (maybe-apply [f (maybe-function/c any/c any/c)] + [arg any/c]) any/c + (cond [(procedure? f) (f arg)] + [else f])) -(defcontract plot-pen-styles/c (or/c (listof plot-pen-style/c) - ((listof real?) . -> . (listof plot-pen-style/c)))) +(defcontract (plot-colors/c [in-contract contract/c]) + (maybe-function/c in-contract (listof plot-color/c))) -(defcontract plot-brush-styles/c (or/c (listof plot-brush-style/c) - ((listof real?) . -> . (listof plot-brush-style/c)))) +(defcontract (pen-widths/c [in-contract contract/c]) + (maybe-function/c in-contract (listof (>=/c 0)))) -(defcontract alphas/c (or/c (listof (real-in 0 1)) - ((listof real?) . -> . (listof (real-in 0 1))))) +(defcontract (plot-pen-styles/c [in-contract contract/c]) + (maybe-function/c in-contract (listof plot-pen-style/c))) + +(defcontract (plot-brush-styles/c [in-contract contract/c]) + (maybe-function/c in-contract (listof plot-brush-style/c))) + +(defcontract (alphas/c [in-contract contract/c]) + (maybe-function/c in-contract (listof (real-in 0 1)))) + +(defcontract (labels/c [in-contract contract/c]) + (maybe-function/c in-contract (listof (or/c string? #f)))) diff --git a/collects/plot/common/draw.rkt b/collects/plot/common/draw.rkt index 33e98fc089..7a29ef0178 100644 --- a/collects/plot/common/draw.rkt +++ b/collects/plot/common/draw.rkt @@ -202,11 +202,6 @@ (defproc (alpha-expt [a (real-in 0 1)] [n (>/c 0)]) real? (- 1 (expt (- 1 a) n))) -(defproc (maybe-apply/list [list-or-proc (or/c (listof any/c) (any/c . -> . any/c))] - [xs (listof any/c)]) (listof any/c) - (cond [(procedure? list-or-proc) (list-or-proc xs)] - [else list-or-proc])) - ;; =================================================================================================== ;; Subdividing nonlinearly transformed shapes diff --git a/collects/plot/common/legend.rkt b/collects/plot/common/legend.rkt index 87ce334471..d28bf7c43a 100644 --- a/collects/plot/common/legend.rkt +++ b/collects/plot/common/legend.rkt @@ -28,14 +28,16 @@ (send pd draw-line (vector x-min y) (vector x-max y))))) (defproc (line-legend-entries [label string?] [zs (listof real?)] [z-labels (listof string?)] - [colors plot-colors/c] [widths pen-widths/c] [styles plot-pen-styles/c] + [colors (plot-colors/c (listof real?))] + [widths (pen-widths/c (listof real?))] + [styles (plot-pen-styles/c (listof real?))] ) (listof legend-entry?) (define hash (for/fold ([hash empty]) ([z (in-list zs)] [z-label (in-list z-labels)] - [color (in-cycle (maybe-apply/list colors zs))] - [width (in-cycle (maybe-apply/list widths zs))] - [style (in-cycle (maybe-apply/list styles zs))]) + [color (in-cycle (maybe-apply colors zs))] + [width (in-cycle (maybe-apply widths zs))] + [style (in-cycle (maybe-apply styles zs))]) (assoc-cons hash (list color width style) z-label))) (reverse @@ -50,46 +52,49 @@ ;; Rectangle legends (defproc (rectangle-legend-entry [label string?] - [fill-color plot-color/c] [fill-style plot-brush-style/c] + [color plot-color/c] [style plot-brush-style/c] [line-color plot-color/c] [line-width (>=/c 0)] [line-style plot-pen-style/c]) legend-entry? (legend-entry label (λ (pd rect) - (send pd set-brush fill-color fill-style) + (send pd set-brush color style) (send pd set-pen line-color line-width line-style) (send pd set-alpha 1) (send pd draw-rect rect)))) (defproc (rectangle-legend-entries [label string?] [zs (listof real?)] - [fill-colors plot-colors/c] [fill-styles plot-brush-styles/c] - [line-colors plot-colors/c] [line-widths pen-widths/c] - [line-styles plot-pen-styles/c]) (listof legend-entry?) + [colors (plot-colors/c (listof real?))] + [styles (plot-brush-styles/c (listof real?))] + [line-colors (plot-colors/c (listof real?))] + [line-widths (pen-widths/c (listof real?))] + [line-styles (plot-pen-styles/c (listof real?))] + ) (listof legend-entry?) (define z-min (first zs)) (define z-max (last zs)) (define digits (digits-for-range z-min z-max)) (define hash (for/fold ([hash empty]) ([z (in-list zs)] - [fill-color (in-cycle (maybe-apply/list fill-colors zs))] - [fill-style (in-cycle (maybe-apply/list fill-styles zs))] - [line-color (in-cycle (maybe-apply/list line-colors zs))] - [line-width (in-cycle (maybe-apply/list line-widths zs))] - [line-style (in-cycle (maybe-apply/list line-styles zs))]) + [color (in-cycle (maybe-apply colors zs))] + [style (in-cycle (maybe-apply styles zs))] + [line-color (in-cycle (maybe-apply line-colors zs))] + [line-width (in-cycle (maybe-apply line-widths zs))] + [line-style (in-cycle (maybe-apply line-styles zs))]) (define entry-label (real->plot-label z digits)) - (assoc-cons hash (list fill-color fill-style line-color line-width line-style) entry-label))) + (assoc-cons hash (list color style line-color line-width line-style) entry-label))) (reverse (for/list ([entry (in-list hash)]) - (match-define (cons (list fill-color fill-style line-color line-width line-style) vs) entry) + (match-define (cons (list color style line-color line-width line-style) vs) entry) (rectangle-legend-entry (if (= 1 (length vs)) (format "~a = ~a" label (first vs)) (format "~a ∈ {~a}" label (string-join (reverse vs) ","))) - fill-color fill-style line-color line-width line-style)))) + color style line-color line-width line-style)))) ;; =================================================================================================== ;; Interval legends (defproc (interval-legend-entry [label string?] - [fill-color plot-color/c] [fill-style plot-brush-style/c] + [color plot-color/c] [style plot-brush-style/c] [line-color plot-color/c] [line-width (>=/c 0)] [line-style plot-pen-style/c] [line1-color plot-color/c] [line1-width (>=/c 0)] [line1-style plot-pen-style/c] [line2-color plot-color/c] [line2-width (>=/c 0)] [line2-style plot-pen-style/c] @@ -99,7 +104,7 @@ (send pd set-alpha 1) ;; rectangle (send pd set-pen line-color line-width line-style) - (send pd set-brush fill-color fill-style) + (send pd set-brush color style) (send pd draw-rect rect) ;; bottom line (send pd set-pen line1-color line1-width line1-style) @@ -108,69 +113,50 @@ (send pd set-pen line2-color line2-width line2-style) (send pd draw-line (vector x-min y-min) (vector x-max y-min))))) -(defproc (interval-legend-entries - [label string?] [zs (listof real?)] [z-labels (listof string?)] - [fill-colors plot-colors/c] [fill-styles plot-brush-styles/c] - [line-colors plot-colors/c] [line-widths pen-widths/c] [line-styles plot-pen-styles/c] - [line1-colors plot-colors/c] [line1-widths pen-widths/c] [line1-styles plot-pen-styles/c] - [line2-colors plot-colors/c] [line2-widths pen-widths/c] [line2-styles plot-pen-styles/c] - ) (listof legend-entry?) +(defproc (interval-legend-entries [label string?] [ivls (listof ivl?)] [ivl-labels (listof string?)] + [colors (plot-colors/c (listof ivl?))] + [styles (plot-brush-styles/c (listof ivl?))] + [line-colors (plot-colors/c (listof ivl?))] + [line-widths (pen-widths/c (listof ivl?))] + [line-styles (plot-pen-styles/c (listof ivl?))] + [line1-colors (plot-colors/c (listof ivl?))] + [line1-widths (pen-widths/c (listof ivl?))] + [line1-styles (plot-pen-styles/c (listof ivl?))] + [line2-colors (plot-colors/c (listof ivl?))] + [line2-widths (pen-widths/c (listof ivl?))] + [line2-styles (plot-pen-styles/c (listof ivl?))] + ) (listof legend-entry?) (define hash - (for/fold ([hash empty]) ([za (in-list zs)] - [zb (in-list (rest zs))] - [la (in-list z-labels)] - [lb (in-list (rest z-labels))] - [fill-color (in-cycle (maybe-apply/list fill-colors zs))] - [fill-style (in-cycle (maybe-apply/list fill-styles zs))] - [line-color (in-cycle (maybe-apply/list line-colors zs))] - [line-width (in-cycle (maybe-apply/list line-widths zs))] - [line-style (in-cycle (maybe-apply/list line-styles zs))] - [line1-color (in-cycle (maybe-apply/list line1-colors zs))] - [line1-width (in-cycle (maybe-apply/list line1-widths zs))] - [line1-style (in-cycle (maybe-apply/list line1-styles zs))] - [line2-color (in-cycle (maybe-apply/list line2-colors zs))] - [line2-width (in-cycle (maybe-apply/list line2-widths zs))] - [line2-style (in-cycle (maybe-apply/list line2-styles zs))]) - (define entry-label (format "[~a,~a]" la lb)) + (for/fold ([hash empty]) ([ivl-label (in-list ivl-labels)] + [color (in-cycle (maybe-apply colors ivls))] + [style (in-cycle (maybe-apply styles ivls))] + [line-color (in-cycle (maybe-apply line-colors ivls))] + [line-width (in-cycle (maybe-apply line-widths ivls))] + [line-style (in-cycle (maybe-apply line-styles ivls))] + [line1-color (in-cycle (maybe-apply line1-colors ivls))] + [line1-width (in-cycle (maybe-apply line1-widths ivls))] + [line1-style (in-cycle (maybe-apply line1-styles ivls))] + [line2-color (in-cycle (maybe-apply line2-colors ivls))] + [line2-width (in-cycle (maybe-apply line2-widths ivls))] + [line2-style (in-cycle (maybe-apply line2-styles ivls))]) (assoc-cons hash - (list fill-color fill-style line-color line-width line-style + (list color style line-color line-width line-style line1-color line1-width line1-style line2-color line2-width line2-style) - entry-label))) + ivl-label))) (reverse (for/list ([entry (in-list hash)]) - (match-define (cons (list fill-color fill-style line-color line-width line-style + (match-define (cons (list color style line-color line-width line-style line1-color line1-width line1-style line2-color line2-width line2-style) - vs) + ivl-labels) entry) - (interval-legend-entry (format "~a ∈ ~a" label (string-join (reverse vs) " ∪ ")) - fill-color fill-style line-color line-width line-style + (interval-legend-entry (format "~a ∈ ~a" label (string-join (reverse ivl-labels) " ∪ ")) + color style line-color line-width line-style line1-color line1-width line1-style line2-color line2-width line2-style)))) -(defproc (contour-intervals-legend-entries - [label string?] [zs (listof real?)] [z-labels (listof string?)] - [fill-colors plot-colors/c] [fill-styles plot-brush-styles/c] - [line-colors plot-colors/c] [line-widths pen-widths/c] [line-styles plot-pen-styles/c] - [contour-colors plot-colors/c] [contour-widths pen-widths/c] - [contour-styles plot-pen-styles/c]) (listof legend-entry?) - (define n (- (length zs) 2)) - (define ccs (append (list 0) - (sequence-take (in-cycle (maybe-apply/list contour-colors zs)) 0 n) - (list 0))) - (define cws (append (list 0) - (sequence-take (in-cycle (maybe-apply/list contour-widths zs)) 0 n) - (list 0))) - (define css (append '(transparent) - (sequence-take (in-cycle (maybe-apply/list contour-styles zs)) 0 n) - '(transparent))) - - (interval-legend-entries label zs z-labels - fill-colors fill-styles line-colors line-widths line-styles - ccs cws css (rest ccs) (rest cws) (rest css))) - ;; =================================================================================================== ;; Point legends diff --git a/collects/plot/common/parameters.rkt b/collects/plot/common/parameters.rkt index b60a6bd899..3fadefdb45 100644 --- a/collects/plot/common/parameters.rkt +++ b/collects/plot/common/parameters.rkt @@ -7,7 +7,8 @@ "contract-doc.rkt" "draw.rkt" "axis-transform.rkt" - "ticks.rkt") + "ticks.rkt" + "math.rkt") (provide (all-defined-out)) @@ -78,7 +79,7 @@ plot-animating?)) (defproc (pen-gap) real? #:document-body - (* 2 (plot-line-width))) + (max 1 (* 2 (plot-line-width)))) (defproc (animated-samples [samples (and/c exact-integer? (>=/c 2))] ) (and/c exact-integer? (>=/c 2)) #:document-body @@ -222,6 +223,7 @@ (defparam vector-field-line-style plot-pen-style/c 'solid) (defparam vector-field-scale (or/c real? (one-of/c 'auto 'normalized)) 'auto) (defparam vector-field-alpha (real-in 0 1) 1) +(defparam vector-field3d-samples exact-positive-integer? 9) ;; Error bars @@ -237,22 +239,22 @@ (color-seq* (list (->pen-color 5) (->pen-color 0) (->pen-color 1)) (length zs))) -(defproc (default-contour-fill-colors [zs (listof real?)]) (listof plot-color/c) #:document-body +(defproc (default-contour-fill-colors [z-ivls (listof ivl?)]) (listof plot-color/c) #:document-body (color-seq* (list (->brush-color 5) (->brush-color 0) (->brush-color 1)) - (sub1 (length zs)))) + (length z-ivls))) (defparam contour-samples (and/c exact-integer? (>=/c 2)) 51) (defparam contour-levels (or/c 'auto exact-positive-integer? (listof real?)) 'auto) -(defparam contour-colors plot-colors/c default-contour-colors) -(defparam contour-widths pen-widths/c '(1)) -(defparam contour-styles plot-pen-styles/c '(solid long-dash)) -(defparam contour-alphas alphas/c '(1)) +(defparam contour-colors (plot-colors/c (listof real?)) default-contour-colors) +(defparam contour-widths (pen-widths/c (listof real?)) '(1)) +(defparam contour-styles (plot-pen-styles/c (listof real?)) '(solid long-dash)) +(defparam contour-alphas (alphas/c (listof real?)) '(1)) -(defparam contour-interval-colors plot-colors/c default-contour-fill-colors) -(defparam contour-interval-styles plot-brush-styles/c '(solid)) -(defparam contour-interval-alphas alphas/c '(1)) +(defparam contour-interval-colors (plot-colors/c (listof ivl?)) default-contour-fill-colors) +(defparam contour-interval-styles (plot-brush-styles/c (listof ivl?)) '(solid)) +(defparam contour-interval-alphas (alphas/c (listof ivl?)) '(1)) -;; Histograms +;; Rectangles (defparam rectangle-color plot-color/c 3) (defparam rectangle-style plot-brush-style/c 'solid) @@ -260,7 +262,17 @@ (defparam rectangle-line-width (>=/c 0) 1) (defparam rectangle-line-style plot-pen-style/c 'solid) (defparam rectangle-alpha (real-in 0 1) 1) +(defparam rectangle3d-line-width (>=/c 0) 1/3) + (defparam discrete-histogram-gap (real-in 0 1) 1/8) +(defparam discrete-histogram-skip (>=/c 0) 1) + +(defparam stacked-histogram-colors (plot-colors/c nat/c) (λ (n) (build-list n add1))) +(defparam stacked-histogram-styles (plot-brush-styles/c nat/c) '(solid)) +(defparam stacked-histogram-line-colors (plot-colors/c nat/c) (stacked-histogram-colors)) +(defparam stacked-histogram-line-widths (pen-widths/c nat/c) '(1)) +(defparam stacked-histogram-line-styles (plot-pen-styles/c nat/c) '(solid)) +(defparam stacked-histogram-alphas (alphas/c nat/c) '(1)) ;; Decorations @@ -301,9 +313,9 @@ ;; Contour surfaces -(defparam contour-interval-line-colors plot-colors/c '(0)) -(defparam contour-interval-line-widths pen-widths/c '(1/3)) -(defparam contour-interval-line-styles plot-pen-styles/c '(solid)) +(defparam contour-interval-line-colors (plot-colors/c (listof ivl?)) '(0)) +(defparam contour-interval-line-widths (pen-widths/c (listof ivl?)) '(1/3)) +(defparam contour-interval-line-styles (plot-pen-styles/c (listof ivl?)) '(solid)) ;; Isosurfaces @@ -316,12 +328,9 @@ (length zs))) (defparam isosurface-levels (or/c 'auto exact-positive-integer? (listof real?)) 'auto) -(defparam isosurface-colors plot-colors/c default-isosurface-colors) -(defparam isosurface-line-colors plot-colors/c default-isosurface-line-colors) -(defparam isosurface-line-widths pen-widths/c '(1/3)) -(defparam isosurface-line-styles plot-pen-styles/c '(solid)) -(defparam isosurface-alphas alphas/c '(1/2)) - -;; Histograms - -(defparam rectangle3d-line-width (>=/c 0) 1/3) +(defparam isosurface-colors (plot-colors/c (listof real?)) default-isosurface-colors) +(defparam isosurface-styles (plot-brush-styles/c (listof real?)) '(solid)) +(defparam isosurface-line-colors (plot-colors/c (listof real?)) default-isosurface-line-colors) +(defparam isosurface-line-widths (pen-widths/c (listof real?)) '(1/3)) +(defparam isosurface-line-styles (plot-pen-styles/c (listof real?)) '(solid)) +(defparam isosurface-alphas (alphas/c (listof real?)) '(1/2)) diff --git a/collects/plot/common/ticks.rkt b/collects/plot/common/ticks.rkt index 04c55b61b4..0b23ac2e4b 100644 --- a/collects/plot/common/ticks.rkt +++ b/collects/plot/common/ticks.rkt @@ -624,21 +624,28 @@ ;; =================================================================================================== ;; Tick utils -(defproc (collapse-nearby-ticks [ts (listof tick?)] - [near? (tick? tick? . -> . boolean?)] - [format-string string? "~a|~a"]) (listof tick?) - (let* ([ts (sort ts < #:key pre-tick-value)]) +(define (same-label? t1 t2) (string=? (tick-label t1) (tick-label t2))) + +(define (collapse-equiv-ticks ts near-format-string) + (match-define (list (tick xs majors labels) ...) ts) + (define x (/ (apply + xs) (length ts))) + (define major? (ormap values majors)) + (define label1 (first labels)) + (define label2 (last labels)) + (define label + (cond [(string=? label1 label2) label1] + [else (format near-format-string label1 label2)])) + (tick x major? label)) + +(defproc (collapse-ticks [ts (listof tick?)] [near? (tick? tick? . -> . boolean?)] + [near-format-string string? "~a|~a"]) (listof tick?) + (let ([ts (sort ts < #:key pre-tick-value)]) (append* - (for/list ([ts (in-list (group-neighbors ts near?))]) + (for/list ([ts (in-list (group-neighbors + ts (λ (t1 t2) (or (same-label? t1 t2) (near? t1 t2)))))]) (define n (length ts)) (define m (count pre-tick-major? ts)) (cond [(n . <= . 1) ts] - [(m . = . 0) (match-define (list (tick xs _ labels) ...) ts) - (define x (/ (apply + xs) n)) - (define label (format format-string (first labels) (last labels))) - (list (tick x #f label))] + [(m . = . 0) (list (collapse-equiv-ticks ts near-format-string))] [(m . = . 1) (filter pre-tick-major? ts)] - [else (match-define (list (tick xs _ labels) ...) (filter pre-tick-major? ts)) - (define x (/ (apply + xs) m)) - (define label (format format-string (first labels) (last labels))) - (list (tick x #t label))]))))) + [else (list (collapse-equiv-ticks (filter pre-tick-major? ts) near-format-string))]))))) diff --git a/collects/plot/common/utils.rkt b/collects/plot/common/utils.rkt index 0d275f966d..6689101f31 100644 --- a/collects/plot/common/utils.rkt +++ b/collects/plot/common/utils.rkt @@ -1,6 +1,6 @@ #lang racket/base -;; Extra functions that can't be easily categorized (i.e. math, vector). +;; Extra functions that can't be easily categorized (require racket/sequence racket/list racket/math racket/flonum racket/match) @@ -44,8 +44,10 @@ (make-hash (map cons sorted-lst (f sorted-lst))))) (map (λ (e) (hash-ref h e)) lst)) -(define (transpose lsts) - (apply map list lsts)) +(define (transpose xss) + (cond [(andmap empty? xss) empty] + [else (cons (map (λ (xs) (if (empty? xs) #f (first xs))) xss) + (transpose (map (λ (xs) (if (empty? xs) empty (rest xs))) xss)))])) (define (group-neighbors lst equiv?) (reverse diff --git a/collects/plot/contracted/draw.rkt b/collects/plot/contracted/draw.rkt index 8d7e11610a..e7e1474f97 100644 --- a/collects/plot/contracted/draw.rkt +++ b/collects/plot/contracted/draw.rkt @@ -5,5 +5,4 @@ (require "../common/draw.rkt") (provide (activate-contract-out ->color ->pen-color ->brush-color ->pen-style ->brush-style color-seq color-seq* - alpha-expt - maybe-apply/list)) + alpha-expt)) diff --git a/collects/plot/contracted/legend.rkt b/collects/plot/contracted/legend.rkt index 5ca7f2d6d3..e05756a660 100644 --- a/collects/plot/contracted/legend.rkt +++ b/collects/plot/contracted/legend.rkt @@ -12,6 +12,5 @@ line-legend-entry line-legend-entries rectangle-legend-entry rectangle-legend-entries interval-legend-entry interval-legend-entries - contour-intervals-legend-entries point-legend-entry vector-field-legend-entry)) diff --git a/collects/plot/contracted/parameters.rkt b/collects/plot/contracted/parameters.rkt index b33a1b911f..03a99b61b3 100644 --- a/collects/plot/contracted/parameters.rkt +++ b/collects/plot/contracted/parameters.rkt @@ -41,14 +41,19 @@ vector-field-color vector-field-line-width vector-field-line-style vector-field-scale vector-field-alpha + vector-field3d-samples error-bar-width error-bar-color error-bar-line-width error-bar-line-style error-bar-alpha contour-samples contour-levels contour-colors contour-widths contour-styles contour-alphas contour-interval-colors contour-interval-styles contour-interval-alphas rectangle-color rectangle-style rectangle-line-color rectangle-line-width rectangle-line-style rectangle-alpha - discrete-histogram-gap rectangle3d-line-width + discrete-histogram-gap + discrete-histogram-skip + stacked-histogram-colors stacked-histogram-styles + stacked-histogram-line-colors stacked-histogram-line-widths stacked-histogram-line-styles + stacked-histogram-alphas x-axis-ticks? y-axis-ticks? z-axis-ticks? x-axis-labels? y-axis-labels? z-axis-labels? x-axis-far? y-axis-far? z-axis-far? @@ -58,7 +63,8 @@ surface-color surface-style surface-line-color surface-line-width surface-line-style surface-alpha contour-interval-line-colors contour-interval-line-widths contour-interval-line-styles isosurface-levels - isosurface-colors isosurface-line-colors isosurface-line-widths isosurface-line-styles + isosurface-colors isosurface-styles + isosurface-line-colors isosurface-line-widths isosurface-line-styles isosurface-alphas ;; Functions pen-gap diff --git a/collects/plot/contracted/ticks.rkt b/collects/plot/contracted/ticks.rkt index 32bacc64d6..5dab593683 100644 --- a/collects/plot/contracted/ticks.rkt +++ b/collects/plot/contracted/ticks.rkt @@ -22,4 +22,4 @@ currency-ticks-scales currency-ticks-formats currency-ticks-layout currency-ticks-format currency-ticks fraction-ticks-format fraction-ticks - collapse-nearby-ticks)) + collapse-ticks)) diff --git a/collects/plot/deprecated/renderers.rkt b/collects/plot/deprecated/renderers.rkt index 1e6ffff87e..c81c46825b 100644 --- a/collects/plot/deprecated/renderers.rkt +++ b/collects/plot/deprecated/renderers.rkt @@ -30,7 +30,7 @@ #:samples samples #:width width #:color color)])])) (define (contour-renderer f samples width color levels) - (isolines f #:samples samples #:levels (if (exact-integer? levels) (sub1 levels) levels) + (contours f #:samples samples #:levels (if (exact-integer? levels) (sub1 levels) levels) #:colors (list color) #:widths (list width) #:styles '(solid))) (define (shade-fill-colors zs) diff --git a/collects/plot/main.rkt b/collects/plot/main.rkt index 5899fce7f2..4243383a5c 100644 --- a/collects/plot/main.rkt +++ b/collects/plot/main.rkt @@ -44,11 +44,10 @@ lines-interval parametric-interval polar-interval function-interval inverse-interval)) (require "plot2d/contour.rkt") -(provide (activate-contract-out contours contour-intervals - isoline isolines isoline-intervals)) +(provide (activate-contract-out isoline contours contour-intervals)) (require "plot2d/rectangle.rkt") -(provide (activate-contract-out rectangles area-histogram discrete-histogram)) +(provide (activate-contract-out rectangles area-histogram discrete-histogram stacked-histogram)) (require "plot2d/decoration.rkt") (provide (activate-contract-out @@ -70,14 +69,13 @@ (provide (activate-contract-out surface3d)) (require "plot3d/contour.rkt") -(provide (activate-contract-out contour3d contours3d contour-intervals3d - isoline3d isolines3d isoline-intervals3d)) +(provide (activate-contract-out isoline3d contours3d contour-intervals3d)) (require "plot3d/line.rkt") (provide (activate-contract-out lines3d parametric3d)) (require "plot3d/point.rkt") -(provide (activate-contract-out points3d)) +(provide (activate-contract-out points3d vector-field3d)) (require "plot3d/isosurface.rkt") (provide (activate-contract-out isosurface3d isosurfaces3d polar3d)) diff --git a/collects/plot/plot2d/contour.rkt b/collects/plot/plot2d/contour.rkt index 7ff7c8db6c..b7bf04dbf4 100644 --- a/collects/plot/plot2d/contour.rkt +++ b/collects/plot/plot2d/contour.rkt @@ -4,11 +4,10 @@ (require racket/contract racket/class racket/match racket/list racket/flonum racket/vector racket/math plot/utils - "../common/contract-doc.rkt") + "../common/contract-doc.rkt" + "../common/utils.rkt") -(provide (all-defined-out) - (rename-out [contours isolines] - [contour-intervals isoline-intervals])) +(provide (all-defined-out)) ;; =================================================================================================== ;; One contour line @@ -66,35 +65,34 @@ (match-define (list (tick zs _ labels) ...) (contour-ticks z-min z-max levels #f)) - (define cs (maybe-apply/list colors zs)) - (define ws (maybe-apply/list widths zs)) - (define ss (maybe-apply/list styles zs)) - (define as (maybe-apply/list alphas zs)) - - (for ([z (in-list zs)] - [color (in-cycle cs)] - [width (in-cycle ws)] - [style (in-cycle ss)] - [alpha (in-cycle as)]) - (send area put-alpha alpha) - (send area put-pen color width style) - (for ([ya (in-list ys)] - [yb (in-list (rest ys))] - [zs0 (in-vector zss)] - [zs1 (in-vector zss 1)] - #:when #t - [xa (in-list xs)] - [xb (in-list (rest xs))] - [z1 (in-vector zs0)] - [z2 (in-vector zs0 1)] - [z3 (in-vector zs1 1)] - [z4 (in-vector zs1)]) - (for/list ([line (in-list (heights->lines xa xb ya yb z z1 z2 z3 z4))]) - (match-define (list v1 v2) (map (λ (v) (vector-take v 2)) line)) - (send area put-line v1 v2)))) - - (cond [label (line-legend-entries label zs labels colors widths styles)] - [else empty]))) + (let ([colors (maybe-apply colors zs)] + [widths (maybe-apply widths zs)] + [styles (maybe-apply styles zs)] + [alphas (maybe-apply alphas zs)]) + (for ([z (in-list zs)] + [color (in-cycle colors)] + [width (in-cycle widths)] + [style (in-cycle styles)] + [alpha (in-cycle alphas)]) + (send area put-alpha alpha) + (send area put-pen color width style) + (for ([ya (in-list ys)] + [yb (in-list (rest ys))] + [zs0 (in-vector zss)] + [zs1 (in-vector zss 1)] + #:when #t + [xa (in-list xs)] + [xb (in-list (rest xs))] + [z1 (in-vector zs0)] + [z2 (in-vector zs0 1)] + [z3 (in-vector zs1 1)] + [z4 (in-vector zs1)]) + (for/list ([line (in-list (heights->lines xa xb ya yb z z1 z2 z3 z4))]) + (match-define (list v1 v2) (map (λ (v) (vector-take v 2)) line)) + (send area put-line v1 v2)))) + + (cond [label (line-legend-entries label zs labels colors widths styles)] + [else empty])))) (defproc (contours [f (real? real? . -> . real?)] @@ -102,12 +100,12 @@ [x-max (or/c regular-real? #f) #f] [y-min (or/c regular-real? #f) #f] [y-max (or/c regular-real? #f) #f] - [#:levels levels (or/c 'auto exact-positive-integer? (listof real?)) (contour-levels)] [#:samples samples (and/c exact-integer? (>=/c 2)) (contour-samples)] - [#:colors colors plot-colors/c (contour-colors)] - [#:widths widths pen-widths/c (contour-widths)] - [#:styles styles plot-pen-styles/c (contour-styles)] - [#:alphas alphas alphas/c (contour-alphas)] + [#:levels levels (or/c 'auto exact-positive-integer? (listof real?)) (contour-levels)] + [#:colors colors (plot-colors/c (listof real?)) (contour-colors)] + [#:widths widths (pen-widths/c (listof real?)) (contour-widths)] + [#:styles styles (plot-pen-styles/c (listof real?)) (contour-styles)] + [#:alphas alphas (alphas/c (listof real?)) (contour-alphas)] [#:label label (or/c string? #f) #f] ) renderer2d? (define g (2d-function->sampler f)) @@ -127,60 +125,79 @@ (match-define (list (tick zs _ labels) ...) (contour-ticks z-min z-max levels #t)) - (define cs (map ->brush-color (maybe-apply/list colors zs))) - (define fss (map ->brush-style (maybe-apply/list styles zs))) - (define pss (map (λ (fill-style) (if (eq? fill-style 'solid) 'solid 'transparent)) fss)) - (define as (maybe-apply/list alphas zs)) + (define-values (z-ivls ivl-labels) + (for/lists (z-ivls ivl-labels) ([za (in-list zs)] + [zb (in-list (rest zs))] + [la (in-list labels)] + [lb (in-list (rest labels))]) + (values (ivl za zb) (format "[~a,~a]" la lb)))) - (for ([za (in-list zs)] - [zb (in-list (rest zs))] - [color (in-cycle cs)] - [fill-style (in-cycle fss)] - [poly-line-style (in-cycle pss)] - [alpha (in-cycle as)]) - (define polys - (append* - (for/list ([ya (in-list ys)] - [yb (in-list (rest ys))] - [zs0 (in-vector zss)] - [zs1 (in-vector zss 1)] - #:when #t - [xa (in-list xs)] - [xb (in-list (rest xs))] - [z1 (in-vector zs0)] - [z2 (in-vector zs0 1)] - [z3 (in-vector zs1 1)] - [z4 (in-vector zs1)]) - (for/list ([poly (in-list (heights->polys xa xb ya yb za zb z1 z2 z3 z4))]) - (map (λ (v) (vector-take v 2)) poly))))) + (let ([colors (map ->brush-color (maybe-apply colors z-ivls))] + [styles (map ->brush-style (maybe-apply styles z-ivls))] + [alphas (maybe-apply alphas z-ivls)]) + (define line-styles (map (λ (style) (if (eq? style 'solid) 'solid 'transparent)) styles)) - (define (draw-polys) - (for ([poly (in-list polys)]) - (send area put-polygon poly))) + (for ([za (in-list zs)] + [zb (in-list (rest zs))] + [color (in-cycle colors)] + [style (in-cycle styles)] + [alpha (in-cycle alphas)] + [line-style (in-cycle line-styles)]) + (define polys + (append* + (for/list ([ya (in-list ys)] + [yb (in-list (rest ys))] + [zs0 (in-vector zss)] + [zs1 (in-vector zss 1)] + #:when #t + [xa (in-list xs)] + [xb (in-list (rest xs))] + [z1 (in-vector zs0)] + [z2 (in-vector zs0 1)] + [z3 (in-vector zs1 1)] + [z4 (in-vector zs1)]) + (for/list ([poly (in-list (heights->polys xa xb ya yb za zb z1 z2 z3 z4))]) + (map (λ (v) (vector-take v 2)) poly))))) + + (define (draw-polys) + (for ([poly (in-list polys)]) + (send area put-polygon poly))) + + (cond [(= alpha 1) + (send area put-pen color 1 line-style) + (send area put-brush color style) + (send area put-alpha 1) + (draw-polys)] + [else + ;; draw the outlines with reduced alpha first + (send area put-pen color 1 line-style) + (send area put-brush color 'transparent) + (send area put-alpha (alpha-expt alpha 1/8)) + (draw-polys) + ;; now draw the centers + (send area put-pen color 1 'transparent) + (send area put-brush color style) + (send area put-alpha alpha) + (draw-polys)])) - (cond [(= alpha 1) - (send area put-pen color 1 poly-line-style) - (send area put-brush color fill-style) - (send area put-alpha 1) - (draw-polys)] - [else - ;; draw the outlines with reduced alpha first - (send area put-pen color 1 poly-line-style) - (send area put-brush color 'transparent) - (send area put-alpha (alpha-expt alpha 1/8)) - (draw-polys) - ;; now draw the centers - (send area put-pen color 1 'transparent) - (send area put-brush color fill-style) - (send area put-alpha alpha) - (draw-polys)])) - - ((contours-render-proc g levels samples contour-colors contour-widths contour-styles alphas #f) - area) - - (cond [label (contour-intervals-legend-entries - label zs labels cs fss cs '(1) pss contour-colors contour-widths contour-styles)] - [else empty]))) + ((contours-render-proc g levels samples contour-colors contour-widths contour-styles alphas #f) + area) + + (define n (- (length zs) 2)) + (define contour-colors* + (append (list 0) (sequence-take (in-cycle (maybe-apply contour-colors zs)) 0 n) (list 0))) + (define contour-widths* + (append (list 0) (sequence-take (in-cycle (maybe-apply contour-widths zs)) 0 n) (list 0))) + (define contour-styles* + (append '(transparent) (sequence-take (in-cycle (maybe-apply contour-styles zs)) 0 n) + '(transparent))) + + (cond [label (interval-legend-entries + label z-ivls ivl-labels + colors styles colors '(1) line-styles + contour-colors* contour-widths* contour-styles* + (rest contour-colors*) (rest contour-widths*) (rest contour-styles*))] + [else empty])))) (defproc (contour-intervals [f (real? real? . -> . real?)] @@ -188,14 +205,14 @@ [x-max (or/c regular-real? #f) #f] [y-min (or/c regular-real? #f) #f] [y-max (or/c regular-real? #f) #f] - [#:levels levels (or/c 'auto exact-positive-integer? (listof real?)) (contour-levels)] [#:samples samples (and/c exact-integer? (>=/c 2)) (contour-samples)] - [#:colors colors plot-colors/c (contour-interval-colors)] - [#:styles styles plot-brush-styles/c (contour-interval-styles)] - [#:contour-colors contour-colors plot-colors/c (contour-colors)] - [#:contour-widths contour-widths pen-widths/c (contour-widths)] - [#:contour-styles contour-styles plot-pen-styles/c (contour-styles)] - [#:alphas alphas alphas/c (contour-interval-alphas)] + [#:levels levels (or/c 'auto exact-positive-integer? (listof real?)) (contour-levels)] + [#:colors colors (plot-colors/c (listof ivl?)) (contour-interval-colors)] + [#:styles styles (plot-brush-styles/c (listof ivl?)) (contour-interval-styles)] + [#:contour-colors contour-colors (plot-colors/c (listof real?)) (contour-colors)] + [#:contour-widths contour-widths (pen-widths/c (listof real?)) (contour-widths)] + [#:contour-styles contour-styles (plot-pen-styles/c (listof real?)) (contour-styles)] + [#:alphas alphas (alphas/c (listof ivl?)) (contour-interval-alphas)] [#:label label (or/c string? #f) #f] ) renderer2d? (define g (2d-function->sampler f)) diff --git a/collects/plot/plot2d/plot-area.rkt b/collects/plot/plot2d/plot-area.rkt index bf3a4da33b..8955ce9f2c 100644 --- a/collects/plot/plot2d/plot-area.rkt +++ b/collects/plot/plot2d/plot-area.rkt @@ -140,17 +140,17 @@ (vector x (pre-tick-value t2)))) (define x-ticks - (collapse-nearby-ticks (filter (λ (t) (<= x-min (pre-tick-value t) x-max)) rx-ticks) - (x-tick-near? y-min))) + (collapse-ticks (filter (λ (t) (<= x-min (pre-tick-value t) x-max)) rx-ticks) + (x-tick-near? y-min))) (define x-far-ticks - (collapse-nearby-ticks (filter (λ (t) (<= x-min (pre-tick-value t) x-max)) rx-far-ticks) - (x-tick-near? y-max))) + (collapse-ticks (filter (λ (t) (<= x-min (pre-tick-value t) x-max)) rx-far-ticks) + (x-tick-near? y-max))) (define y-ticks - (collapse-nearby-ticks (filter (λ (t) (<= y-min (pre-tick-value t) y-max)) ry-ticks) - (y-tick-near? x-min))) + (collapse-ticks (filter (λ (t) (<= y-min (pre-tick-value t) y-max)) ry-ticks) + (y-tick-near? x-min))) (define y-far-ticks - (collapse-nearby-ticks (filter (λ (t) (<= y-min (pre-tick-value t) y-max)) ry-far-ticks) - (y-tick-near? x-max))) + (collapse-ticks (filter (λ (t) (<= y-min (pre-tick-value t) y-max)) ry-far-ticks) + (y-tick-near? x-max))) ;; =============================================================================================== ;; Tick and label parameters, and fixpoint margin computation @@ -345,7 +345,7 @@ (define (draw-labels) (for ([params (in-list (get-all-label-params))]) - (send/apply pd draw-text params))) + (send/apply pd draw-text params #:outline? #t))) ;; =============================================================================================== ;; Public drawing control (used by plot/dc) diff --git a/collects/plot/plot2d/rectangle.rkt b/collects/plot/plot2d/rectangle.rkt index 4f8566b84f..c1e299a229 100644 --- a/collects/plot/plot2d/rectangle.rkt +++ b/collects/plot/plot2d/rectangle.rkt @@ -103,12 +103,13 @@ (default-y-ticks y-min y-max) (default-y-far-ticks y-min y-max))) (defproc (discrete-histogram - [cat-vals (listof (vector/c any/c real?))] + [cat-vals (listof (vector/c any/c (or/c real? ivl? #f)))] [#:x-min x-min (or/c regular-real? #f) 0] [#:x-max x-max (or/c regular-real? #f) #f] [#:y-min y-min (or/c regular-real? #f) 0] [#:y-max y-max (or/c regular-real? #f) #f] [#:gap gap (real-in 0 1) (discrete-histogram-gap)] + [#:skip skip (>=/c 0) (discrete-histogram-skip)] [#:color color plot-color/c (rectangle-color)] [#:style style plot-brush-style/c (rectangle-style)] [#:line-color line-color plot-color/c (rectangle-line-color)] @@ -119,22 +120,64 @@ [#:far-ticks? far-ticks? boolean? #f] ) renderer2d? (match-define (list (vector cats ys) ...) cat-vals) - (define rys (filter regular-real? ys)) + (define rys (filter regular-real? (append* (for/list ([y (in-list ys)]) + (match y + [(ivl y1 y2) (list y1 y2)] + [_ (list y)]))))) (cond [(empty? rys) (renderer2d #f #f #f #f)] [else (define n (length cats)) (let* ([x-min (if x-min x-min 0)] - [x-max (if x-max x-max (+ x-min n))] + [x-max (if x-max x-max (+ x-min (* n skip)))] [y-min (if y-min y-min (apply min* rys))] [y-max (if y-max y-max (apply max* rys))]) (define xs (linear-seq x-min x-max (add1 n))) (define x-ivls (for/list ([x1 (in-list xs)] [x2 (in-list (rest xs))]) - (define 1/2-gap-size (* 1/2 gap (- x2 x1))) + (define 1/2-gap-size (+ (* 1/2 (- skip 1)) (* 1/2 gap (- x2 x1)))) (ivl (+ x1 1/2-gap-size) (- x2 1/2-gap-size)))) (define tick-xs (linear-seq x-min x-max n #:start? #f #:end? #f)) (renderer2d (vector (ivl x-min x-max) (ivl y-min y-max)) #f (discrete-histogram-ticks-fun cats tick-xs far-ticks?) - (rectangles-render-proc (map (λ (x-ivl y) (vector x-ivl (ivl 0 y))) x-ivls ys) + (rectangles-render-proc (map (λ (x-ivl y) (vector x-ivl (if (ivl? y) y (ivl 0 y)))) x-ivls ys) color style line-color line-width line-style alpha label)))])) + +(defproc (stacked-histogram + [cat-vals (listof (vector/c any/c (listof real?)))] + [#:x-min x-min (or/c regular-real? #f) 0] + [#:x-max x-max (or/c regular-real? #f) #f] + [#:y-min y-min (or/c regular-real? #f) 0] + [#:y-max y-max (or/c regular-real? #f) #f] + [#:gap gap (real-in 0 1) (discrete-histogram-gap)] + [#:skip skip (>=/c 0) (discrete-histogram-skip)] + [#:colors colors (plot-colors/c nat/c) (stacked-histogram-colors)] + [#:styles styles (plot-brush-styles/c nat/c) (stacked-histogram-styles)] + [#:line-colors line-colors (plot-colors/c nat/c) (stacked-histogram-line-colors)] + [#:line-widths line-widths (pen-widths/c nat/c) (stacked-histogram-line-widths)] + [#:line-styles line-styles (plot-pen-styles/c nat/c) (stacked-histogram-line-styles)] + [#:alphas alphas (alphas/c nat/c) (stacked-histogram-alphas)] + [#:labels labels (labels/c nat/c) '(#f)] + [#:far-ticks? far-ticks? boolean? #f] + ) (listof renderer2d?) + (match-define (list (vector cats ys) ...) cat-vals) + (define yss + (for/list ([y (in-list ys)]) + (reverse (foldl (λ (x xs) (cons (+ x (first xs)) xs)) '(0) y)))) + (define y-ivlss (for/list ([ys (in-list yss)]) + (for/list ([y1 (in-list ys)] [y2 (in-list (rest ys))]) + (ivl y1 y2)))) + (define max-num (apply max (map length yss))) + (for/list ([y-ivls (in-list (transpose y-ivlss))] + [color (in-cycle (maybe-apply colors max-num))] + [style (in-cycle (maybe-apply styles max-num))] + [line-color (in-cycle (maybe-apply line-colors max-num))] + [line-width (in-cycle (maybe-apply line-widths max-num))] + [line-style (in-cycle (maybe-apply line-styles max-num))] + [alpha (in-cycle (maybe-apply alphas max-num))] + [label (in-cycle (maybe-apply labels max-num))]) + (discrete-histogram (for/list ([cat (in-list cats)] [y-ivl (in-list y-ivls)]) + (vector cat y-ivl)) + #:x-min x-min #:x-max x-max #:y-min y-min #:gap gap #:skip skip + #:color color #:style style #:line-color line-color #:line-width line-width + #:line-style line-style #:alpha alpha #:label label #:far-ticks? far-ticks?))) diff --git a/collects/plot/plot3d/contour.rkt b/collects/plot/plot3d/contour.rkt index fd59b2227b..9e5a7dafb6 100644 --- a/collects/plot/plot3d/contour.rkt +++ b/collects/plot/plot3d/contour.rkt @@ -2,17 +2,15 @@ (require racket/class racket/match racket/list racket/flonum racket/contract plot/utils - "../common/contract-doc.rkt") + "../common/contract-doc.rkt" + "../common/utils.rkt") -(provide (all-defined-out) - (rename-out [contour3d isoline3d] - [contours3d isolines3d] - [contour-intervals3d isoline-intervals3d])) +(provide (all-defined-out)) ;; =================================================================================================== ;; One contour line in 3D (using marching squares) -(define ((contour3d-render-proc f z samples color width style alpha label) area) +(define ((isoline3d-render-proc f z samples color width style alpha label) area) (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 (2d-sample xs ys zss fz-min fz-max) @@ -41,7 +39,7 @@ (cond [label (line-legend-entry label color width style)] [else empty])) -(defproc (contour3d +(defproc (isoline3d [f (real? real? . -> . real?)] [z real?] [x-min (or/c regular-real? #f) #f] [x-max (or/c regular-real? #f) #f] @@ -61,7 +59,7 @@ [z-max (if z-max z-max z)]) (renderer3d (vector (ivl x-min x-max) (ivl y-min y-max) (ivl z-min z-max)) #f default-ticks-fun - (contour3d-render-proc g z samples color width style alpha label)))) + (isoline3d-render-proc g z samples color width style alpha label)))) ;; =================================================================================================== ;; Contour lines in 3D (using marching squares) @@ -74,37 +72,36 @@ (match-define (list (tick zs _ labels) ...) (contour-ticks z-min z-max levels #f)) - (define cs (maybe-apply/list colors zs)) - (define ws (maybe-apply/list widths zs)) - (define ss (maybe-apply/list styles zs)) - (define as (maybe-apply/list alphas zs)) - - (for ([z (in-list zs)] - [color (in-cycle cs)] - [width (in-cycle ws)] - [style (in-cycle ss)] - [alpha (in-cycle as)]) - (send area put-alpha alpha) - (send area put-pen color width style) - (for ([ya (in-list ys)] - [yb (in-list (rest ys))] - [zs0 (in-vector zss)] - [zs1 (in-vector zss 1)] - #:when #t - [xa (in-list xs)] - [xb (in-list (rest xs))] - [z1 (in-vector zs0)] - [z2 (in-vector zs0 1)] - [z3 (in-vector zs1 1)] - [z4 (in-vector zs1)]) - (for ([line (in-list (heights->lines xa xb ya yb z z1 z2 z3 z4))]) - (match-define (list v1 v2) line) - (define center (vector (* 1/2 (+ xa xb)) (* 1/2 (+ ya yb)) - (* 1/2 (+ (min z1 z2 z3 z4) (max z1 z2 z3 z4))))) - (send area put-line v1 v2 center)))) - - (cond [label (line-legend-entries label zs labels colors widths styles)] - [else empty])) + (let ([colors (maybe-apply colors zs)] + [widths (maybe-apply widths zs)] + [styles (maybe-apply styles zs)] + [alphas (maybe-apply alphas zs)]) + (for ([z (in-list zs)] + [color (in-cycle colors)] + [width (in-cycle widths)] + [style (in-cycle styles)] + [alpha (in-cycle alphas)]) + (send area put-alpha alpha) + (send area put-pen color width style) + (for ([ya (in-list ys)] + [yb (in-list (rest ys))] + [zs0 (in-vector zss)] + [zs1 (in-vector zss 1)] + #:when #t + [xa (in-list xs)] + [xb (in-list (rest xs))] + [z1 (in-vector zs0)] + [z2 (in-vector zs0 1)] + [z3 (in-vector zs1 1)] + [z4 (in-vector zs1)]) + (for ([line (in-list (heights->lines xa xb ya yb z z1 z2 z3 z4))]) + (match-define (list v1 v2) line) + (define center (vector (* 1/2 (+ xa xb)) (* 1/2 (+ ya yb)) + (* 1/2 (+ (min z1 z2 z3 z4) (max z1 z2 z3 z4))))) + (send area put-line v1 v2 center)))) + + (cond [label (line-legend-entries label zs labels colors widths styles)] + [else empty]))) (defproc (contours3d [f (real? real? . -> . real?)] @@ -114,12 +111,12 @@ [y-max (or/c regular-real? #f) #f] [#:z-min z-min (or/c regular-real? #f) #f] [#:z-max z-max (or/c regular-real? #f) #f] - [#:levels levels (or/c 'auto exact-positive-integer? (listof real?)) (contour-levels)] [#:samples samples (and/c exact-integer? (>=/c 2)) (plot3d-samples)] - [#:colors colors plot-colors/c (contour-colors)] - [#:widths widths pen-widths/c (contour-widths)] - [#:styles styles plot-pen-styles/c (contour-styles)] - [#:alphas alphas alphas/c (contour-alphas)] + [#:levels levels (or/c 'auto pos/c (listof real?)) (contour-levels)] + [#:colors colors (plot-colors/c (listof real?)) (contour-colors)] + [#:widths widths (pen-widths/c (listof real?)) (contour-widths)] + [#:styles styles (plot-pen-styles/c (listof real?)) (contour-styles)] + [#:alphas alphas (alphas/c (listof real?)) (contour-alphas)] [#:label label (or/c string? #f) #f] ) renderer3d? (define g (2d-function->sampler f)) @@ -132,7 +129,7 @@ ;; Contour intervals in 3D (using marching squares) (define ((contour-intervals3d-render-proc - f levels samples colors line-colors line-widths line-styles + f levels samples colors styles line-colors line-widths line-styles contour-colors contour-widths contour-styles alphas label) area) (match-define (vector (ivl x-min x-max) (ivl y-min y-max) (ivl z-min z-max)) @@ -142,46 +139,65 @@ (match-define (list (tick zs _ labels) ...) (contour-ticks z-min z-max levels #t)) - (define cs (maybe-apply/list colors zs)) - (define lcs (maybe-apply/list line-colors zs)) - (define lws (maybe-apply/list line-widths zs)) - (define lss (maybe-apply/list line-styles zs)) - (define as (maybe-apply/list alphas zs)) + (define-values (z-ivls ivl-labels) + (for/lists (z-ivls ivl-labels) ([za (in-list zs)] + [zb (in-list (rest zs))] + [la (in-list labels)] + [lb (in-list (rest labels))]) + (values (ivl za zb) (format "[~a,~a]" la lb)))) - (for ([za (in-list zs)] - [zb (in-list (rest zs))] - [color (in-cycle cs)] - [line-color (in-cycle lcs)] - [line-width (in-cycle lws)] - [line-style (in-cycle lss)] - [alpha (in-cycle as)]) - (send area put-alpha alpha) - (send area put-pen line-color line-width line-style) - (send area put-brush color 'solid) - (for ([ya (in-list ys)] - [yb (in-list (rest ys))] - [zs0 (in-vector zss)] - [zs1 (in-vector zss 1)] - #:when #t - [xa (in-list xs)] - [xb (in-list (rest xs))] - [z1 (in-vector zs0)] - [z2 (in-vector zs0 1)] - [z3 (in-vector zs1 1)] - [z4 (in-vector zs1)]) - (for ([poly (in-list (heights->polys xa xb ya yb za zb z1 z2 z3 z4))]) - (define center (vector (* 1/2 (+ xa xb)) - (* 1/2 (+ ya yb)) - (* 1/2 (+ (min z1 z2 z3 z4) (max z1 z2 z3 z4))))) - (send area put-polygon poly center)))) - - ((contours3d-render-proc f levels samples contour-colors contour-widths contour-styles alphas #f) - area) - - (cond [label (contour-intervals-legend-entries - label zs labels colors '(solid) line-colors line-widths line-styles - contour-colors contour-widths contour-styles)] - [else empty])) + (let ([colors (maybe-apply colors z-ivls)] + [styles (maybe-apply styles z-ivls)] + [alphas (maybe-apply alphas z-ivls)] + [line-colors (maybe-apply line-colors z-ivls)] + [line-widths (maybe-apply line-widths z-ivls)] + [line-styles (maybe-apply line-styles z-ivls)]) + (for ([za (in-list zs)] + [zb (in-list (rest zs))] + [color (in-cycle colors)] + [style (in-cycle styles)] + [alpha (in-cycle alphas)] + [line-color (in-cycle line-colors)] + [line-width (in-cycle line-widths)] + [line-style (in-cycle line-styles)]) + (send area put-alpha alpha) + (send area put-pen line-color line-width line-style) + (send area put-brush color style) + (for ([ya (in-list ys)] + [yb (in-list (rest ys))] + [zs0 (in-vector zss)] + [zs1 (in-vector zss 1)] + #:when #t + [xa (in-list xs)] + [xb (in-list (rest xs))] + [z1 (in-vector zs0)] + [z2 (in-vector zs0 1)] + [z3 (in-vector zs1 1)] + [z4 (in-vector zs1)]) + (for ([poly (in-list (heights->polys xa xb ya yb za zb z1 z2 z3 z4))]) + (define center (vector (* 1/2 (+ xa xb)) + (* 1/2 (+ ya yb)) + (* 1/2 (+ (min z1 z2 z3 z4) (max z1 z2 z3 z4))))) + (send area put-polygon poly center)))) + + ((contours3d-render-proc f levels samples contour-colors contour-widths contour-styles alphas #f) + area) + + (define n (- (length zs) 2)) + (define contour-colors* + (append (list 0) (sequence-take (in-cycle (maybe-apply contour-colors zs)) 0 n) (list 0))) + (define contour-widths* + (append (list 0) (sequence-take (in-cycle (maybe-apply contour-widths zs)) 0 n) (list 0))) + (define contour-styles* + (append '(transparent) (sequence-take (in-cycle (maybe-apply contour-styles zs)) 0 n) + '(transparent))) + + (cond [label (interval-legend-entries + label z-ivls ivl-labels + colors styles line-colors line-widths line-styles + contour-colors* contour-widths* contour-styles* + (rest contour-colors*) (rest contour-widths*) (rest contour-styles*))] + [else empty]))) (defproc (contour-intervals3d [f (real? real? . -> . real?)] @@ -191,23 +207,24 @@ [y-max (or/c regular-real? #f) #f] [#:z-min z-min (or/c regular-real? #f) #f] [#:z-max z-max (or/c regular-real? #f) #f] - [#:levels levels (or/c 'auto exact-positive-integer? (listof real?)) (contour-levels)] [#:samples samples (and/c exact-integer? (>=/c 2)) (plot3d-samples)] - [#:colors colors plot-colors/c (contour-interval-colors)] - [#:line-colors line-colors plot-colors/c (contour-interval-line-colors)] - [#:line-widths line-widths pen-widths/c (contour-interval-line-widths)] - [#:line-styles line-styles plot-pen-styles/c (contour-interval-line-styles)] - [#:contour-colors contour-colors plot-colors/c (contour-colors)] - [#:contour-widths contour-widths pen-widths/c (contour-widths)] - [#:contour-styles contour-styles plot-pen-styles/c (contour-styles)] - [#:alphas alphas alphas/c (contour-interval-alphas)] + [#:levels levels (or/c 'auto pos/c (listof real?)) (contour-levels)] + [#:colors colors (plot-colors/c (listof ivl?)) (contour-interval-colors)] + [#:styles styles (plot-brush-styles/c (listof ivl?)) (contour-interval-styles)] + [#:line-colors line-colors (plot-colors/c (listof ivl?)) (contour-interval-line-colors)] + [#:line-widths line-widths (pen-widths/c (listof ivl?)) (contour-interval-line-widths)] + [#:line-styles line-styles (plot-pen-styles/c (listof ivl?)) (contour-interval-line-styles)] + [#:contour-colors contour-colors (plot-colors/c (listof real?)) (contour-colors)] + [#:contour-widths contour-widths (pen-widths/c (listof real?)) (contour-widths)] + [#:contour-styles contour-styles (plot-pen-styles/c (listof real?)) (contour-styles)] + [#:alphas alphas (alphas/c (listof ivl?)) (contour-interval-alphas)] [#:label label (or/c string? #f) #f] ) renderer3d? (define g (2d-function->sampler f)) (renderer3d (vector (ivl x-min x-max) (ivl y-min y-max) (ivl z-min z-max)) (surface3d-bounds-fun g samples) default-ticks-fun - (contour-intervals3d-render-proc g levels samples colors + (contour-intervals3d-render-proc g levels samples colors styles line-colors line-widths line-styles contour-colors contour-widths contour-styles alphas label))) diff --git a/collects/plot/plot3d/isosurface.rkt b/collects/plot/plot3d/isosurface.rkt index 07ff33ce83..4a4ec70588 100644 --- a/collects/plot/plot3d/isosurface.rkt +++ b/collects/plot/plot3d/isosurface.rkt @@ -9,7 +9,8 @@ ;; =================================================================================================== ;; Surfaces of constant value (isosurfaces) -(define ((isosurface3d-render-proc f d samples color line-color line-width line-style alpha label) +(define ((isosurface3d-render-proc + f d samples color style line-color line-width line-style alpha label) area) (match-define (vector (ivl x-min x-max) (ivl y-min y-max) (ivl z-min z-max)) (send area get-bounds-rect)) @@ -19,7 +20,7 @@ z-min z-max (animated-samples samples))) (send area put-alpha alpha) - (send area put-brush color 'solid) + (send area put-brush color style) (send area put-pen line-color line-width line-style) (for ([za (in-list zs)] [zb (in-list (rest zs))] @@ -50,7 +51,7 @@ (vector (* 1/2 (+ xa xb)) (* 1/2 (+ ya yb)) (* 1/2 (+ za zb)))))) (cond [label (rectangle-legend-entry - label color 'solid line-color line-width line-style)] + label color style line-color line-width line-style)] [else empty])) (defproc (isosurface3d [f (real? real? real? . -> . real?)] [d real?] @@ -62,6 +63,7 @@ [z-max (or/c regular-real? #f) #f] [#:samples samples (and/c exact-integer? (>=/c 2)) (plot3d-samples)] [#:color color plot-color/c (surface-color)] + [#:style style plot-brush-style/c (surface-style)] [#:line-color line-color plot-color/c (surface-line-color)] [#:line-width line-width (>=/c 0) (surface-line-width)] [#:line-style line-style plot-pen-style/c (surface-line-style)] @@ -70,14 +72,14 @@ ) renderer3d? (define g (3d-function->sampler f)) (renderer3d (vector (ivl x-min x-max) (ivl y-min y-max) (ivl z-min z-max)) #f default-ticks-fun - (isosurface3d-render-proc g d samples color line-color line-width line-style alpha - label))) + (isosurface3d-render-proc + g d samples color style line-color line-width line-style alpha label))) ;; =================================================================================================== ;; Nested isosurfaces -(define ((isosurfaces3d-render-proc - f rd-min rd-max levels samples colors line-colors line-widths line-styles alphas label) +(define ((isosurfaces3d-render-proc f rd-min rd-max levels samples colors styles + line-colors line-widths line-styles alphas label) area) (match-define (vector (ivl x-min x-max) (ivl y-min y-max) (ivl z-min z-max)) (send area get-bounds-rect)) @@ -95,75 +97,80 @@ (match-define (list (tick ds _ labels) ...) (isosurface-ticks d-min d-max levels)) #;(define ds (linear-seq d-min d-max levels #:start? (and rd-min #t) #:end? (and rd-max #t))) - (for ([d (in-list ds)] - [color (in-cycle (maybe-apply/list colors ds))] - [line-color (in-cycle (maybe-apply/list line-colors ds))] - [line-width (in-cycle (maybe-apply/list line-widths ds))] - [line-style (in-cycle (maybe-apply/list line-styles ds))] - [alpha (in-cycle (maybe-apply/list alphas ds))]) - (send area put-alpha alpha) - (send area put-brush color 'solid) - (send area put-pen line-color line-width line-style) - (for ([za (in-list zs)] - [zb (in-list (rest zs))] - [dss0 (in-vector dsss)] - [dss1 (in-vector dsss 1)] - #:when #t - [ya (in-list ys)] - [yb (in-list (rest ys))] - [ds00 (in-vector dss0)] - [ds01 (in-vector dss0 1)] - [ds10 (in-vector dss1)] - [ds11 (in-vector dss1 1)] - #:when #t - [xa (in-list xs)] - [xb (in-list (rest xs))] - [d1 (in-vector ds00)] - [d2 (in-vector ds00 1)] - [d3 (in-vector ds01 1)] - [d4 (in-vector ds01)] - [d5 (in-vector ds10)] - [d6 (in-vector ds10 1)] - [d7 (in-vector ds11 1)] - [d8 (in-vector ds11)]) - (define polys (heights->cube-polys xa xb ya yb za zb d d1 d2 d3 d4 d5 d6 d7 d8)) - (when (not (empty? polys)) - (send area put-polygons polys - (vector (* 1/2 (+ xa xb)) (* 1/2 (+ ya yb)) (* 1/2 (+ za zb))))))) - - (cond - [label (rectangle-legend-entries - label ds colors '(solid) line-colors line-widths line-styles)] - [else empty])])) + (let ([colors (maybe-apply colors ds)] + [styles (maybe-apply styles ds)] + [alphas (maybe-apply alphas ds)] + [line-colors (maybe-apply line-colors ds)] + [line-widths (maybe-apply line-widths ds)] + [line-styles (maybe-apply line-styles ds)]) + (for ([d (in-list ds)] + [color (in-cycle colors)] + [style (in-cycle styles)] + [alpha (in-cycle alphas)] + [line-color (in-cycle line-colors)] + [line-width (in-cycle line-widths)] + [line-style (in-cycle line-styles)]) + (send area put-alpha alpha) + (send area put-brush color style) + (send area put-pen line-color line-width line-style) + (for ([za (in-list zs)] + [zb (in-list (rest zs))] + [dss0 (in-vector dsss)] + [dss1 (in-vector dsss 1)] + #:when #t + [ya (in-list ys)] + [yb (in-list (rest ys))] + [ds00 (in-vector dss0)] + [ds01 (in-vector dss0 1)] + [ds10 (in-vector dss1)] + [ds11 (in-vector dss1 1)] + #:when #t + [xa (in-list xs)] + [xb (in-list (rest xs))] + [d1 (in-vector ds00)] + [d2 (in-vector ds00 1)] + [d3 (in-vector ds01 1)] + [d4 (in-vector ds01)] + [d5 (in-vector ds10)] + [d6 (in-vector ds10 1)] + [d7 (in-vector ds11 1)] + [d8 (in-vector ds11)]) + (define polys (heights->cube-polys xa xb ya yb za zb d d1 d2 d3 d4 d5 d6 d7 d8)) + (when (not (empty? polys)) + (send area put-polygons polys + (vector (* 1/2 (+ xa xb)) (* 1/2 (+ ya yb)) (* 1/2 (+ za zb))))))) + + (cond + [label (rectangle-legend-entries + label ds colors styles line-colors line-widths line-styles)] + [else empty]))])) -(defproc (isosurfaces3d [f (real? real? real? . -> . real?)] - [x-min (or/c regular-real? #f) #f] - [x-max (or/c regular-real? #f) #f] - [y-min (or/c regular-real? #f) #f] - [y-max (or/c regular-real? #f) #f] - [z-min (or/c regular-real? #f) #f] - [z-max (or/c regular-real? #f) #f] - [#:d-min d-min (or/c regular-real? #f) #f] - [#:d-max d-max (or/c regular-real? #f) #f] - [#:levels levels (or/c 'auto exact-positive-integer? (listof real?)) - (isosurface-levels)] - [#:samples samples (and/c exact-integer? (>=/c 2)) (plot3d-samples)] - [#:colors colors plot-colors/c (isosurface-colors)] - [#:line-colors line-colors plot-colors/c (isosurface-line-colors)] - [#:line-widths line-widths pen-widths/c (isosurface-line-widths)] - [#:line-styles line-styles plot-pen-styles/c (isosurface-line-styles)] - [#:alphas alphas alphas/c (isosurface-alphas)] - [#:label label (or/c string? #f) #f] - ) renderer3d? +(defproc (isosurfaces3d + [f (real? real? real? . -> . real?)] + [x-min (or/c regular-real? #f) #f] [x-max (or/c regular-real? #f) #f] + [y-min (or/c regular-real? #f) #f] [y-max (or/c regular-real? #f) #f] + [z-min (or/c regular-real? #f) #f] [z-max (or/c regular-real? #f) #f] + [#:d-min d-min (or/c regular-real? #f) #f] [#:d-max d-max (or/c regular-real? #f) #f] + [#:samples samples (and/c exact-integer? (>=/c 2)) (plot3d-samples)] + [#:levels levels (or/c 'auto exact-positive-integer? (listof real?)) (isosurface-levels)] + [#:colors colors (plot-colors/c (listof real?)) (isosurface-colors)] + [#:styles styles (plot-brush-styles/c (listof real?)) (isosurface-styles)] + [#:line-colors line-colors (plot-colors/c (listof real?)) (isosurface-line-colors)] + [#:line-widths line-widths (pen-widths/c (listof real?)) (isosurface-line-widths)] + [#:line-styles line-styles (plot-pen-styles/c (listof real?)) (isosurface-line-styles)] + [#:alphas alphas (alphas/c (listof real?)) (isosurface-alphas)] + [#:label label (or/c string? #f) #f] + ) renderer3d? (define g (3d-function->sampler f)) (renderer3d (vector (ivl x-min x-max) (ivl y-min y-max) (ivl z-min z-max)) #f default-ticks-fun - (isosurfaces3d-render-proc g d-min d-max levels samples colors + (isosurfaces3d-render-proc g d-min d-max levels samples colors styles line-colors line-widths line-styles alphas label))) ;; =================================================================================================== -(define ((polar3d-render-proc f g samples color line-color line-width line-style alpha label) area) +(define ((polar3d-render-proc f g samples color style line-color line-width line-style alpha label) + area) (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 (3d-sample xs ys zs dsss d-min d-max) @@ -172,7 +179,7 @@ z-min z-max (animated-samples samples))) (send area put-alpha alpha) - (send area put-brush color 'solid) + (send area put-brush color style) (send area put-pen line-color line-width line-style) (for ([za (in-list zs)] [zb (in-list (rest zs))] @@ -218,7 +225,7 @@ (draw-cube xa xb ya yb za zb d1 d2 d3 d4 d5 d6 d7 d8)])) (cond [label (rectangle-legend-entry - label color 'solid line-color line-width line-style)] + label color style line-color line-width line-style)] [else empty])) (define 2pi (* 2 pi)) @@ -233,21 +240,20 @@ (flatan (fl/ z (fldistance x y))))])) (fl- (exact->inexact (f θ ρ)) (fldistance x y z)))) -(defproc (polar3d [f (real? real? . -> . real?)] - [#:x-min x-min (or/c regular-real? #f) #f] - [#:x-max x-max (or/c regular-real? #f) #f] - [#:y-min y-min (or/c regular-real? #f) #f] - [#:y-max y-max (or/c regular-real? #f) #f] - [#:z-min z-min (or/c regular-real? #f) #f] - [#:z-max z-max (or/c regular-real? #f) #f] - [#:samples samples (and/c exact-integer? (>=/c 2)) (plot3d-samples)] - [#:color color plot-color/c (surface-color)] - [#:line-color line-color plot-color/c (surface-line-color)] - [#:line-width line-width (>=/c 0) (surface-line-width)] - [#:line-style line-style plot-pen-style/c (surface-line-style)] - [#:alpha alpha (real-in 0 1) (surface-alpha)] - [#:label label (or/c string? #f) #f] - ) renderer3d? +(defproc (polar3d + [f (real? real? . -> . real?)] + [#:x-min x-min (or/c regular-real? #f) #f] [#:x-max x-max (or/c regular-real? #f) #f] + [#:y-min y-min (or/c regular-real? #f) #f] [#:y-max y-max (or/c regular-real? #f) #f] + [#:z-min z-min (or/c regular-real? #f) #f] [#:z-max z-max (or/c regular-real? #f) #f] + [#:samples samples (and/c exact-integer? (>=/c 2)) (plot3d-samples)] + [#:color color plot-color/c (surface-color)] + [#:style style plot-brush-style/c (surface-style)] + [#:line-color line-color plot-color/c (surface-line-color)] + [#:line-width line-width (>=/c 0) (surface-line-width)] + [#:line-style line-style plot-pen-style/c (surface-line-style)] + [#:alpha alpha (real-in 0 1) (surface-alpha)] + [#:label label (or/c string? #f) #f] + ) renderer3d? (define vs (for*/list ([θ (in-list (linear-seq 0.0 2pi (* 4 samples)))] [ρ (in-list (linear-seq (* -1/2 pi) (* 1/2 pi) (* 2 samples)))]) (3d-polar->3d-cartesian θ ρ (f θ ρ)))) @@ -265,5 +271,5 @@ (define g (3d-function->sampler new-f)) (renderer3d (vector (ivl x-min x-max) (ivl y-min y-max) (ivl z-min z-max)) #f default-ticks-fun - (polar3d-render-proc new-f g samples color + (polar3d-render-proc new-f g samples color style line-color line-width line-style alpha label)))])) diff --git a/collects/plot/plot3d/plot-area.rkt b/collects/plot/plot3d/plot-area.rkt index c9666f476e..be1f8599dc 100644 --- a/collects/plot/plot3d/plot-area.rkt +++ b/collects/plot/plot3d/plot-area.rkt @@ -214,24 +214,24 @@ (vector x y (pre-tick-value t2)))) (define x-ticks - (collapse-nearby-ticks (filter (λ (t) (<= x-min (pre-tick-value t) x-max)) rx-ticks) - (x-ticks-near? x-axis-y))) + (collapse-ticks (filter (λ (t) (<= x-min (pre-tick-value t) x-max)) rx-ticks) + (x-ticks-near? x-axis-y))) (define y-ticks - (collapse-nearby-ticks (filter (λ (t) (<= y-min (pre-tick-value t) y-max)) ry-ticks) - (y-ticks-near? y-axis-x))) + (collapse-ticks (filter (λ (t) (<= y-min (pre-tick-value t) y-max)) ry-ticks) + (y-ticks-near? y-axis-x))) (define z-ticks - (collapse-nearby-ticks (filter (λ (t) (<= z-min (pre-tick-value t) z-max)) rz-ticks) - (z-ticks-near? z-axis-x z-axis-y))) + (collapse-ticks (filter (λ (t) (<= z-min (pre-tick-value t) z-max)) rz-ticks) + (z-ticks-near? z-axis-x z-axis-y))) (define x-far-ticks - (collapse-nearby-ticks (filter (λ (t) (<= x-min (pre-tick-value t) x-max)) rx-far-ticks) - (x-ticks-near? x-far-axis-y))) + (collapse-ticks (filter (λ (t) (<= x-min (pre-tick-value t) x-max)) rx-far-ticks) + (x-ticks-near? x-far-axis-y))) (define y-far-ticks - (collapse-nearby-ticks (filter (λ (t) (<= y-min (pre-tick-value t) y-max)) ry-far-ticks) - (y-ticks-near? y-far-axis-x))) + (collapse-ticks (filter (λ (t) (<= y-min (pre-tick-value t) y-max)) ry-far-ticks) + (y-ticks-near? y-far-axis-x))) (define z-far-ticks - (collapse-nearby-ticks (filter (λ (t) (<= z-min (pre-tick-value t) z-max)) rz-far-ticks) - (z-ticks-near? z-far-axis-x z-far-axis-y))) + (collapse-ticks (filter (λ (t) (<= z-min (pre-tick-value t) z-max)) rz-far-ticks) + (z-ticks-near? z-far-axis-x z-far-axis-y))) ;; =============================================================================================== ;; Tick and label parameters, and fixpoint margin computation @@ -321,7 +321,7 @@ (define dist (+ (pen-gap) tick-radius)) (for/list ([t (in-list ticks)] #:when (pre-tick-major? t)) (match-define (tick x _ label) t) - (list #t label (v+ (tick-value->dc x) (v* offset-dir dist)) anchor))) + (list label (v+ (tick-value->dc x) (v* offset-dir dist)) anchor))) (define (get-x-tick-label-params) (if (plot-x-axis?) @@ -423,35 +423,35 @@ (define (get-x-label-params) (define v0 (plot->dc/no-axis-trans (vector x-mid x-axis-y z-min))) (define dist (+ max-x-tick-offset (max-x-tick-label-diag) half-char-height)) - (list #t (plot-x-label) (v+ v0 (v* (y-axis-dir) (if x-axis-y-min? (- dist) dist))) + (list (plot-x-label) (v+ v0 (v* (y-axis-dir) (if x-axis-y-min? (- dist) dist))) 'top (- (if x-axis-y-min? 0 pi) (x-axis-angle)))) (define (get-y-label-params) (define v0 (plot->dc/no-axis-trans (vector y-axis-x y-mid z-min))) (define dist (+ max-y-tick-offset (max-y-tick-label-diag) half-char-height)) - (list #t (plot-y-label) (v+ v0 (v* (x-axis-dir) (if y-axis-x-min? (- dist) dist))) + (list (plot-y-label) (v+ v0 (v* (x-axis-dir) (if y-axis-x-min? (- dist) dist))) 'top (- (if y-axis-x-min? pi 0) (y-axis-angle)))) (define (get-z-label-params) - (list #t (plot-z-label) (v+ (plot->dc* (vector z-axis-x z-axis-y z-max)) - (vector 0 (- half-char-height))) + (list (plot-z-label) (v+ (plot->dc* (vector z-axis-x z-axis-y z-max)) + (vector 0 (- half-char-height))) 'bottom-left 0)) (define (get-x-far-label-params) (define v0 (plot->dc/no-axis-trans (vector x-mid x-far-axis-y z-min))) (define dist (+ max-x-far-tick-offset (max-x-far-tick-label-diag) half-char-height)) - (list #f (plot-x-far-label) (v+ v0 (v* (y-axis-dir) (if x-axis-y-min? dist (- dist)))) + (list (plot-x-far-label) (v+ v0 (v* (y-axis-dir) (if x-axis-y-min? dist (- dist)))) 'bottom (- (if x-axis-y-min? 0 pi) (x-axis-angle)))) (define (get-y-far-label-params) (define v0 (plot->dc/no-axis-trans (vector y-far-axis-x y-mid z-min))) (define dist (+ max-y-far-tick-offset (max-y-far-tick-label-diag) half-char-height)) - (list #f (plot-y-far-label) (v+ v0 (v* (x-axis-dir) (if y-axis-x-min? dist (- dist)))) + (list (plot-y-far-label) (v+ v0 (v* (x-axis-dir) (if y-axis-x-min? dist (- dist)))) 'bottom (- (if y-axis-x-min? pi 0) (y-axis-angle)))) (define (get-z-far-label-params) - (list #t (plot-z-far-label) (v+ (plot->dc* (vector z-far-axis-x z-far-axis-y z-max)) - (vector 0 (- half-char-height))) + (list (plot-z-far-label) (v+ (plot->dc* (vector z-far-axis-x z-far-axis-y z-max)) + (vector 0 (- half-char-height))) 'bottom-right 0)) ;; ----------------------------------------------------------------------------------------------- @@ -508,7 +508,7 @@ ;(printf "label params = ~v~n" (get-all-label-params)) ;(printf "tick params = ~v~n" (get-all-tick-params)) (set! view->dc (make-view->dc left right top bottom)) - (append (append* (map (λ (params) (send/apply pd get-text-corners (rest params))) + (append (append* (map (λ (params) (send/apply pd get-text-corners params)) (get-all-label-params))) (append* (map (λ (params) (send/apply pd get-tick-endpoints (rest params))) (get-all-tick-params))))) @@ -569,7 +569,7 @@ (define (draw-labels label-params) (for ([params (in-list label-params)]) - (send/apply pd draw-text (rest params) #:outline? (first params)))) + (send/apply pd draw-text params #:outline? #t))) ;; =============================================================================================== ;; Delayed drawing @@ -578,7 +578,7 @@ (define (add-shape! shape) (set! render-list (cons shape render-list))) (define (draw-shapes lst) - (for ([s (in-list (depth-sort lst))]) + (for ([s (in-list (depth-sort (reverse lst)))]) (send pd set-alpha (shape-alpha s)) (match s ; shapes @@ -609,6 +609,10 @@ [(tick-glyph alpha center radius angle pen-color pen-width pen-style) (send pd set-pen pen-color pen-width pen-style) (send pd draw-tick (view->dc (rotate/rho center)) radius angle)] + ; arrow glyph + [(arrow-glyph alpha center v1 v2 pen-color pen-width pen-style) + (send pd set-pen pen-color pen-width pen-style) + (send pd draw-arrow (view->dc v1) (view->dc v2))] [_ (error 'draw-shapes "shape not implemented: ~e" s)]))) ;; Use a special view transform for the light so that the light angle is always the same @@ -886,6 +890,19 @@ (get-pen-color) (get-pen-width) (get-pen-style) (get-brush-color) (get-brush-style)))))) + (define/public (put-arrow v1 v2 [c (v* (v+ v1 v2) 1/2)]) + (when (and (vregular? v1) (vregular? v2) (in-bounds? v1)) + (cond [(in-bounds? v2) (add-shape! + (arrow-glyph (get-alpha) (plot->view/no-rho c) + (plot->view v1) (plot->view v2) + (->brush-color (plot-background)) + (+ 2 (get-pen-width)) 'solid)) + (add-shape! + (arrow-glyph (get-alpha) (plot->view/no-rho c) + (plot->view v1) (plot->view v2) + (get-pen-color) (get-pen-width) (get-pen-style)))] + [else (put-line v1 v2)]))) + (define/public (put-tick v radius angle) (when (and (vregular? v) (in-bounds? v)) (add-shape! diff --git a/collects/plot/plot3d/point.rkt b/collects/plot/plot3d/point.rkt index 6976c168c2..d148352106 100644 --- a/collects/plot/plot3d/point.rkt +++ b/collects/plot/plot3d/point.rkt @@ -44,3 +44,71 @@ (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)))]))) + +;; =================================================================================================== + +(define ((vector-field3d-render-fun f samples scale color line-width line-style alpha label) area) + (match-define (vector (ivl x-min x-max) (ivl y-min y-max) (ivl z-min z-max)) + (send area get-bounds-rect)) + + (define xs0 (linear-seq x-min x-max samples #:start? #t #:end? #t)) + (define ys0 (linear-seq y-min y-max samples #:start? #t #:end? #t)) + (define zs0 (linear-seq z-min z-max samples #:start? #t #:end? #t)) + + (define-values (vs dxs dys dzs norms mags) + (for*/lists (vs dxs dys dzs norms mags) ([x (in-list xs0)] + [y (in-list ys0)] + [z (in-list zs0)] + [dv (in-value (f x y z))] #:when (vregular? dv)) + (match-define (vector dx dy dz) dv) + (values (vector x y z) dx dy dz (vnormalize dv) (vmag dv)))) + + (cond [(empty? vs) empty] + [else (define box-x-size (/ (- x-max x-min) samples)) + (define box-y-size (/ (- y-max y-min) samples)) + (define box-z-size (/ (- z-max z-min) samples)) + + (define new-mags + (match scale + [(? real?) (map (λ (mag) (* scale mag)) mags)] + ['normalized (define box-size (min box-x-size box-y-size box-z-size)) + (build-list (length dxs) (λ _ box-size))] + ['auto (define dx-max (apply max (map abs dxs))) + (define dy-max (apply max (map abs dys))) + (define dz-max (apply max (map abs dzs))) + (define scale (min (/ box-x-size dx-max) + (/ box-y-size dy-max) + (/ box-z-size dz-max))) + (map (λ (mag) (* scale mag)) mags)])) + + (send area put-alpha alpha) + (send area put-pen color line-width line-style) + (for ([v (in-list vs)] + [norm (in-list norms)] + [mag (in-list new-mags)]) + (send area put-arrow v (v+ v (v* norm mag)))) + + (cond [label (vector-field-legend-entry label color line-width line-style)] + [else empty])])) + +(defproc (vector-field3d + [f (or/c (real? real? real? . -> . (vector/c real? real? real?)) + ((vector/c real? real? real?) . -> . (vector/c real? real? real?)))] + [x-min (or/c regular-real? #f) #f] + [x-max (or/c regular-real? #f) #f] + [y-min (or/c regular-real? #f) #f] + [y-max (or/c regular-real? #f) #f] + [z-min (or/c regular-real? #f) #f] + [z-max (or/c regular-real? #f) #f] + [#:samples samples exact-positive-integer? ( vector-field3d-samples)] + [#:scale scale (or/c real? (one-of/c 'auto 'normalized)) (vector-field-scale)] + [#:color color plot-color/c (vector-field-color)] + [#:line-width line-width (>=/c 0) (vector-field-line-width)] + [#:line-style line-style plot-pen-style/c (vector-field-line-style)] + [#:alpha alpha (real-in 0 1) (vector-field-alpha)] + [#:label label (or/c string? #f) #f] + ) renderer3d? + (let ([f (cond [(procedure-arity-includes? f 3 #t) f] + [else (λ (x y z) (f (vector x y z)))])]) + (renderer3d (vector (ivl x-min x-max) (ivl y-min y-max) (ivl z-min z-max)) #f default-ticks-fun + (vector-field3d-render-fun f samples scale color line-width line-style alpha label)))) diff --git a/collects/plot/plot3d/shape.rkt b/collects/plot/plot3d/shape.rkt index dfb3a1aa8e..7f45f79002 100644 --- a/collects/plot/plot3d/shape.rkt +++ b/collects/plot/plot3d/shape.rkt @@ -12,6 +12,7 @@ (struct text shape (anchor angle str font-size font-family color) #: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) (struct shapes shape (list) #:transparent) (define (draw-before? s1 s2) diff --git a/collects/plot/scribblings/renderer2d.scrbl b/collects/plot/scribblings/renderer2d.scrbl index 9ef0b83f6b..d4e76a03b5 100644 --- a/collects/plot/scribblings/renderer2d.scrbl +++ b/collects/plot/scribblings/renderer2d.scrbl @@ -243,10 +243,6 @@ For example, #:styles '(solid dot)))] } -@defproc[(isolines ...) renderer2d?]{ -A synonym of @(racket contours). -} - @doc-apply[contour-intervals]{ Returns a renderer that fills the area between contour lines, and additionally draws contour lines. @@ -258,10 +254,6 @@ For example, the canonical saddle, with its gradient field superimposed: #:color "black" #:label "Gradient")))] } -@defproc[(isoline-intervals ...) renderer2d?]{ -A synonym of @(racket contour-intervals). -} - @section{2D Rectangle Renderers} @defstruct[ivl ([min real?] [max real?])]{ diff --git a/collects/plot/scribblings/renderer3d.scrbl b/collects/plot/scribblings/renderer3d.scrbl index 668023368a..4585d22d4f 100644 --- a/collects/plot/scribblings/renderer3d.scrbl +++ b/collects/plot/scribblings/renderer3d.scrbl @@ -98,14 +98,10 @@ Combining polar function renderers allows faking latitudes or longitudes in larg @section{3D Contour (Isoline) Renderers} -@doc-apply[contour3d]{ +@doc-apply[isoline3d]{ Returns a renderer that plots a single contour line on the surface of a function. } -@defproc[(isoline3d ...) renderer3d?]{ -A synonym of @(racket contour3d). -} - @doc-apply[contours3d]{ Returns a renderer that plots contour lines on the surface of a function. @@ -118,10 +114,6 @@ For example, #:legend-anchor 'top-left)] } -@defproc[(isolines3d ...) renderer3d?]{ -A synonym of @(racket contours3d). -} - @doc-apply[contour-intervals3d]{ Returns a renderer that plots contour intervals and contour lines on the surface of a function. The appearance keyword arguments are interpreted identically to the appearance keyword arguments to @(racket contour-intervals). @@ -133,10 +125,6 @@ For example, #:legend-anchor 'top-left)] } -@defproc[(isoline-intervals3d ...) renderer3d?]{ -A synonym of @(racket contour-intervals3d). -} - @section{3D Isosurface Renderers} @doc-apply[isosurface3d]{ diff --git a/collects/plot/tests/doc-tests.rkt b/collects/plot/tests/doc-tests.rkt new file mode 100644 index 0000000000..78a19f36db --- /dev/null +++ b/collects/plot/tests/doc-tests.rkt @@ -0,0 +1,31 @@ +#lang racket + +(require plot/doc + scribble/manual + scribble/render + scribble/text-render + scribble/decode) + +(define (render-doc doc-part) + (define path (make-temporary-file "racket-doc-~a.txt" #f (current-directory))) + (dynamic-wind + (λ () (void)) + (λ () + (render (list (decode (list (declare-exporting) doc-part))) + (list path) + #:render-mixin render-mixin) + (file->lines path)) + (λ () (delete-file path)))) + +(define (display-doc doc-part) + (for ([line (in-list (render-doc doc-part))]) + (displayln line))) + +(display-doc (plot/dc:doc)) +(newline) +(display-doc (treeof:doc)) +(newline) +(display-doc (plot-background:doc)) +(newline) +(display-doc (known-point-symbols:doc)) +(newline) diff --git a/collects/plot/tests/isosurface-tests.rkt b/collects/plot/tests/isosurface-tests.rkt index ba0bd48753..e1a79b46b3 100644 --- a/collects/plot/tests/isosurface-tests.rkt +++ b/collects/plot/tests/isosurface-tests.rkt @@ -35,7 +35,9 @@ (time (define saddle (λ (x y z) (- (sqr x) (* 1/2 (+ (sqr y) (sqr z)))))) - (plot3d (isosurface3d saddle -1/4 #:color 0 #:line-color 0 #:alpha 7/8 + (plot3d (isosurface3d saddle -1/4 #:samples 21 + #:color "black" #:style 3 + #:alpha 1 #:label "d = -1/4") #:x-min -2 #:x-max 2 #:y-min -2 #:y-max 2 diff --git a/collects/plot/tests/plot2d-tests.rkt b/collects/plot/tests/plot2d-tests.rkt index cbc8647739..d48011b98b 100644 --- a/collects/plot/tests/plot2d-tests.rkt +++ b/collects/plot/tests/plot2d-tests.rkt @@ -196,6 +196,29 @@ #:y-label "Widgetyness" #:legend-anchor 'bottom-right)) +(time + (plot (stacked-histogram '(#(a (1 1 1)) #(b (1.5 3)) #(c ()) #(d (1/2))) + #:labels '("Red" #f "Blue")))) + +(time + (parameterize ([discrete-histogram-gap 0] + [discrete-histogram-skip 3] + [rectangle-line-width 2]) + (plot (list (discrete-histogram '(#(a 1) #(b 2.5) #(c 2)) #:label "Blue") + (discrete-histogram '(#(a 2) #(b 4) #(c 1)) #:x-min 2/3 #:color 1 #:line-color 1 + #:label "Red") + (discrete-histogram '(#(a 3) #(b 3) #(c 2.5)) #:x-min 4/3 #:color 2 #:line-color 2 + #:label "Green"))))) + +(time + (parameterize ([discrete-histogram-gap 0] + [discrete-histogram-skip 2] + [stacked-histogram-line-widths '(3)]) + (plot (list (stacked-histogram '(#(a (0.2 1)) #(b (2.5 1.2)) #(c (2 0)))) + (stacked-histogram '(#(a (2 1)) #(b (1.1 0.9)) #(c (1 1.1))) #:x-min 7/8 + #:colors '(3 4) + #:line-colors '(3 4)))))) + (time (plot (rectangles (map vector @@ -285,7 +308,7 @@ (time (plot (list (tick-grid) (contour-intervals f1 -5 2 -5 2 #:levels '(0.25 0.5 0.75 1.0 1.25 1.5 1.75) - #:colors default-contour-colors + #:colors (compose default-contour-colors (curry map ivl-center)) #:styles '(0 1 2 3 4 5 6) #:contour-styles '(transparent) #:label "z") diff --git a/collects/plot/tests/plot3d-tests.rkt b/collects/plot/tests/plot3d-tests.rkt index df2e078f87..0df0c9da70 100644 --- a/collects/plot/tests/plot3d-tests.rkt +++ b/collects/plot/tests/plot3d-tests.rkt @@ -20,6 +20,10 @@ (plot3d (points3d '(#(0.1 0.6 0.3))) #:x-min 0 #:x-max 1 #:y-min 0 #:y-max 1 #:z-min 0 #:z-max 1)) +(time + (plot3d (vector-field3d (λ (x y z) (vector x z y)) -2 2 -2 2 -2 2 + #:line-width 3))) + (time (define x-ivls (bounds->intervals (linear-seq 2 8 10))) (define y-ivls (bounds->intervals (linear-seq -5 5 10)))