From 596e8b37757fe487a341ee684b9850ff4221c14b Mon Sep 17 00:00:00 2001 From: Neil Toronto Date: Thu, 3 Nov 2011 11:59:27 -0600 Subject: [PATCH] Polar axes use r ticks Removed r and d transforms (r needs design, d is useless) --- collects/plot/common/axis-transform.rkt | 2 +- collects/plot/common/parameters.rkt | 33 +++---- collects/plot/common/plot-element.rkt | 19 ++-- collects/plot/common/sample.rkt | 62 +++++++----- collects/plot/common/samplers.rkt | 20 ++++ collects/plot/contracted/axis-transform.rkt | 2 +- collects/plot/contracted/parameters.rkt | 3 +- collects/plot/contracted/sample.rkt | 24 +++-- collects/plot/contracted/samplers.rkt | 7 +- collects/plot/plot2d/area.rkt | 4 +- collects/plot/plot2d/contour.rkt | 28 ++---- collects/plot/plot2d/decoration.rkt | 27 ++--- collects/plot/plot2d/line.rkt | 4 +- collects/plot/plot3d/area.rkt | 6 +- collects/plot/plot3d/contour.rkt | 12 +-- collects/plot/plot3d/isosurface.rkt | 19 ++-- collects/plot/tests/contour-labels-test.rkt | 103 -------------------- 17 files changed, 143 insertions(+), 232 deletions(-) delete mode 100644 collects/plot/tests/contour-labels-test.rkt diff --git a/collects/plot/common/axis-transform.rkt b/collects/plot/common/axis-transform.rkt index a0df27155a..3b45d7bc3d 100644 --- a/collects/plot/common/axis-transform.rkt +++ b/collects/plot/common/axis-transform.rkt @@ -23,7 +23,7 @@ (defthing id-function invertible-function? (invertible-function (λ (x) x) (λ (x) x))) -(defproc (apply-transform [t axis-transform/c] [x-min real?] [x-max real?]) invertible-function? +(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 diff --git a/collects/plot/common/parameters.rkt b/collects/plot/common/parameters.rkt index b2a65975dd..b60a6bd899 100644 --- a/collects/plot/common/parameters.rkt +++ b/collects/plot/common/parameters.rkt @@ -43,7 +43,7 @@ (defparam plot-x-max-ticks exact-positive-integer? 5) (defparam plot-y-max-ticks exact-positive-integer? 5) (defparam plot-z-max-ticks exact-positive-integer? 8) -(defparam plot-d-max-ticks exact-positive-integer? 5) +(defparam plot-d-max-ticks exact-positive-integer? 6) (defparam plot-r-max-ticks exact-positive-integer? 8) (defparam plot-x-far-max-ticks exact-positive-integer? 5) @@ -131,32 +131,23 @@ (defparam plot-x-transform axis-transform/c id-transform) (defparam plot-y-transform axis-transform/c id-transform) (defparam plot-z-transform axis-transform/c id-transform) -(defparam plot-d-transform axis-transform/c id-transform) -(defparam plot-r-transform axis-transform/c id-transform) (defparam plot-x-ticks ticks? (linear-ticks)) (defparam plot-y-ticks ticks? (linear-ticks)) (defparam plot-z-ticks ticks? (linear-ticks)) -(defparam plot-d-ticks ticks? (linear-ticks)) +(defparam plot-d-ticks ticks? (linear-ticks #:divisors '(1 2 4 5))) (defparam plot-r-ticks ticks? (linear-ticks)) (defparam plot-x-far-ticks ticks? (ticks-mimic plot-x-ticks)) (defparam plot-y-far-ticks ticks? (ticks-mimic plot-y-ticks)) (defparam plot-z-far-ticks ticks? (ticks-mimic plot-z-ticks)) -(struct axis (transform ticks) #:transparent) -(define-parameter-group plot-d-axis (plot-d-transform plot-d-ticks) #:struct axis) -(define-parameter-group plot-r-axis (plot-r-transform plot-r-ticks) #:struct axis) +(struct axis (transform ticks far-ticks) #:transparent) +(define-parameter-group plot-x-axis (plot-x-transform plot-x-ticks plot-x-far-ticks) #:struct axis) +(define-parameter-group plot-y-axis (plot-y-transform plot-y-ticks plot-y-far-ticks) #:struct axis) +(define-parameter-group plot-z-axis (plot-z-transform plot-z-ticks plot-z-far-ticks) #:struct axis) -(struct dual-axis (transform ticks far-ticks) #:transparent) -(define-parameter-group plot-x-axis (plot-x-transform plot-x-ticks plot-x-far-ticks) - #:struct dual-axis) -(define-parameter-group plot-y-axis (plot-y-transform plot-y-ticks plot-y-far-ticks) - #:struct dual-axis) -(define-parameter-group plot-z-axis (plot-z-transform plot-z-ticks plot-z-far-ticks) - #:struct dual-axis) - -(define-parameter-group plot-axes (plot-x-axis plot-y-axis plot-z-axis plot-d-axis plot-r-axis) +(define-parameter-group plot-axes (plot-x-axis plot-y-axis plot-z-axis plot-d-ticks plot-r-ticks) #:struct list) (defproc (default-x-ticks [x-min real?] [x-max real?]) (listof tick?) #:document-body @@ -276,12 +267,10 @@ (defparam x-axis-ticks? boolean? #t) (defparam y-axis-ticks? boolean? #t) (defparam z-axis-ticks? boolean? #t) -(defparam polar-axes-ticks? boolean? #t) (defparam x-axis-labels? boolean? #f) (defparam y-axis-labels? boolean? #f) (defparam z-axis-labels? boolean? #f) -(defparam polar-axes-labels? boolean? #t) (defparam x-axis-far? boolean? #f) (defparam y-axis-far? boolean? #f) @@ -290,9 +279,11 @@ (defparam x-axis-alpha (real-in 0 1) 1) (defparam y-axis-alpha (real-in 0 1) 1) (defparam z-axis-alpha (real-in 0 1) 1) -(defparam polar-axes-alpha (real-in 0 1) 1/2) -(defparam polar-axes-number exact-positive-integer? 12) +(defparam polar-axes-number exact-nonnegative-integer? 12) +(defparam polar-axes-ticks? boolean? #t) +(defparam polar-axes-labels? boolean? #t) +(defparam polar-axes-alpha (real-in 0 1) 1/2) (defparam label-anchor anchor/c 'left) (defparam label-angle real? 0) @@ -324,7 +315,7 @@ (color-seq* (list (->pen-color 5) (->pen-color 0) (->pen-color 1)) (length zs))) -(defparam isosurface-levels exact-positive-integer? 3) +(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)) diff --git a/collects/plot/common/plot-element.rkt b/collects/plot/common/plot-element.rkt index 17c9ee4c99..b96bc4dfe6 100644 --- a/collects/plot/common/plot-element.rkt +++ b/collects/plot/common/plot-element.rkt @@ -38,10 +38,8 @@ (match-define (vector xi yi) r) (cond [(ivl-known? xi) (match-define (ivl x-min x-max) xi) - (match-define (list xs ys) (f x-min x-max samples)) - (define rys (filter regular? ys)) - (cond [(not (empty? rys)) (vector xi (ivl (apply min* rys) (apply max* rys)))] - [else r])] + (match-define (sample xs ys y-min y-max) (f x-min x-max samples)) + (vector xi (ivl y-min y-max))] [else r]))) (defproc (inverse-bounds-fun [f sampler/c] [samples exact-nonnegative-integer?]) bounds-fun/c @@ -49,10 +47,8 @@ (match-define (vector xi yi) r) (cond [(ivl-known? yi) (match-define (ivl y-min y-max) yi) - (match-define (list ys xs) (f y-min y-max samples)) - (define rxs (filter regular? xs)) - (cond [(not (empty? rxs)) (vector (ivl (apply min* rxs) (apply max* rxs)) yi)] - [else r])] + (match-define (sample ys xs x-min x-max) (f y-min y-max samples)) + (vector (ivl x-min x-max) yi)] [else r]))) (defproc (function-interval-bounds-fun [f1 sampler/c] [f2 sampler/c] @@ -73,10 +69,9 @@ (cond [(and (ivl-known? xi) (ivl-known? yi)) (match-define (ivl x-min x-max) xi) (match-define (ivl y-min y-max) yi) - (match-define (list xs ys zss) (f x-min x-max samples y-min y-max samples)) - (define zs (filter regular? (2d-sample->list zss))) - (cond [(not (empty? zs)) (vector xi yi (ivl (apply min* zs) (apply max* zs)))] - [else r])] + (match-define (2d-sample xs ys zss z-min z-max) + (f x-min x-max samples y-min y-max samples)) + (vector xi yi (ivl z-min z-max))] [else r]))) ;; =================================================================================================== diff --git a/collects/plot/common/sample.rkt b/collects/plot/common/sample.rkt index 1f7f63a4b0..74dc285c29 100644 --- a/collects/plot/common/sample.rkt +++ b/collects/plot/common/sample.rkt @@ -53,7 +53,7 @@ [transform axis-transform/c] [#:start? start? boolean? #t] [#:end? end? boolean? #t]) (listof real?) - (match-define (invertible-function _ finv) (apply-transform transform start end)) + (match-define (invertible-function _ finv) (apply-axis-transform transform start end)) (map finv (linear-seq start end num #:start? start? #:end? end?))) (struct mapped-function (f fmap) #:transparent @@ -70,21 +70,21 @@ ;; =================================================================================================== ;; Making memoized samplers -(defcontract sample/c (list/c (listof real?) (listof real?))) -(defcontract sampler/c (real? real? exact-nonnegative-integer? . -> . sample/c)) +(struct sample (xs ys y-min y-max) #:transparent) +(struct 2d-sample (xs ys zss z-min z-max) #:transparent) +(struct 3d-sample (xs ys zs dsss d-min d-max) #:transparent) + +(defcontract sample/c (list/c (listof real?) (listof real?))) +(defcontract sampler/c (real? real? exact-nonnegative-integer? . -> . sample?)) -(defcontract 2d-sample/c (list/c (listof real?) (listof real?) - (vectorof (vectorof real?)))) (defcontract 2d-sampler/c (real? real? exact-nonnegative-integer? real? real? exact-nonnegative-integer? - . -> . 2d-sample/c)) + . -> . 2d-sample?)) -(defcontract 3d-sample/c (list/c (listof real?) (listof real?) (listof real?) - (vectorof (vectorof (vectorof real?))))) (defcontract 3d-sampler/c (real? real? exact-nonnegative-integer? real? real? exact-nonnegative-integer? real? real? exact-nonnegative-integer? - . -> . 3d-sample/c)) + . -> . 3d-sample?)) (defproc (make-function->sampler [transform-thnk (-> axis-transform/c)] ) ((real? . -> . real?) . -> . sampler/c) @@ -95,7 +95,12 @@ (hash-ref! memo (vector x-min x-max x-samples tx) (λ () (define xs (nonlinear-seq x-min x-max x-samples tx)) - (list xs (map* f xs))))))) + (define ys (map* f xs)) + (define rys (filter regular? ys)) + (define-values (y-min y-max) + (cond [(empty? rys) (values #f #f)] + [else (values (apply min* rys) (apply max* rys))])) + (sample xs ys y-min y-max)))))) (defproc (make-2d-function->sampler [transform-x-thnk (-> axis-transform/c)] [transform-y-thnk (-> axis-transform/c)] @@ -109,9 +114,16 @@ (λ () (define xs (nonlinear-seq x-min x-max x-samples tx)) (define ys (nonlinear-seq y-min y-max y-samples ty)) - (list xs ys (for/vector #:length y-samples ([y (in-list ys)]) + (define z-min #f) + (define z-max #f) + (define zss (for/vector #:length y-samples ([y (in-list ys)]) (for/vector #:length x-samples ([x (in-list xs)]) - (f x y))))))))) + (let ([z (f x y)]) + (when (regular? z) + (unless (and z-min (z . >= . z-min)) (set! z-min z)) + (unless (and z-max (z . <= . z-max)) (set! z-max z))) + z)))) + (2d-sample xs ys zss z-min z-max)))))) (defproc (make-3d-function->sampler [transform-x-thnk (-> axis-transform/c)] [transform-y-thnk (-> axis-transform/c)] @@ -130,18 +142,14 @@ (define xs (nonlinear-seq x-min x-max x-samples tx)) (define ys (nonlinear-seq y-min y-max y-samples ty)) (define zs (nonlinear-seq z-min z-max z-samples tz)) - (list xs ys zs (for/vector #:length z-samples ([z (in-list zs)]) - (for/vector #:length y-samples ([y (in-list ys)]) - (for/vector #:length x-samples ([x (in-list xs)]) - (f x y z)))))))))) - -(defproc (2d-sample->list [zss (vectorof (vectorof real?))]) (listof real?) - (for*/list ([zs (in-vector zss)] - [z (in-vector zs)]) - z)) - -(defproc (3d-sample->list [dsss (vectorof (vectorof (vectorof real?)))]) (listof real?) - (for*/list ([dss (in-vector dsss)] - [ds (in-vector dss)] - [d (in-vector ds)]) - d)) + (define d-min #f) + (define d-max #f) + (define dsss (for/vector #:length z-samples ([z (in-list zs)]) + (for/vector #:length y-samples ([y (in-list ys)]) + (for/vector #:length x-samples ([x (in-list xs)]) + (let ([d (f x y z)]) + (when (regular? d) + (unless (and d-min (d . >= . d-min)) (set! d-min d)) + (unless (and d-max (d . <= . d-max)) (set! d-max d))) + d))))) + (3d-sample xs ys zs dsss d-min d-max)))))) diff --git a/collects/plot/common/samplers.rkt b/collects/plot/common/samplers.rkt index 515320d911..9334b24575 100644 --- a/collects/plot/common/samplers.rkt +++ b/collects/plot/common/samplers.rkt @@ -49,3 +49,23 @@ (match-define (list (pre-tick zs majors) ...) all-ts) (define labels (format z-min z-max all-ts)) (map tick zs majors labels)) + +(defproc (isosurface-ticks [d-min real?] [d-max real?] + [levels (or/c 'auto exact-positive-integer? (listof real?))] + ) (listof tick?) + (define epsilon (expt 10 (- (digits-for-range d-min d-max)))) + (match-define (ticks layout format) (plot-d-ticks)) + (define ts + (cond [(eq? levels 'auto) (filter pre-tick-major? (layout d-min d-max (plot-d-max-ticks)))] + [else (define ds (cond [(list? levels) (filter (λ (d) (<= d-min d d-max)) levels)] + [else (linear-seq d-min d-max levels #:start? #f #:end? #f)])) + (map (λ (d) (pre-tick d #t)) ds)])) + (define all-ts + (let* ([ts (cond [((abs (- d-min (pre-tick-value (first ts)))) . >= . epsilon) ts] + [else (rest ts)])] + [ts (cond [((abs (- d-max (pre-tick-value (last ts)))) . >= . epsilon) ts] + [else (take ts (- (length ts) 1))])]) + ts)) + (match-define (list (pre-tick ds majors) ...) all-ts) + (define labels (format d-min d-max all-ts)) + (map tick ds majors labels)) diff --git a/collects/plot/contracted/axis-transform.rkt b/collects/plot/contracted/axis-transform.rkt index a18ed776b2..9f89edb393 100644 --- a/collects/plot/contracted/axis-transform.rkt +++ b/collects/plot/contracted/axis-transform.rkt @@ -8,7 +8,7 @@ (activate-contract-out id-function axis-transform/c id-transform - apply-transform + apply-axis-transform make-axis-transform axis-transform-compose axis-transform-append diff --git a/collects/plot/contracted/parameters.rkt b/collects/plot/contracted/parameters.rkt index eea24e58bd..b33a1b911f 100644 --- a/collects/plot/contracted/parameters.rkt +++ b/collects/plot/contracted/parameters.rkt @@ -29,8 +29,7 @@ plot-x-transform plot-x-ticks plot-x-far-ticks plot-y-transform plot-y-ticks plot-y-far-ticks plot-z-transform plot-z-ticks plot-z-far-ticks - plot-d-transform plot-d-ticks - plot-r-transform plot-r-ticks + plot-d-ticks plot-r-ticks ;; Renderer parameters line-samples line-color line-width line-style line-alpha interval-color interval-style diff --git a/collects/plot/contracted/sample.rkt b/collects/plot/contracted/sample.rkt index d61d826af5..02da226644 100644 --- a/collects/plot/contracted/sample.rkt +++ b/collects/plot/contracted/sample.rkt @@ -3,14 +3,26 @@ (require racket/contract unstable/latent-contract) (require "../common/sample.rkt") -(provide (activate-contract-out build-linear-seq linear-seq linear-seq* nonlinear-seq - sample/c sampler/c - 2d-sample/c 2d-sampler/c - 3d-sample/c 3d-sampler/c +(provide (contract-out (struct sample ([xs (listof real?)] + [ys (listof real?)] + [y-min (or/c real? #f)] + [y-max (or/c real? #f)])) + (struct 2d-sample ([xs (listof real?)] + [ys (listof real?)] + [zss (vectorof (vectorof real?))] + [z-min (or/c real? #f)] + [z-max (or/c real? #f)])) + (struct 3d-sample ([xs (listof real?)] + [ys (listof real?)] + [zs (listof real?)] + [dsss (vectorof (vectorof (vectorof real?)))] + [d-min (or/c real? #f)] + [d-max (or/c real? #f)]))) + (activate-contract-out build-linear-seq linear-seq linear-seq* nonlinear-seq + sampler/c 2d-sampler/c 3d-sampler/c make-function->sampler make-2d-function->sampler - make-3d-function->sampler - 2d-sample->list 3d-sample->list) + make-3d-function->sampler) (contract-out (struct mapped-function ([f (any/c . -> . any/c)] [fmap ((listof any/c) . -> . (listof any/c))]))) map*) diff --git a/collects/plot/contracted/samplers.rkt b/collects/plot/contracted/samplers.rkt index 9a650652b8..9cd7a91028 100644 --- a/collects/plot/contracted/samplers.rkt +++ b/collects/plot/contracted/samplers.rkt @@ -3,8 +3,9 @@ (require unstable/latent-contract) (require "../common/samplers.rkt") -(provide (activate-contract-out contour-ticks - function->sampler +(provide (activate-contract-out function->sampler inverse->sampler 2d-function->sampler - 3d-function->sampler)) + 3d-function->sampler + contour-ticks + isosurface-ticks)) diff --git a/collects/plot/plot2d/area.rkt b/collects/plot/plot2d/area.rkt index e5e9315066..82633198ba 100644 --- a/collects/plot/plot2d/area.rkt +++ b/collects/plot/plot2d/area.rkt @@ -90,8 +90,8 @@ (and (equal? (plot-x-transform) id-transform) (equal? (plot-y-transform) id-transform))) - (match-define (invertible-function fx _) (apply-transform (plot-x-transform) x-min x-max)) - (match-define (invertible-function fy _) (apply-transform (plot-y-transform) y-min y-max)) + (match-define (invertible-function fx _) (apply-axis-transform (plot-x-transform) x-min x-max)) + (match-define (invertible-function fy _) (apply-axis-transform (plot-y-transform) y-min y-max)) (define plot->view (cond [identity-transforms? (λ (v) v)] diff --git a/collects/plot/plot2d/contour.rkt b/collects/plot/plot2d/contour.rkt index 39f1efc06d..4ebffccba4 100644 --- a/collects/plot/plot2d/contour.rkt +++ b/collects/plot/plot2d/contour.rkt @@ -13,12 +13,10 @@ ;; =================================================================================================== ;; One contour line -(define ((isoline-render-proc f z samples color width style alpha label) area) +(define ((isoline-render-proc g z samples color width style alpha label) area) (define-values (x-min x-max y-min y-max) (send area get-bounds)) - (match-define (list xs ys zss) (f x-min x-max samples y-min y-max samples)) - (define zs (2d-sample->list zss)) - (define z-min (apply min* zs)) - (define z-max (apply max* zs)) + (match-define (2d-sample xs ys zss z-min z-max) + (g x-min x-max samples y-min y-max samples)) (when (<= z-min z z-max) (send area set-alpha alpha) @@ -61,12 +59,8 @@ (define ((contours-render-proc g levels samples colors widths styles alphas label) area) (let/ec return (define-values (x-min x-max y-min y-max) (send area get-bounds)) - (match-define (list xs ys zss) (g x-min x-max samples y-min y-max samples)) - - (define-values (z-min z-max) - (let ([zs (filter regular? (2d-sample->list zss))]) - (when (empty? zs) (return empty)) - (values (apply min* zs) (apply max* zs)))) + (match-define (2d-sample xs ys zss z-min z-max) + (g x-min x-max samples y-min y-max samples)) (match-define (list (tick zs _ labels) ...) (contour-ticks z-min z-max levels #f)) @@ -120,16 +114,12 @@ ;; Contour intervals (define ((contour-intervals-render-proc - f levels samples colors styles contour-colors contour-widths contour-styles alphas label) + g levels samples colors styles contour-colors contour-widths contour-styles alphas label) area) (let/ec return (define-values (x-min x-max y-min y-max) (send area get-bounds)) - (match-define (list xs ys zss) (f x-min x-max samples y-min y-max samples)) - - (define-values (z-min z-max) - (let ([flat-zs (filter regular? (2d-sample->list zss))]) - (when (empty? flat-zs) (return empty)) - (values (apply min* flat-zs) (apply max* flat-zs)))) + (match-define (2d-sample xs ys zss z-min z-max) + (g x-min x-max samples y-min y-max samples)) (match-define (list (tick zs _ labels) ...) (contour-ticks z-min z-max levels #t)) @@ -181,7 +171,7 @@ (send area set-alpha alpha) (draw-polys)])) - ((contours-render-proc f levels samples contour-colors contour-widths contour-styles alphas #f) + ((contours-render-proc g levels samples contour-colors contour-widths contour-styles alphas #f) area) (cond [label (contour-intervals-legend-entries diff --git a/collects/plot/plot2d/decoration.rkt b/collects/plot/plot2d/decoration.rkt index aa34f9024b..e85cb4066b 100644 --- a/collects/plot/plot2d/decoration.rkt +++ b/collects/plot/plot2d/decoration.rkt @@ -23,7 +23,7 @@ (define radius (if ticks? (* 1/2 (plot-tick-size)) 0)) (send area set-alpha alpha) - (send area set-minor-pen) + (send area set-major-pen) (send area put-line (vector x-min y) (vector x-max y)) (when ticks? @@ -56,7 +56,7 @@ (define radius (if ticks? (* 1/2 (plot-tick-size)) 0)) (send area set-alpha alpha) - (send area set-minor-pen) + (send area set-major-pen) (send area put-line (vector x y-min) (vector x y-max)) (when ticks? @@ -125,7 +125,7 @@ ;; Draw the tick lines (for ([t (in-list ts)]) (match-define (tick r major? label) t) - (if major? (send area set-major-pen) (send area set-minor-pen 'long-dash)) + (if major? (send area set-minor-pen) (send area set-minor-pen 'long-dash)) (define pts (for/list ([θ (in-list (linear-seq 0 (* 2 pi) 500))]) (vector (* r (cos θ)) (* r (sin θ))))) (send area put-lines pts)) @@ -143,22 +143,23 @@ (send area put-text label (vector (* r (cos mθ)) (* r (sin mθ))) 'center 0 #:outline? #t))))) -(define ((polar-axes-render-proc num ticks? labels? alpha) area) +(define (draw-polar-axis-lines num area) (define-values (x-min x-max y-min y-max) (send area get-bounds)) (define-values (θs r-mins r-maxs) (build-polar-axes num x-min x-max y-min y-max)) - ;; Draw the axes - (send area set-alpha alpha) + (send area set-major-pen) (for ([θ (in-list θs)] [r-min (in-list r-mins)] [r-max (in-list r-maxs)]) (send area put-line (vector (* r-min (cos θ)) (* r-min (sin θ))) - (vector (* r-max (cos θ)) (* r-max (sin θ))))) - ;; Draw the ticks - (when ticks? (draw-polar-axis-ticks num labels? area)) - ;; No legend + (vector (* r-max (cos θ)) (* r-max (sin θ)))))) + +(define ((polar-axes-render-proc num ticks? labels? alpha) area) + (send area set-alpha alpha) + (when (num . > . 0) (draw-polar-axis-lines num area)) + (when ticks? (draw-polar-axis-ticks (if (num . > . 0) num 12) labels? area)) empty) -(defproc (polar-axes [#:number num exact-positive-integer? (polar-axes-number)] +(defproc (polar-axes [#:number num exact-nonnegative-integer? (polar-axes-number)] [#:ticks? ticks? boolean? (polar-axes-ticks?)] [#:labels? labels? boolean? (polar-axes-labels?)] [#:alpha alpha (real-in 0 1) (polar-axes-alpha)]) renderer2d? @@ -175,7 +176,7 @@ (send area set-alpha 1/2) (for ([t (in-list x-ticks)]) (match-define (tick x major? _) t) - (if major? (send area set-major-pen) (send area set-minor-pen 'long-dash)) + (if major? (send area set-minor-pen) (send area set-minor-pen 'long-dash)) (send area put-line (vector x y-min) (vector x y-max))) empty) @@ -188,7 +189,7 @@ (send area set-alpha 1/2) (for ([t (in-list y-ticks)]) (match-define (tick y major? _) t) - (if major? (send area set-major-pen) (send area set-minor-pen 'long-dash)) + (if major? (send area set-minor-pen) (send area set-minor-pen 'long-dash)) (send area put-line (vector x-min y) (vector x-max y))) empty) diff --git a/collects/plot/plot2d/line.rkt b/collects/plot/plot2d/line.rkt index f034d3e3ce..02588914c5 100644 --- a/collects/plot/plot2d/line.rkt +++ b/collects/plot/plot2d/line.rkt @@ -78,7 +78,7 @@ (define ((function-render-proc f samples color width style alpha label) area) (define x-min (send area get-x-min)) (define x-max (send area get-x-max)) - (match-define (list xs ys) (f x-min x-max samples)) + (match-define (sample xs ys y-min y-max) (f x-min x-max samples)) (send area set-alpha alpha) (send area set-pen color width style) @@ -109,7 +109,7 @@ (define ((inverse-render-proc f samples color width style alpha label) area) (define y-min (send area get-y-min)) (define y-max (send area get-y-max)) - (match-define (list ys xs) (f y-min y-max samples)) + (match-define (list ys xs x-min x-max) (f y-min y-max samples)) (send area set-alpha alpha) (send area set-pen color width style) diff --git a/collects/plot/plot3d/area.rkt b/collects/plot/plot3d/area.rkt index ff233c176a..c2b9514dcf 100644 --- a/collects/plot/plot3d/area.rkt +++ b/collects/plot/plot3d/area.rkt @@ -103,9 +103,9 @@ (equal? (plot-y-transform) id-transform) (equal? (plot-z-transform) id-transform))) - (match-define (invertible-function fx _) (apply-transform (plot-x-transform) x-min x-max)) - (match-define (invertible-function fy _) (apply-transform (plot-y-transform) y-min y-max)) - (match-define (invertible-function fz _) (apply-transform (plot-z-transform) z-min z-max)) + (match-define (invertible-function fx _) (apply-axis-transform (plot-x-transform) x-min x-max)) + (match-define (invertible-function fy _) (apply-axis-transform (plot-y-transform) y-min y-max)) + (match-define (invertible-function fz _) (apply-axis-transform (plot-z-transform) z-min z-max)) (define axis-transform (cond diff --git a/collects/plot/plot3d/contour.rkt b/collects/plot/plot3d/contour.rkt index 774577bcff..7a089730be 100644 --- a/collects/plot/plot3d/contour.rkt +++ b/collects/plot/plot3d/contour.rkt @@ -14,8 +14,8 @@ (define ((contour3d-render-proc f z samples color width style alpha label) area) (define-values (x-min x-max y-min y-max z-min z-max) (send area get-bounds)) - (match-define (list xs ys zss) (f x-min x-max (animated-samples samples) - y-min y-max (animated-samples samples))) + (match-define (2d-sample xs ys zss _z-min _z-max) + (f x-min x-max (animated-samples samples) y-min y-max (animated-samples samples))) (when (<= z-min z z-max) (send area put-alpha alpha) @@ -64,8 +64,8 @@ (define ((contours3d-render-proc f levels samples colors widths styles alphas label) area) (define-values (x-min x-max y-min y-max z-min z-max) (send area get-bounds)) - (match-define (list xs ys zss) (f x-min x-max (animated-samples samples) - y-min y-max (animated-samples samples))) + (match-define (2d-sample xs ys zss _z-min _z-max) + (f x-min x-max (animated-samples samples) y-min y-max (animated-samples samples))) (match-define (list (tick zs _ labels) ...) (contour-ticks z-min z-max levels #f)) @@ -128,8 +128,8 @@ contour-colors contour-widths contour-styles alphas label) area) (define-values (x-min x-max y-min y-max z-min z-max) (send area get-bounds)) - (match-define (list xs ys zss) (f x-min x-max (animated-samples samples) - y-min y-max (animated-samples samples))) + (match-define (2d-sample xs ys zss _z-min _z-max) + (f x-min x-max (animated-samples samples) y-min y-max (animated-samples samples))) (match-define (list (tick zs _ labels) ...) (contour-ticks z-min z-max levels #t)) diff --git a/collects/plot/plot3d/isosurface.rkt b/collects/plot/plot3d/isosurface.rkt index 21126326f8..c765d5b1c3 100644 --- a/collects/plot/plot3d/isosurface.rkt +++ b/collects/plot/plot3d/isosurface.rkt @@ -17,7 +17,7 @@ (define ((isosurface3d-render-proc f d samples color line-color line-width line-style alpha label) area) (define-values (x-min x-max y-min y-max z-min z-max) (send area get-bounds)) - (match-define (list xs ys zs dsss) + (match-define (3d-sample xs ys zs dsss d-min d-max) (f x-min x-max (animated-samples samples) y-min y-max (animated-samples samples) z-min z-max (animated-samples samples))) @@ -86,23 +86,19 @@ f rd-min rd-max levels samples colors line-colors line-widths line-styles alphas label) area) (define-values (x-min x-max y-min y-max z-min z-max) (send area get-bounds)) - (match-define (list xs ys zs dsss) + (match-define (3d-sample xs ys zs dsss fd-min fd-max) (f x-min x-max (animated-samples samples) y-min y-max (animated-samples samples) z-min z-max (animated-samples samples))) - (define-values (fd-min fd-max) - (let ([regular-ds (filter regular? (3d-sample->list dsss))]) - (values (if (empty? regular-ds) #f (apply min* regular-ds)) - (if (empty? regular-ds) #f (apply max* regular-ds))))) - (define d-min (if rd-min rd-min fd-min)) (define d-max (if rd-max rd-max fd-max)) (cond [(not (and d-min d-max)) empty] [else - (define ds (linear-seq d-min d-max levels #:start? (and rd-min #t) #:end? (and rd-max #t))) + (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))] @@ -156,7 +152,8 @@ [y-min (or/c real? #f) #f] [y-max (or/c real? #f) #f] [z-min (or/c real? #f) #f] [z-max (or/c real? #f) #f] [#:d-min d-min (or/c real? #f) #f] [#:d-max d-max (or/c real? #f) #f] - [#:levels levels exact-positive-integer? (isosurface-levels)] + [#: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)] @@ -175,8 +172,8 @@ (define ((polar3d-render-proc f g samples color line-color line-width line-style alpha label) area) (define-values (x-min x-max y-min y-max z-min z-max) (send area get-bounds)) - (match-define (list xs ys zs dsss) - (g x-min x-max (animated-samples samples) + (match-define (3d-sample xs ys zs dsss d-min d-max) + (f x-min x-max (animated-samples samples) y-min y-max (animated-samples samples) z-min z-max (animated-samples samples))) diff --git a/collects/plot/tests/contour-labels-test.rkt b/collects/plot/tests/contour-labels-test.rkt deleted file mode 100644 index c4a86348ee..0000000000 --- a/collects/plot/tests/contour-labels-test.rkt +++ /dev/null @@ -1,103 +0,0 @@ -#lang racket - -(require plot plot/utils plot/common/contract-doc) - -(struct label-params (score z z-ivl str v) #:transparent) - -(define (dnorm x m s^2) - (* (/ 1 (sqrt (* 2 pi s^2))) (exp (* -1/2 (/ (sqr (- x m)) s^2))))) - -(define ((contour-labels-render-proc f g levels samples color size family alpha) area) - (let/ec return - (define-values (x-min x-max y-min y-max) (send area get-bounds)) - (match-define (list xs ys zss) (g x-min x-max samples y-min y-max samples)) - - (define-values (z-min z-max) - (let ([zs (filter regular? (2d-sample->list zss))]) - (when (empty? zs) (return empty)) - (values (apply min* zs) (apply max* zs)))) - - (define z-ticks (contour-ticks z-min z-max levels #f)) - (define zs (map pre-tick-value z-ticks)) - - (send area set-text-foreground color) - (send area set-font size family) - (send area set-alpha alpha) - (define labels - (append* - (for/list ([z-tick (in-list z-ticks)]) - (match-define (tick z major? label) z-tick) - (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)] - #:when #t - [line (in-list (heights->lines xa xb ya yb z z1 z2 z3 z4))]) - (match-define (vector x y _) (vcenter line)) - (label-params 0 z - (ivl (min* z1 z2 z3 z4) (max* z1 z2 z3 z4)) - label (send area plot->dc (vector x y))))))) - - (match-define (vector dc-x-min dc-y-min) (send area plot->dc (vector x-min y-min))) - (match-define (vector dc-x-max dc-y-max) (send area plot->dc (vector x-max y-max))) - - (define x-sigma (/ (plot-width) samples)) - (define y-sigma (/ (plot-height) samples)) - (define z-sigma (/ (- z-max z-min) (length z-ticks))) - - (define new-labels - (for/fold ([labels labels]) ([keep (in-list (list 4))]) - (define new-labels - (for/list ([l1 (in-list labels)]) - (match-define (label-params s1 z1 (ivl z1-min z1-max) str1 (vector x1 y1)) l1) - (define new-score - (apply + (for/list ([l2 (in-list labels)]) - (match-define (label-params s2 z2 _ str2 (vector x2 y2)) l2) - (* (exp (* -1/2 (sqr (/ (- s1 s2) 1)))) - (exp (* -1/2 (sqr (/ (- x1 x2) x-sigma)))) - (exp (* -1/2 (sqr (/ (- y1 y2) y-sigma)))) - (exp (* -1/2 (sqr (/ (- z1 z2) z-sigma)))) - )))) - (label-params new-score z1 (ivl z1-min z1-max) str1 (vector x1 y1)))) - (append* - (for/list ([z (in-list zs)]) - (define z-labels (sort (filter (λ (l) (= z (label-params-z l))) new-labels) - > #:key label-params-score)) - #;(define keep (min 4 (length z-labels) (round (* 1/8 (length z-labels))))) - (take z-labels (min keep (length z-labels))))))) - - (for ([label (in-list new-labels)]) - (match-define (label-params score z _ str (vector x y)) label) - (send area draw-text #;(real->plot-label score 3) str (vector x y) 'center 0 #:outline? #t)) - - empty)) - -(defproc (contour-labels - [f (real? real? . -> . real?)] - [x-min (or/c real? #f) #f] [x-max (or/c real? #f) #f] - [y-min (or/c real? #f) #f] [y-max (or/c 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)] - [#:color color plot-color/c (plot-foreground)] - [#:size size (>=/c 0) (plot-font-size)] - [#:family family font-family/c (plot-font-family)] - [#:alpha alpha (real-in 0 1) (label-alpha)] - ) renderer2d? - (define g (2d-function->sampler f)) - (renderer2d (vector (ivl x-min x-max) (ivl y-min y-max)) #f #f - (contour-labels-render-proc f g levels samples color size family alpha))) - -;(contour-samples 11) -;(plot-z-max-ticks 50) -#; -(parameterize (#;[plot-x-transform log-transform] - #;[plot-y-transform log-transform]) - (plot (list (contours (λ (x y) (sqrt (+ (sqr x) (sqr y)))) -1 4 -1 4) - (contour-labels (λ (x y) (sqrt (+ (sqr x) (sqr y))))))))