From 4ca0729a2fe16aa464b969569c1ad2cab1d206f3 Mon Sep 17 00:00:00 2001 From: Neil Toronto Date: Tue, 18 Oct 2011 13:05:12 -0600 Subject: [PATCH] Combined renderer structs and fixpoint bounds determination --- collects/plot/common/axis-transform.rkt | 5 +- collects/plot/common/contract.rkt | 10 + collects/plot/common/math.rkt | 82 ++++- collects/plot/common/renderer.rkt | 108 +++++++ collects/plot/common/vector.rkt | 75 ++++- collects/plot/compat.rkt | 4 +- collects/plot/deprecated.rkt | 7 +- collects/plot/main.rkt | 11 +- collects/plot/plot2d/bounds.rkt | 90 ------ collects/plot/plot2d/contour.rkt | 20 +- collects/plot/plot2d/decoration.rkt | 40 +-- collects/plot/plot2d/interval.rkt | 33 +- collects/plot/plot2d/kde.rkt | 2 +- collects/plot/plot2d/line.rkt | 23 +- collects/plot/plot2d/plot.rkt | 94 +++--- collects/plot/plot2d/point.rkt | 52 ++-- collects/plot/plot2d/rectangle.rkt | 30 +- collects/plot/plot2d/renderer.rkt | 58 ---- collects/plot/plot3d/bounds.rkt | 69 ----- collects/plot/plot3d/contour.rkt | 19 +- collects/plot/plot3d/isosurface.rkt | 32 +- collects/plot/plot3d/line.rkt | 10 +- collects/plot/plot3d/plot.rkt | 117 ++++--- collects/plot/plot3d/point.rkt | 12 +- collects/plot/plot3d/rectangle.rkt | 27 +- collects/plot/plot3d/renderer.rkt | 70 ----- collects/plot/plot3d/surface.rkt | 13 +- collects/plot/tests/axis-transform-tests.rkt | 2 +- collects/plot/tests/low-level-tests.rkt | 301 +++++++++++++++++++ collects/plot/tests/plot2d-tests.rkt | 24 +- collects/plot/tests/tick-tests.rkt | 42 +++ collects/plot/utils.rkt | 5 +- collects/tests/plot/run-tests.rkt | 74 ----- 33 files changed, 889 insertions(+), 672 deletions(-) create mode 100644 collects/plot/common/renderer.rkt delete mode 100644 collects/plot/plot2d/bounds.rkt delete mode 100644 collects/plot/plot2d/renderer.rkt delete mode 100644 collects/plot/plot3d/bounds.rkt delete mode 100644 collects/plot/plot3d/renderer.rkt create mode 100755 collects/plot/tests/low-level-tests.rkt delete mode 100755 collects/tests/plot/run-tests.rkt diff --git a/collects/plot/common/axis-transform.rkt b/collects/plot/common/axis-transform.rkt index b26f9cda51..d2ef2dd07e 100644 --- a/collects/plot/common/axis-transform.rkt +++ b/collects/plot/common/axis-transform.rkt @@ -2,7 +2,8 @@ (require racket/math racket/flonum racket/contract racket/match "math.rkt" - "contract.rkt" "contract-doc.rkt") + "contract.rkt" + "contract-doc.rkt") (provide (struct-out invertible-function) id-function @@ -11,6 +12,8 @@ apply-transform make-axis-transform axis-transform-compose + axis-transform-append + axis-transform-bound log-transform cbrt-transform hand-drawn-transform diff --git a/collects/plot/common/contract.rkt b/collects/plot/common/contract.rkt index 25bfee2efa..6126433795 100644 --- a/collects/plot/common/contract.rkt +++ b/collects/plot/common/contract.rkt @@ -67,3 +67,13 @@ (defcontract alphas/c (or/c (listof (real-in 0 1)) ((listof real?) . -> . (listof (real-in 0 1))))) + +(defcontract bounding-box-corner/c + (or/c (vector/c (or/c real? #f) (or/c real? #f)) + (vector/c (or/c real? #f) (or/c real? #f) (or/c real? #f)))) + +(defcontract bounds-function/c + (bounding-box-corner/c + bounding-box-corner/c + . -> . (values bounding-box-corner/c + bounding-box-corner/c))) diff --git a/collects/plot/common/math.rkt b/collects/plot/common/math.rkt index db41e784e2..a2cc78d391 100644 --- a/collects/plot/common/math.rkt +++ b/collects/plot/common/math.rkt @@ -7,18 +7,6 @@ (provide (all-defined-out)) -(define-struct ivl (min max) #:transparent - #:guard (λ (a b _) - (cond [(and (regular? a) (regular? b)) (values (min* a b) (max* a b))] - [else (values a b)]))) - -(defproc (bounds->intervals [xs (listof real?)]) (listof ivl?) - (cond [((length xs) . < . 2) (raise-type-error 'bounds->intervals "list with length >= 2" xs)] - [else - (for/list ([x1 (in-list xs)] - [x2 (in-list (rest xs))]) - (ivl x1 x2))])) - (define -pi (- pi)) (define 2pi (* 2 pi)) (define -1/2pi (* -1/2 pi)) @@ -171,3 +159,73 @@ (vector (fl* r (fl* (flcos θ) cos-ρ)) (fl* r (fl* (flsin θ) cos-ρ)) (fl* r (flsin ρ))))) + +;; =================================================================================================== +;; Intervals + +(struct ivl (min max) #:transparent + #:guard (λ (a b _) + (cond [(or (nan? a) (nan? b)) (values +nan.0 +nan.0)] + [(and a b) (values (min* a b) (max* a b))] + [else (values a b)]))) + +(defthing empty-ivl ivl? (ivl +nan.0 +nan.0)) +(defthing unknown-ivl ivl? (ivl #f #f)) + +(defproc (ivl-empty? [i ivl?]) boolean? + (nan? (ivl-min i))) + +(defproc (ivl-known? [i ivl?]) boolean? + (match-define (ivl a b) i) + (and a b #t)) + +(defproc (ivl-regular? [i ivl?]) boolean? + (match-define (ivl a b) i) + (and (regular? a) (regular? b))) + +(defproc (ivl-singular? [i ivl?]) boolean? + (match-define (ivl a b) i) + (and a b (= a b))) + +(defproc (ivl-zero-length? [i ivl?]) boolean? + (or (ivl-empty? i) (ivl-singular? i))) + +(defproc (ivl-inexact->exact [i ivl?]) ivl? + (match-define (ivl a b) i) + (ivl (inexact->exact a) (inexact->exact b))) + +(defproc (ivl-contains? [i ivl?] [x real?]) boolean? + (match-define (ivl a b) i) + (and a b (x . >= . a) (x . <= . b))) + +(define (ivl-meet2 i1 i2) ivl? + (cond [(or (ivl-empty? i1) (ivl-empty? i2)) empty-ivl] + [else + (match-define (ivl a1 b1) i1) + (match-define (ivl a2 b2) i2) + (define a (maybe-max a1 a2)) + (define b (maybe-min b1 b2)) + (if (and a b (a . > . b)) empty-ivl (ivl a b))])) + +(define (ivl-meet . is) + (for/fold ([res unknown-ivl]) ([i (in-list is)]) + (ivl-meet2 res i))) + +(define (ivl-join2 i1 i2) + (cond [(ivl-empty? i1) i2] + [(ivl-empty? i2) i1] + [else + (match-define (ivl a1 b1) i1) + (match-define (ivl a2 b2) i2) + (ivl (maybe-min a1 a2) (maybe-max b1 b2))])) + +(define (ivl-join . is) + (for/fold ([res empty-ivl]) ([i (in-list is)]) + (ivl-join2 res i))) + +(defproc (bounds->intervals [xs (listof real?)]) (listof ivl?) + (cond [((length xs) . < . 2) (raise-type-error 'bounds->intervals "list with length >= 2" xs)] + [else + (for/list ([x1 (in-list xs)] + [x2 (in-list (rest xs))]) + (ivl x1 x2))])) diff --git a/collects/plot/common/renderer.rkt b/collects/plot/common/renderer.rkt new file mode 100644 index 0000000000..4f2a35427b --- /dev/null +++ b/collects/plot/common/renderer.rkt @@ -0,0 +1,108 @@ +#lang racket/base + +(require racket/list racket/contract racket/match + "math.rkt" + "vector.rkt" + "contract.rkt" + "contract-doc.rkt" + "parameters.rkt" + "sample.rkt") + +(provide (all-defined-out)) + +(struct renderer (bounds-rect bounds-fun ticks-fun) #:transparent) +(struct renderer2d renderer (render-proc) #:transparent) +(struct renderer3d renderer (render-proc) #:transparent) + +;; =================================================================================================== +;; Common field values + +(define (null-bounds-fun r) r) +(define (null-ticks-fun r) (apply values (make-list (vector-length r) empty))) +(define (null-render-proc area) empty) + +(define null-renderer2d (renderer2d (unknown-rect 2) null-bounds-fun null-ticks-fun null-render-proc)) +(define null-renderer3d (renderer3d (unknown-rect 3) null-bounds-fun null-ticks-fun null-render-proc)) + +(define (default-ticks-fun r) + (apply values (for/list ([i (in-vector r)] + [f (in-list (list default-x-ticks default-y-ticks default-z-ticks))]) + (match-define (ivl a b) i) + (f a b)))) + +(define ((function-bounds-fun f samples) r) + (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])] + [else r])) + +(define ((inverse-bounds-fun f samples) r) + (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])] + [else r])) + +(define ((function-interval-bounds-fun f1 f2 samples) r) + (rect-join ((function-bounds-fun f1 samples) r) + ((function-bounds-fun f2 samples) r))) + +(define ((inverse-interval-bounds-fun f1 f2 samples) r) + (rect-join ((inverse-bounds-fun f1 samples) r) + ((inverse-bounds-fun f2 samples) r))) + +(define ((surface3d-bounds-fun f samples) r) + (match-define (vector xi yi zi) r) + (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])] + [else r])) + +;; =================================================================================================== +;; Fixpoint computation of bounding rectangles + +;; The reasoning in the following comments is in terms of a lattice comprised of rectangles, +;; rect-meet and rect-join. Think of rect-meet like a set intersection; rect-join like a set union. + +;; Attempts to comptute a fixpoint of, roughly, the bounds functions for the given renderers. +;; More precisely, starting with the given plot bounds, it attempts to compute a fixpoint of +;; (renderer-apply-bounds* rs), overridden at every iteration by the plot bounds (if given). +;; Because a fixpoint doesn't always exist, or only exists in the limit, it stops after max-iters. +(define (renderer-bounds-fixpoint rends plot-bounds-rect [max-iters 4]) + (let/ec break + ;; Shortcut eval: if the plot bounds are all known, the code below just returns them anyway + (when (rect-known? plot-bounds-rect) (break plot-bounds-rect)) + ;; Objective: find the fixpoint of F (meeted with plot-bounds-rect) starting at plot-bounds-rect + (define F (renderer-apply-bounds* rends)) + ;; Iterate joint bounds to (hopefully) a fixpoint + (for/fold ([bounds-rect plot-bounds-rect]) ([n (in-range max-iters)]) + ;(printf "bounds-rect = ~v~n" bounds-rect) + ;; Get new bounds from the renderers' bounds functions, limit them to plot bounds (when given) + (define new-bounds-rect (rect-meet plot-bounds-rect (F bounds-rect))) + ;; Shortcut eval: if the bounds haven't changed, we have a fixpoint + (cond [(equal? bounds-rect new-bounds-rect) (break bounds-rect)] + [else new-bounds-rect])))) + +;; Applies the bounds functions of multiple renderers, in parallel, and returns the smallest bounds +;; containing all the new bounds. This function is monotone and increasing regardless of whether any +;; renderer's bounds function is. If iterating it is bounded, a fixpoint exists. +(define ((renderer-apply-bounds* rends) bounds-rect) + (apply rect-join bounds-rect (for/list ([rend (in-list rends)]) + (renderer-apply-bounds rend bounds-rect)))) + +;; Applies the renderer's bounds function. Asks this question: If these are your allowed bounds, what +;; bounds will you try to draw in? +(define (renderer-apply-bounds rend bounds-rect) + (match-define (renderer rend-bounds-rect rend-bounds-fun _) rend) + (rend-bounds-fun (rect-meet bounds-rect rend-bounds-rect))) diff --git a/collects/plot/common/vector.rkt b/collects/plot/common/vector.rkt index a434b0dca2..7ecc7c7f44 100644 --- a/collects/plot/common/vector.rkt +++ b/collects/plot/common/vector.rkt @@ -2,8 +2,11 @@ ;; A small vector library. -(require racket/match racket/vector racket/math racket/list - "math.rkt") +(require racket/match racket/vector racket/math racket/list racket/contract racket/string + "math.rkt" + "contract.rkt" + "contract-doc.rkt" + "utils.rkt") (provide (all-defined-out)) @@ -94,3 +97,71 @@ [m (vmag^2 n)]) (cond [(m . > . 0) (v/ n (sqrt m))] [else default-normal]))]))) + +(define vector-andmap + (case-lambda + [(f v) (let/ec break + (for ([e (in-vector v)]) + (when (not (f e)) (break #f))) + #t)] + [(f v . vs) (define ns (cons (vector-length v) (map vector-length vs))) + (when (not (equal?* ns)) + (error 'vector-andmap "all vectors must have same size; arguments were ~e ~e ~e" + f v (string-join (map (λ (v) (format "~e" v)) vs) " "))) + (let/ec break + (define ess (apply map list (map vector->list vs))) + (for ([e (in-vector v)] [es (in-list ess)]) + (when (not (apply f e es)) (break #f))) + #t)])) + +(define vector-ormap + (case-lambda + [(f v) (let/ec break + (for ([e (in-vector v)]) + (when (f e) (break #t))) + #f)] + [(f v . vs) (define ns (cons (vector-length v) (map vector-length vs))) + (when (not (equal?* ns)) + (error 'vector-andmap "all vectors must have same size; arguments were ~e ~e ~e" + f v (string-join (map (λ (v) (format "~e" v)) vs) " "))) + (let/ec break + (define ess (apply map list (map vector->list vs))) + (for ([e (in-vector v)] [es (in-list ess)]) + (when (apply f e es) (break #t))) + #f)])) + +;; =================================================================================================== +;; Rectangles + +(defproc (empty-rect [n exact-nonnegative-integer?]) (vectorof ivl?) + (make-vector n empty-ivl)) + +(defproc (unknown-rect [n exact-nonnegative-integer?]) (vectorof ivl?) + (make-vector n unknown-ivl)) + +(defproc (rect-empty? [r (vectorof ivl?)]) boolean? + (vector-ormap ivl-empty? r)) + +(defproc (rect-known? [r (vectorof ivl?)]) boolean? + (vector-andmap ivl-known? r)) + +(defproc (rect-regular? [r (vectorof ivl?)]) boolean? + (vector-andmap ivl-regular? r)) + +(defproc (rect-zero-area? [r (vectorof ivl?)]) boolean? + (vector-ormap ivl-zero-length? r)) + +(defproc (rect-singular? [r (vectorof ivl?)]) boolean? + (vector-andmap ivl-singular? r)) + +(defproc (rect-inexact->exact [r (vectorof ivl?)]) (vectorof ivl?) + (vector-map ivl-inexact->exact r)) + +(defproc (rect-contains? [r (vectorof ivl?)] [v (vectorof real?)]) boolean? + (vector-andmap ivl-contains? r v)) + +(define (rect-meet . rs) + (apply vector-map ivl-meet rs)) + +(define (rect-join . rs) + (apply vector-map ivl-join rs)) diff --git a/collects/plot/compat.rkt b/collects/plot/compat.rkt index e76fb7f258..82b60d93db 100644 --- a/collects/plot/compat.rkt +++ b/collects/plot/compat.rkt @@ -6,11 +6,9 @@ ;; Plotting "common/contract.rkt" "common/contract-doc.rkt" - ;"common/ticks.rkt" + "common/renderer.rkt" "plot2d/area.rkt" - "plot2d/renderer.rkt" "plot3d/area.rkt" - "plot3d/renderer.rkt" (prefix-in new. (only-in "main.rkt" x-axis y-axis default-x-ticks default-y-ticks default-z-ticks diff --git a/collects/plot/deprecated.rkt b/collects/plot/deprecated.rkt index 5099f52abb..596d306002 100644 --- a/collects/plot/deprecated.rkt +++ b/collects/plot/deprecated.rkt @@ -5,13 +5,12 @@ "common/deprecation-warning.rkt" "common/contract.rkt" "common/contract-doc.rkt" + "common/renderer.rkt" "plot2d/line.rkt" "plot2d/contour.rkt" - "plot2d/renderer.rkt" "plot3d/surface.rkt" - "plot3d/renderer.rkt" - "utils.rkt" - "deprecated/renderers.rkt") + "deprecated/renderers.rkt" + "utils.rkt") (provide mix line contour shade surface) diff --git a/collects/plot/main.rkt b/collects/plot/main.rkt index 2549c82bec..fc8b23f6cf 100644 --- a/collects/plot/main.rkt +++ b/collects/plot/main.rkt @@ -18,7 +18,10 @@ (provide (all-from-out "common/ticks.rkt")) (require "common/math.rkt") -(provide (contract-out (struct ivl ([min real?] [max real?])))) +(provide (contract-out (struct ivl ([min (or/c real? #f)] [max (or/c real? #f)])))) + +(require "common/renderer.rkt") +(provide renderer2d? renderer3d?) ;; =================================================================================================== ;; 2D exports @@ -41,9 +44,6 @@ (all-from-out "plot2d/decoration.rkt") density) -(require "plot2d/renderer.rkt") -(provide renderer2d?) - ;; =================================================================================================== ;; 3D exports @@ -63,9 +63,6 @@ (all-from-out "plot3d/isosurface.rkt") (all-from-out "plot3d/rectangle.rkt")) -(require "plot3d/renderer.rkt") -(provide renderer3d?) - ;; =================================================================================================== ;; Deprecated functions diff --git a/collects/plot/plot2d/bounds.rkt b/collects/plot/plot2d/bounds.rkt deleted file mode 100644 index 5d440f3603..0000000000 --- a/collects/plot/plot2d/bounds.rkt +++ /dev/null @@ -1,90 +0,0 @@ -#lang racket/base - -(require racket/match racket/list - "../common/math.rkt" - "../common/vector.rkt" - "renderer.rkt") - -(provide renderer2d-bounds-fixpoint - function-bounds-fun - inverse-bounds-fun - function-interval-bounds-fun - inverse-interval-bounds-fun) - -;; =================================================================================================== -;; Fixpoint computation of bounds for multiple renderers - -;; Attempts to comptute a fixpoint of, roughly, the bounds functions for the given renderers. -;; More precisely, starting with the given plot bounds, it attempts to compute a fixpoint of -;; apply-bounds*, overridden at every iteration by the plot bounds (if given). -;; Because a fixpoint doesn't always exist, or may only exist in the limit, it stops after max-iters. -(define (renderer2d-bounds-fixpoint renderers plot-x-min plot-x-max plot-y-min plot-y-max - [max-iters 2]) - (let/ec break - ;; Shortcut eval: if the plot bounds are all specified, the code below just returns them - (when (and plot-x-min plot-x-max plot-y-min plot-y-max) - (break plot-x-min plot-x-max plot-y-min plot-y-max)) - ;; Iterate joint bounds to (hopefully) a fixed point - (for/fold ([x-min plot-x-min] - [x-max plot-x-max] - [y-min plot-y-min] - [y-max plot-y-max]) ([n (in-range max-iters)]) - ;(printf "bounds = ~v ~v ~v ~v~n" x-min x-max y-min y-max) - ;; Get new bounds from the renderers' bounds functions - (define-values (new-x-min new-x-max new-y-min new-y-max) - (let-values ([(new-x-min new-x-max new-y-min new-y-max) - (apply-bounds* renderers x-min x-max y-min y-max)]) - ;; Override by plot bounds - (values (if plot-x-min plot-x-min new-x-min) (if plot-x-max plot-x-max new-x-max) - (if plot-y-min plot-y-min new-y-min) (if plot-y-max plot-y-max new-y-max)))) - ;; Shortcut eval: if the bounds haven't changed, another iteration won't change them - (cond [(and (equal? new-x-min x-min) (equal? new-x-max x-max) - (equal? new-y-min y-min) (equal? new-y-max y-max)) - (break new-x-min new-x-max new-y-min new-y-max)] - [else (values new-x-min new-x-max new-y-min new-y-max)])))) - -;; Applies the bounds functions of multiple renderers, in parallel. Returns the smallest rectangle -;; that contains all the new bounds. -;; This function is monotone because renderer2d-apply-bounds is monotone. If iterating it is bounded, -;; a fixed point exists. -(define (apply-bounds* renderers x-min x-max y-min y-max) - (define-values (x-mins x-maxs y-mins y-maxs) - (for/lists (x-mins x-maxs y-mins y-maxs) ([renderer (in-list renderers)]) - (renderer2d-apply-bounds renderer x-min x-max y-min y-max))) - (values (apply maybe-min x-mins) (apply maybe-max x-maxs) - (apply maybe-min y-mins) (apply maybe-max y-maxs))) - -;; =================================================================================================== -;; Bounds functions - -(define ((function-bounds-fun f samples) x-min x-max y-min y-max) - (cond [(and x-min x-max) (match-define (list xs ys) (f x-min x-max samples)) - (define rys (filter regular? ys)) - (cond [(empty? rys) (values x-min x-max y-min y-max)] - [else (values x-min x-max (apply min* rys) (apply max* rys))])] - [else (values x-min x-max y-min y-max)])) - -(define ((inverse-bounds-fun f samples) x-min x-max y-min y-max) - (cond [(and y-min y-max) (match-define (list ys xs) (f y-min y-max samples)) - (define rxs (filter regular? xs)) - (cond [(empty? rxs) (values x-min x-max y-min y-max)] - [else (values (apply min* rxs) (apply max* rxs) y-min y-max)])] - [else (values x-min x-max y-min y-max)])) - -(define ((function-interval-bounds-fun f1 f2 samples) x-min x-max y-min y-max) - (cond [(and x-min x-max) - (match-define (list x1s y1s) (f1 x-min x-max samples)) - (match-define (list x2s y2s) (f2 x-min x-max samples)) - (define rys (filter regular? (append y1s y2s))) - (cond [(empty? rys) (values x-min x-max y-min y-max)] - [else (values x-min x-max (apply min* rys) (apply max* rys))])] - [else (values x-min x-max y-min y-max)])) - -(define ((inverse-interval-bounds-fun f1 f2 samples) x-min x-max y-min y-max) - (cond [(and y-min y-max) - (match-define (list y1s x1s) (f1 y-min y-max samples)) - (match-define (list y2s x2s) (f2 y-min y-max samples)) - (define rxs (filter regular? (append x1s x2s))) - (cond [(empty? rxs) (values x-min x-max y-min y-max)] - [else (values (apply min* rxs) (apply max* rxs) y-min y-max)])] - [else (values x-min x-max y-min y-max)])) diff --git a/collects/plot/plot2d/contour.rkt b/collects/plot/plot2d/contour.rkt index f18acfbcac..57f6f5a193 100644 --- a/collects/plot/plot2d/contour.rkt +++ b/collects/plot/plot2d/contour.rkt @@ -14,7 +14,7 @@ "../common/ticks.rkt" "../common/vector.rkt" "../common/format.rkt" - "renderer.rkt") + "../common/renderer.rkt") (provide contours contour-intervals) @@ -78,10 +78,10 @@ [#:label label (or/c string? #f) #f] ) renderer2d? (define g (2d-function->sampler f)) - (renderer2d (contours-render-proc g levels samples colors widths styles alphas label) - default-2d-ticks-fun - null-2d-bounds-fun - x-min x-max y-min y-max)) + (renderer2d (vector (ivl x-min x-max) (ivl y-min y-max)) + null-bounds-fun + default-ticks-fun + (contours-render-proc g levels samples colors widths styles alphas label))) ;; =================================================================================================== ;; Contour intervals @@ -175,9 +175,9 @@ [#:label label (or/c string? #f) #f] ) renderer2d? (define g (2d-function->sampler f)) - (renderer2d (contour-intervals-render-proc g levels samples colors styles + (renderer2d (vector (ivl x-min x-max) (ivl y-min y-max)) + null-bounds-fun + default-ticks-fun + (contour-intervals-render-proc g levels samples colors styles contour-colors contour-widths contour-styles - alphas label) - default-2d-ticks-fun - null-2d-bounds-fun - x-min x-max y-min y-max)) + alphas label))) diff --git a/collects/plot/plot2d/decoration.rkt b/collects/plot/plot2d/decoration.rkt index a624901362..95ae3dcf9e 100644 --- a/collects/plot/plot2d/decoration.rkt +++ b/collects/plot/plot2d/decoration.rkt @@ -14,7 +14,7 @@ "../common/sample.rkt" "../common/parameters.rkt" "../common/axis-transform.rkt" - "renderer.rkt" + "../common/renderer.rkt" "area.rkt" "line.rkt" "interval.rkt" @@ -52,15 +52,17 @@ empty) -(define ((x-axis-ticks-fun y) x-min x-max y-min y-max) +(define ((x-axis-ticks-fun y) r) + (match-define (vector _ (ivl y-min y-max)) r) (define digits (digits-for-range y-min y-max)) (values empty (list (tick y #t (real->plot-label y digits))))) (defproc (x-axis [y real? 0] [add-y-tick? boolean? #f] [#:ticks? ticks? boolean? (x-axis-ticks?)]) renderer2d? - (renderer2d (x-axis-render-proc y ticks?) - (if add-y-tick? (x-axis-ticks-fun y) null-2d-ticks-fun) - null-2d-bounds-fun #f #f #f #f)) + (renderer2d (empty-rect 2) + null-bounds-fun + (if add-y-tick? (x-axis-ticks-fun y) null-ticks-fun) + (x-axis-render-proc y ticks?))) (define ((y-axis-render-proc x ticks?) area) (define y-min (send area get-y-min)) @@ -80,15 +82,17 @@ empty) -(define ((y-axis-ticks-fun x) x-min x-max y-min y-max) +(define ((y-axis-ticks-fun x) r) + (match-define (vector (ivl x-min x-max) _) r) (define digits (digits-for-range x-min x-max)) (values (list (tick x #t (real->plot-label x digits))) empty)) (defproc (y-axis [x real? 0] [add-x-tick? boolean? #f] [#:ticks? ticks? boolean? (y-axis-ticks?)]) renderer2d? - (renderer2d (y-axis-render-proc x ticks?) - (if add-x-tick? (y-axis-ticks-fun x) null-2d-ticks-fun) - null-2d-bounds-fun #f #f #f #f)) + (renderer2d (empty-rect 2) + null-bounds-fun + (if add-x-tick? (y-axis-ticks-fun x) null-ticks-fun) + (y-axis-render-proc x ticks?))) (defproc (axes [x real? 0] [y real? 0] [add-x-tick? boolean? #f] [add-y-tick? boolean? #f] [#:x-ticks? x-ticks? boolean? (x-axis-ticks?)] @@ -168,8 +172,10 @@ (defproc (polar-axes [#:number num exact-positive-integer? (polar-axes-number)] [#:ticks? ticks? boolean? (polar-axes-ticks?)] ) renderer2d? - (renderer2d (polar-axes-render-proc num ticks?) - null-2d-ticks-fun null-2d-bounds-fun #f #f #f #f)) + (renderer2d (empty-rect 2) + null-bounds-fun + null-ticks-fun + (polar-axes-render-proc num ticks?))) ;; =================================================================================================== ;; Grid @@ -201,10 +207,10 @@ empty) (defproc (x-tick-lines) renderer2d? - (renderer2d (x-tick-lines-render-proc) null-2d-ticks-fun null-2d-bounds-fun #f #f #f #f)) + (renderer2d (empty-rect 2) null-bounds-fun null-ticks-fun (x-tick-lines-render-proc))) (defproc (y-tick-lines) renderer2d? - (renderer2d (y-tick-lines-render-proc) null-2d-ticks-fun null-2d-bounds-fun #f #f #f #f)) + (renderer2d (empty-rect 2) null-bounds-fun null-ticks-fun (y-tick-lines-render-proc))) (defproc (tick-grid) (listof renderer2d?) (list (x-tick-lines) (y-tick-lines))) @@ -249,10 +255,10 @@ [#:alpha alpha (real-in 0 1) (label-alpha)] ) renderer2d? (match-define (vector x y) v) - (renderer2d (label-render-proc label v color size anchor angle point-size alpha) - null-2d-ticks-fun - null-2d-bounds-fun - x x y y)) + (renderer2d (vector (ivl x x) (ivl y y)) + null-bounds-fun + null-ticks-fun + (label-render-proc label v color size anchor angle point-size alpha))) (defproc (parametric-label [f (real? . -> . (vector/c real? real?))] diff --git a/collects/plot/plot2d/interval.rkt b/collects/plot/plot2d/interval.rkt index 41b21717aa..167d70794b 100644 --- a/collects/plot/plot2d/interval.rkt +++ b/collects/plot/plot2d/interval.rkt @@ -11,8 +11,7 @@ "../common/draw.rkt" "../common/sample.rkt" "../common/parameters.rkt" - "renderer.rkt" - "bounds.rkt") + "../common/renderer.rkt") (provide lines-interval parametric-interval polar-interval function-interval inverse-interval) @@ -65,13 +64,13 @@ [x-max (if x-max x-max (apply max* rxs))] [y-min (if y-min y-min (apply min* rys))] [y-max (if y-max y-max (apply max* rys))]) - (renderer2d (lines-interval-render-proc v1s v2s color style + (renderer2d (vector (ivl x-min x-max) (ivl y-min y-max)) + null-bounds-fun + default-ticks-fun + (lines-interval-render-proc v1s v2s color style line1-color line1-width line1-style line2-color line2-width line2-style - alpha label) - default-2d-ticks-fun - null-2d-bounds-fun - x-min x-max y-min y-max))])) + alpha label)))])) (defproc (parametric-interval [f1 (real? . -> . (vector/c real? real?))] @@ -165,13 +164,13 @@ ) renderer2d? (define g1 (function->sampler f1)) (define g2 (function->sampler f2)) - (renderer2d (function-interval-render-proc g1 g2 samples color style + (renderer2d (vector (ivl x-min x-max) (ivl y-min y-max)) + (function-interval-bounds-fun g1 g2 samples) + default-ticks-fun + (function-interval-render-proc g1 g2 samples color style line1-color line1-width line1-style line2-color line2-width line2-style - alpha label) - default-2d-ticks-fun - (function-interval-bounds-fun g1 g2 samples) - x-min x-max y-min y-max)) + alpha label))) ;; =================================================================================================== ;; Inverse function @@ -212,10 +211,10 @@ ) renderer2d? (define g1 (inverse->sampler f1)) (define g2 (inverse->sampler f2)) - (renderer2d (inverse-interval-render-proc g1 g2 samples color style + (renderer2d (vector (ivl x-min x-max) (ivl y-min y-max)) + (inverse-interval-bounds-fun g1 g2 samples) + default-ticks-fun + (inverse-interval-render-proc g1 g2 samples color style line1-color line1-width line1-style line2-color line2-width line2-style - alpha label) - default-2d-ticks-fun - (inverse-interval-bounds-fun g1 g2 samples) - x-min x-max y-min y-max)) + alpha label))) diff --git a/collects/plot/plot2d/kde.rkt b/collects/plot/plot2d/kde.rkt index fd0c6e6fb8..459bdcd467 100644 --- a/collects/plot/plot2d/kde.rkt +++ b/collects/plot/plot2d/kde.rkt @@ -7,7 +7,7 @@ "../common/utils.rkt" "../common/sample.rkt" "../common/parameters.rkt" - "renderer.rkt" + "../common/renderer.rkt" "line.rkt") (provide kde density) diff --git a/collects/plot/plot2d/line.rkt b/collects/plot/plot2d/line.rkt index fcfd62a39a..47f5f163f0 100644 --- a/collects/plot/plot2d/line.rkt +++ b/collects/plot/plot2d/line.rkt @@ -11,8 +11,7 @@ "../common/legend.rkt" "../common/sample.rkt" "../common/parameters.rkt" - "renderer.rkt" - "bounds.rkt") + "../common/renderer.rkt") (provide lines parametric polar function inverse) @@ -44,10 +43,10 @@ [x-max (if x-max x-max (apply max* rxs))] [y-min (if y-min y-min (apply min* rys))] [y-max (if y-max y-max (apply max* rys))]) - (renderer2d (lines-render-proc vs color width style alpha label) - default-2d-ticks-fun - null-2d-bounds-fun - x-min x-max y-min y-max))])) + (renderer2d (vector (ivl x-min x-max) (ivl y-min y-max)) + null-bounds-fun + default-ticks-fun + (lines-render-proc vs color width style alpha label)))])) (defproc (parametric [f (real? . -> . (vector/c real? real?))] [t-min real?] [t-max real?] @@ -107,10 +106,10 @@ [#:label label (or/c string? #f) #f] ) renderer2d? (define g (function->sampler f)) - (renderer2d (function-render-proc g samples color width style alpha label) - default-2d-ticks-fun + (renderer2d (vector (ivl x-min x-max) (ivl y-min y-max)) (function-bounds-fun g samples) - x-min x-max y-min y-max)) + default-ticks-fun + (function-render-proc g samples color width style alpha label))) ;; =================================================================================================== ;; Inverse function @@ -138,7 +137,7 @@ [#:label label (or/c string? #f) #f] ) renderer2d? (define g (inverse->sampler f)) - (renderer2d (inverse-render-proc g samples color width style alpha label) - default-2d-ticks-fun + (renderer2d (vector (ivl x-min x-max) (ivl y-min y-max)) (inverse-bounds-fun g samples) - x-min x-max y-min y-max)) + default-ticks-fun + (inverse-render-proc g samples color width style alpha label))) diff --git a/collects/plot/plot2d/plot.rkt b/collects/plot/plot2d/plot.rkt index bdd0ab6f3d..f34c207465 100644 --- a/collects/plot/plot2d/plot.rkt +++ b/collects/plot/plot2d/plot.rkt @@ -9,15 +9,16 @@ syntax/strip-context racket/syntax) "../common/math.rkt" - "../common/contract.rkt" "../common/contract-doc.rkt" + "../common/vector.rkt" + "../common/contract.rkt" + "../common/contract-doc.rkt" "../common/legend.rkt" "../common/file-type.rkt" "../common/area.rkt" "../common/parameters.rkt" "../common/deprecation-warning.rkt" - "area.rkt" - "renderer.rkt" - "bounds.rkt") + "../common/renderer.rkt" + "area.rkt") ;; Require lazily: without this, Racket complains while generating documentation: ;; cannot instantiate `racket/gui/base' a second time in the same process @@ -39,54 +40,49 @@ [#:x-label x-label (or/c string? #f) (plot-x-label)] [#:y-label y-label (or/c string? #f) (plot-y-label)] [#:legend-anchor legend-anchor anchor/c (plot-legend-anchor)]) void? - (define rs (filter (λ (renderer) (not (renderer2d-out-of-bounds? renderer x-min x-max y-min y-max))) - (flatten (list renderer-tree)))) + (define given-bounds-rect (vector (ivl x-min x-max) (ivl y-min y-max))) + (define rs (flatten (list renderer-tree))) - (define-values (px-min px-max py-min py-max) - (renderer2d-bounds-fixpoint rs x-min x-max y-min y-max)) + (define plot-bounds-rect (renderer-bounds-fixpoint rs given-bounds-rect)) - (let ([x-min (if x-min x-min px-min)] - [x-max (if x-max x-max px-max)] - [y-min (if y-min y-min py-min)] - [y-max (if y-max y-max py-max)]) - (when (or (not x-min) (not x-max) (x-min . >= . x-max)) - (error 'plot "could not determine nonempty x axis; got: x-min = ~e, x-max = ~e" x-min x-max)) - (when (or (not y-min) (not y-max) (y-min . >= . y-max)) - (error 'plot "could not determine nonempty y axis; got: y-min = ~e, y-max = ~e" y-min y-max)) + (when (or (not (rect-regular? plot-bounds-rect)) + (rect-zero-area? plot-bounds-rect)) + (match-define (vector (ivl x-min x-max) (ivl y-min y-max)) plot-bounds-rect) + (error 'plot "could not determine sensible plot bounds; determined x ∈ [~e,~e], y ∈ [~e,~e]" + x-min x-max y-min y-max)) + + (define bounds-rect (rect-inexact->exact plot-bounds-rect)) + + (define-values (all-x-ticks all-y-ticks) + (for/lists (all-x-ticks all-y-ticks) ([r (in-list rs)]) + ((renderer-ticks-fun r) bounds-rect))) + + (define x-ticks (remove-duplicates (append* all-x-ticks))) + (define y-ticks (remove-duplicates (append* all-y-ticks))) + + (parameterize ([plot-title title] + [plot-x-label x-label] + [plot-y-label y-label] + [plot-legend-anchor legend-anchor]) + (match-define (vector (ivl x-min x-max) (ivl y-min y-max)) bounds-rect) + (define area (make-object 2d-plot-area% + x-ticks y-ticks x-min x-max y-min y-max dc x y width height)) + (send area start-plot) - (let ([x-min (inexact->exact x-min)] - [x-max (inexact->exact x-max)] - [y-min (inexact->exact y-min)] - [y-max (inexact->exact y-max)]) - (define-values (all-x-ticks all-y-ticks) - (for/lists (all-x-ticks all-y-ticks) ([r (in-list rs)]) - ((renderer2d-ticks-fun r) x-min x-max y-min y-max))) - - (define x-ticks (remove-duplicates (append* all-x-ticks))) - (define y-ticks (remove-duplicates (append* all-y-ticks))) - - (parameterize ([plot-title title] - [plot-x-label x-label] - [plot-y-label y-label] - [plot-legend-anchor legend-anchor]) - (define area (make-object 2d-plot-area% - x-ticks y-ticks x-min x-max y-min y-max dc x y width height)) - (send area start-plot) - - (define legend-entries - (flatten (for/list ([renderer (in-list rs)]) - (match-define (renderer2d render-proc ticks-fun bounds-fun - rx-min rx-max ry-min ry-max) - renderer) - (send area start-renderer rx-min rx-max ry-min ry-max) - (render-proc area)))) - - (send area end-plot) - - (when (not (empty? legend-entries)) - (send area put-legend legend-entries)) - - (send area restore-drawing-params))))) + (define legend-entries + (flatten (for/list ([rend (in-list rs)]) + (match-define (renderer2d (vector (ivl rx-min rx-max) (ivl ry-min ry-max)) + _bf _tf render-proc) + rend) + (send area start-renderer rx-min rx-max ry-min ry-max) + (render-proc area)))) + + (send area end-plot) + + (when (not (empty? legend-entries)) + (send area put-legend legend-entries)) + + (send area restore-drawing-params))) ;; =================================================================================================== ;; Plot to various other backends diff --git a/collects/plot/plot2d/point.rkt b/collects/plot/plot2d/point.rkt index d5f92ee608..3bf015f6c6 100644 --- a/collects/plot/plot2d/point.rkt +++ b/collects/plot/plot2d/point.rkt @@ -5,12 +5,12 @@ (require racket/contract racket/class racket/match racket/math racket/list "../common/math.rkt" "../common/vector.rkt" - "../common/contract.rkt" "../common/contract-doc.rkt" + "../common/contract.rkt" + "../common/contract-doc.rkt" "../common/legend.rkt" "../common/draw.rkt" "../common/parameters.rkt" - "renderer.rkt" - "bounds.rkt" + "../common/renderer.rkt" "clip.rkt") (provide points vector-field error-bars) @@ -43,10 +43,10 @@ [x-max (if x-max x-max (apply max* xs))] [y-min (if y-min y-min (apply min* ys))] [y-max (if y-max y-max (apply max* ys))]) - (renderer2d (points-render-fun vs sym color size line-width alpha label) - default-2d-ticks-fun - null-2d-bounds-fun - x-min x-max y-min y-max))]))) + (renderer2d (vector (ivl x-min x-max) (ivl y-min y-max)) + null-bounds-fun + default-ticks-fun + (points-render-fun vs sym color size line-width alpha label)))]))) ;; =================================================================================================== ;; Vector fields @@ -107,17 +107,15 @@ ) renderer2d? (let ([f (cond [(procedure-arity-includes? f 2 #t) f] [else (λ (x y) (f (vector x y)))])]) - (renderer2d (vector-field-render-fun - f samples scale color line-width line-style alpha label) - default-2d-ticks-fun - null-2d-bounds-fun - x-min x-max y-min y-max))) + (renderer2d (vector (ivl x-min x-max) (ivl y-min y-max)) + null-bounds-fun + default-ticks-fun + (vector-field-render-fun f samples scale color line-width line-style alpha label)))) ;; =================================================================================================== ;; Error bars -(define ((error-bars-render-fun bars color line-width line-style width alpha) area) - (match-define (list (vector xs ys hs) ...) bars) +(define ((error-bars-render-fun xs ys hs color line-width line-style width alpha) area) (define-values (x-min x-max y-min y-max) (send area get-clip-bounds)) (define half (* 1/2 width)) @@ -141,18 +139,6 @@ empty) -(define (error-bars-bounds-fun bars) - (let ([bars (filter vregular? bars)]) - (cond [(empty? bars) null-2d-bounds-fun] - [else - (match-define (list (vector xs ys hs) ...) bars) - (λ (x-min x-max y-min y-max) - (let ([x-min (if x-min x-min (apply min* xs))] - [x-max (if x-max x-max (apply max* xs))] - [y-min (if y-min y-min (apply min* (map - ys hs)))] - [y-max (if y-max y-max (apply max* (map + ys hs)))]) - (values x-min x-max y-min y-max)))]))) - (defproc (error-bars [bars (listof (vector/c real? real? real?))] [#:x-min x-min (or/c real? #f) #f] [#:x-max x-max (or/c real? #f) #f] @@ -166,7 +152,13 @@ (let ([bars (filter vregular? bars)]) (cond [(empty? bars) null-renderer2d] [else - (renderer2d (error-bars-render-fun bars color line-width line-style width alpha) - default-2d-ticks-fun - (error-bars-bounds-fun bars) - x-min x-max y-min y-max)]))) + (match-define (list (vector xs ys hs) ...) bars) + (let ([x-min (if x-min x-min (apply min* xs))] + [x-max (if x-max x-max (apply max* xs))] + [y-min (if y-min y-min (apply min* (map - ys hs)))] + [y-max (if y-max y-max (apply max* (map + ys hs)))]) + (renderer2d + (vector (ivl x-min x-max) (ivl y-min y-max)) + null-bounds-fun + default-ticks-fun + (error-bars-render-fun xs ys hs color line-width line-style width alpha)))]))) diff --git a/collects/plot/plot2d/rectangle.rkt b/collects/plot/plot2d/rectangle.rkt index af425ee161..c0e92bac95 100644 --- a/collects/plot/plot2d/rectangle.rkt +++ b/collects/plot/plot2d/rectangle.rkt @@ -7,10 +7,11 @@ "../common/vector.rkt" "../common/format.rkt" "../common/ticks.rkt" - "../common/contract.rkt" "../common/contract-doc.rkt" + "../common/contract.rkt" + "../common/contract-doc.rkt" "../common/legend.rkt" "../common/parameters.rkt" - "renderer.rkt") + "../common/renderer.rkt") (provide rectangles area-histogram discrete-histogram) @@ -51,12 +52,11 @@ [x-max (if x-max x-max (apply max* rxs))] [y-min (if y-min y-min (apply min* rys))] [y-max (if y-max y-max (apply max* rys))]) - (renderer2d (rectangles-render-proc rects color style - line-color line-width line-style alpha label) - default-2d-ticks-fun - null-2d-bounds-fun - x-min x-max y-min y-max))])) - + (renderer2d + (vector (ivl x-min x-max) (ivl y-min y-max)) + null-bounds-fun + default-ticks-fun + (rectangles-render-proc rects color style line-color line-width line-style alpha label)))])) ;; =================================================================================================== ;; Real histograms (or histograms on the real line) @@ -98,7 +98,8 @@ ;; =================================================================================================== ;; Discrete histograms -(define ((discrete-histogram-ticks-fun cats tick-xs) _x-min _x-max y-min y-max) +(define ((discrete-histogram-ticks-fun cats tick-xs) r) + (match-define (vector _ (ivl y-min y-max)) r) (define x-ticks (for/list ([cat (in-list cats)] [x (in-list tick-xs)]) (tick x #t (->plot-label cat)))) @@ -132,8 +133,9 @@ (define 1/2-gap-size (* 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 (rectangles-render-proc (map (λ (x-ivl y) (vector x-ivl (ivl 0 y))) x-ivls ys) - color style line-color line-width line-style alpha label) - (discrete-histogram-ticks-fun cats tick-xs) - null-2d-bounds-fun - x-min x-max y-min y-max))])) + (renderer2d + (vector (ivl x-min x-max) (ivl y-min y-max)) + null-bounds-fun + (discrete-histogram-ticks-fun cats tick-xs) + (rectangles-render-proc (map (λ (x-ivl y) (vector x-ivl (ivl 0 y))) x-ivls ys) + color style line-color line-width line-style alpha label)))])) diff --git a/collects/plot/plot2d/renderer.rkt b/collects/plot/plot2d/renderer.rkt deleted file mode 100644 index 6d2312faaf..0000000000 --- a/collects/plot/plot2d/renderer.rkt +++ /dev/null @@ -1,58 +0,0 @@ -#lang racket/base - -(require racket/list racket/match racket/contract - "../common/contract.rkt" - "../common/contract-doc.rkt" - "../common/math.rkt" - "../common/ticks.rkt" - "../common/parameters.rkt") - -(provide (all-defined-out)) - -;; =================================================================================================== -;; 2D plot renderers - -(struct renderer2d (render-proc ticks-fun bounds-fun x-min x-max y-min y-max) #:transparent - #:guard - (λ (render-proc ticks-fun bounds-fun x-min x-max y-min y-max _) - (when (and x-min x-max (x-min . > . x-max)) - (error 'renderer2d "expected x-min <= x-max; got x-min = ~e and x-max = ~e" x-min x-max)) - (when (and y-min y-max (y-min . > . y-max)) - (error 'renderer2d "expected y-min <= y-max; got y-min = ~e and y-max = ~e" y-min y-max)) - (values render-proc ticks-fun bounds-fun x-min x-max y-min y-max))) - -(define (null-2d-render-proc area) empty) -(define (null-2d-ticks-fun x-min x-max y-min y-max) (values empty empty)) -(define (null-2d-bounds-fun x-min x-max y-min y-max) (values x-min x-max y-min y-max)) - -(define null-renderer2d - (renderer2d null-2d-render-proc null-2d-ticks-fun null-2d-bounds-fun #f #f #f #f)) - -;; =================================================================================================== -;; Bounds functions - -(define (renderer2d-out-of-bounds? renderer x-min x-max y-min y-max) - (match-define (renderer2d _1 _2 _3 rx-min rx-max ry-min ry-max) renderer) - (or (and rx-max x-min (rx-max . < . x-min)) (and rx-min x-max (rx-min . > . x-max)) - (and ry-max y-min (ry-max . < . y-min)) (and ry-min y-max (ry-min . > . y-max)))) - -;; Applies the renderer's bounds function, if the renderer's bounds intersect the given bounds. -;; This function is monotone regardless of whether the bounds function is monotone. -(define (renderer2d-apply-bounds renderer x-min x-max y-min y-max) - (cond [(renderer2d-out-of-bounds? renderer x-min x-max y-min y-max) - (values x-min x-max y-min y-max)] - [else - (match-define (renderer2d _1 _2 bounds-fun rx-min rx-max ry-min ry-max) renderer) - (define-values (new-x-min new-x-max new-y-min new-y-max) - (bounds-fun (maybe-max rx-min x-min) (maybe-min rx-max x-max) - (maybe-max ry-min y-min) (maybe-min ry-max y-max))) - (values (maybe-min x-min new-x-min) (maybe-max x-max new-x-max) - (maybe-min y-min new-y-min) (maybe-max y-max new-y-max))])) - -;; =================================================================================================== -;; Tick functions - -(defproc (default-2d-ticks-fun [x-min real?] [x-max real?] [y-min real?] [y-max real?] - ) (values (listof tick?) (listof tick?)) - (values (default-x-ticks x-min x-max) - (default-y-ticks y-min y-max))) diff --git a/collects/plot/plot3d/bounds.rkt b/collects/plot/plot3d/bounds.rkt deleted file mode 100644 index ed66b7b0af..0000000000 --- a/collects/plot/plot3d/bounds.rkt +++ /dev/null @@ -1,69 +0,0 @@ -#lang racket/base - -(require racket/match racket/list - "../common/math.rkt" - "../common/vector.rkt" - "../common/sample.rkt" - "renderer.rkt") - -(provide renderer3d-bounds-fixpoint - surface3d-bounds-fun) - -;; =================================================================================================== -;; Fixpoint computation of bounds for multiple renderers - -;; Attempts to comptute a fixpoint of, roughly, the bounds functions for the given renderers. -;; More precisely, starting with the given plot bounds, it attempts to compute a fixpoint of -;; apply-bounds*, overridden at every iteration by the plot bounds (if given). -;; Because a fixpoint doesn't always exist, or may only exist in the limit, it stops after max-iters. -(define (renderer3d-bounds-fixpoint renderers plot-x-min plot-x-max plot-y-min plot-y-max - plot-z-min plot-z-max [max-iters 2]) - (let/ec break - ;; Shortcut eval: if the plot bounds are all specified, the code below just returns them - (when (and plot-x-min plot-x-max plot-y-min plot-y-max plot-z-min plot-z-max) - (break plot-x-min plot-x-max plot-y-min plot-y-max plot-z-min plot-z-max)) - ;; Iterate joint bounds to (hopefully) a fixed point - (for/fold ([x-min plot-x-min] - [x-max plot-x-max] - [y-min plot-y-min] - [y-max plot-y-max] - [z-min plot-z-min] - [z-max plot-z-max]) ([n (in-range max-iters)]) - ;(printf "bounds = ~v ~v ~v ~v ~v ~v~n" x-min x-max y-min y-max z-min z-max) - ;; Get new bounds from the renderers' bounds functions - (define-values (new-x-min new-x-max new-y-min new-y-max new-z-min new-z-max) - (let-values ([(new-x-min new-x-max new-y-min new-y-max new-z-min new-z-max) - (apply-bounds* renderers x-min x-max y-min y-max z-min z-max)]) - ;; Override by plot bounds - (values (if plot-x-min plot-x-min new-x-min) (if plot-x-max plot-x-max new-x-max) - (if plot-y-min plot-y-min new-y-min) (if plot-y-max plot-y-max new-y-max) - (if plot-z-min plot-z-min new-z-min) (if plot-z-max plot-z-max new-z-max)))) - ;; Shortcut eval: if the bounds haven't changed, another iteration won't change them - (cond [(and (equal? new-x-min x-min) (equal? new-x-max x-max) - (equal? new-y-min y-min) (equal? new-y-max y-max) - (equal? new-z-min z-min) (equal? new-z-max z-max)) - (break new-x-min new-x-max new-y-min new-y-max new-z-min new-z-max)] - [else (values new-x-min new-x-max new-y-min new-y-max new-z-min new-z-max)])))) - -;; Applies the bounds functions of multiple renderers, in parallel. Returns the smallest rectangle -;; that contains all the new bounds. -;; This function is monotone because renderer2d-apply-bounds is monotone. If iterating it is bounded, -;; a fixed point exists. -(define (apply-bounds* renderers x-min x-max y-min y-max z-min z-max) - (define-values (x-mins x-maxs y-mins y-maxs z-mins z-maxs) - (for/lists (x-mins x-maxs y-mins y-maxs z-mins z-maxs) ([renderer (in-list renderers)]) - (renderer3d-apply-bounds renderer x-min x-max y-min y-max z-min z-max))) - (values (apply maybe-min x-mins) (apply maybe-max x-maxs) - (apply maybe-min y-mins) (apply maybe-max y-maxs) - (apply maybe-min z-mins) (apply maybe-max z-maxs))) - -;; =================================================================================================== -;; Bounds functions - -(define ((surface3d-bounds-fun f samples) x-min x-max y-min y-max z-min z-max) - (cond [(and x-min x-max y-min y-max) - (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 [(empty? zs) (values x-min x-max y-min y-max z-min z-max)] - [else (values x-min x-max y-min y-max (apply min* zs) (apply max* zs))])] - [else (values x-min x-max y-min y-max z-min z-max)])) diff --git a/collects/plot/plot3d/contour.rkt b/collects/plot/plot3d/contour.rkt index 204a793418..160bcedf85 100644 --- a/collects/plot/plot3d/contour.rkt +++ b/collects/plot/plot3d/contour.rkt @@ -11,8 +11,7 @@ "../common/legend.rkt" "../common/sample.rkt" "../common/parameters.rkt" - "renderer.rkt" - "bounds.rkt") + "../common/renderer.rkt") (provide contours3d contour-intervals3d) @@ -76,10 +75,10 @@ [#:label label (or/c string? #f) #f] ) renderer3d? (define g (2d-function->sampler f)) - (renderer3d (contours3d-render-proc g levels samples colors widths styles alphas label) - default-3d-ticks-fun + (renderer3d (vector (ivl x-min x-max) (ivl y-min y-max) (ivl z-min z-max)) (surface3d-bounds-fun g samples) - x-min x-max y-min y-max z-min z-max)) + default-ticks-fun + (contours3d-render-proc g levels samples colors widths styles alphas label))) ;; =================================================================================================== ;; Contour intervals in 3D (using marching squares) @@ -156,10 +155,10 @@ [#:label label (or/c string? #f) #f] ) renderer3d? (define g (2d-function->sampler f)) - (renderer3d (contour-intervals3d-render-proc g levels samples colors + (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 line-colors line-widths line-styles contour-colors contour-widths contour-styles - alphas label) - default-3d-ticks-fun - (surface3d-bounds-fun g samples) - x-min x-max y-min y-max z-min z-max)) + alphas label))) diff --git a/collects/plot/plot3d/isosurface.rkt b/collects/plot/plot3d/isosurface.rkt index ec1e50102f..bfe0ce4c13 100644 --- a/collects/plot/plot3d/isosurface.rkt +++ b/collects/plot/plot3d/isosurface.rkt @@ -10,7 +10,7 @@ "../common/legend.rkt" "../common/sample.rkt" "../common/parameters.rkt" - "renderer.rkt") + "../common/renderer.rkt") (provide isosurface3d isosurfaces3d polar3d) @@ -83,12 +83,12 @@ [#:label label (or/c string? #f) #f] ) renderer3d? (define g (3d-function->sampler f)) - (renderer3d (isosurface3d-render-proc g d samples color + (renderer3d (vector (ivl x-min x-max) (ivl y-min y-max) (ivl z-min z-max)) + null-bounds-fun + default-ticks-fun + (isosurface3d-render-proc g d samples color line-color line-width line-style alpha - label) - default-3d-ticks-fun - null-3d-bounds-fun - x-min x-max y-min y-max z-min z-max)) + label))) ;; =================================================================================================== ;; Nested isosurfaces @@ -177,12 +177,12 @@ [#:label label (or/c string? #f) #f] ) renderer3d? (define g (3d-function->sampler f)) - (renderer3d (isosurfaces3d-render-proc g d-min d-max levels samples colors + (renderer3d (vector (ivl x-min x-max) (ivl y-min y-max) (ivl z-min z-max)) + null-bounds-fun + default-ticks-fun + (isosurfaces3d-render-proc g d-min d-max levels samples colors line-colors line-widths line-styles alphas - label) - default-3d-ticks-fun - null-3d-bounds-fun - x-min x-max y-min y-max z-min z-max)) + label))) ;; =================================================================================================== @@ -273,8 +273,8 @@ [z-max (if z-max z-max (apply max* rzs))]) (define new-f (2d-polar->3d-function f)) (define g (3d-function->sampler new-f)) - (renderer3d (polar3d-render-proc new-f g samples color - line-color line-width line-style alpha label) - default-3d-ticks-fun - null-3d-bounds-fun - x-min x-max y-min y-max z-min z-max))])) + (renderer3d (vector (ivl x-min x-max) (ivl y-min y-max) (ivl z-min z-max)) + null-bounds-fun + default-ticks-fun + (polar3d-render-proc new-f g samples color + line-color line-width line-style alpha label)))])) diff --git a/collects/plot/plot3d/line.rkt b/collects/plot/plot3d/line.rkt index 768d3dc2c4..fca58bdb00 100644 --- a/collects/plot/plot3d/line.rkt +++ b/collects/plot/plot3d/line.rkt @@ -8,7 +8,7 @@ "../common/legend.rkt" "../common/sample.rkt" "../common/parameters.rkt" - "renderer.rkt") + "../common/renderer.rkt") (provide lines3d parametric3d) @@ -34,10 +34,10 @@ [y-max (if y-max y-max (apply max* rys))] [z-min (if z-min z-min (apply min* rzs))] [z-max (if z-max z-max (apply max* rzs))]) - (renderer3d (lines3d-render-proc vs-thnk color width style alpha label) - default-3d-ticks-fun - null-3d-bounds-fun - x-min x-max y-min y-max z-min z-max))])) + (renderer3d (vector (ivl x-min x-max) (ivl y-min y-max) (ivl z-min z-max)) + null-bounds-fun + default-ticks-fun + (lines3d-render-proc vs-thnk color width style alpha label)))])) (defproc (lines3d [vs (listof (vector/c real? real? real?))] diff --git a/collects/plot/plot3d/plot.rkt b/collects/plot/plot3d/plot.rkt index 60941360c1..78327b6390 100644 --- a/collects/plot/plot3d/plot.rkt +++ b/collects/plot/plot3d/plot.rkt @@ -5,14 +5,14 @@ unstable/lazy-require (for-syntax racket/base) "../common/math.rkt" + "../common/vector.rkt" "../common/file-type.rkt" "../common/area.rkt" "../common/contract.rkt" "../common/contract-doc.rkt" "../common/parameters.rkt" "../common/deprecation-warning.rkt" - "area.rkt" - "renderer.rkt" - "bounds.rkt") + "../common/renderer.rkt" + "area.rkt") ;; Require lazily: without this, Racket complains while generating documentation: ;; cannot instantiate `racket/gui/base' a second time in the same process @@ -36,70 +36,59 @@ [#:y-label y-label (or/c string? #f) (plot-y-label)] [#:z-label z-label (or/c string? #f) (plot-z-label)] [#:legend-anchor legend-anchor anchor/c (plot-legend-anchor)]) void? - (define rs (filter (λ (renderer) (not (renderer3d-out-of-bounds? - renderer x-min x-max y-min y-max z-min z-max))) - (flatten (list renderer-tree)))) + (define given-bounds-rect (vector (ivl x-min x-max) (ivl y-min y-max) (ivl z-min z-max))) + (define rs (flatten (list renderer-tree))) - (define-values (px-min px-max py-min py-max pz-min pz-max) - (renderer3d-bounds-fixpoint rs x-min x-max y-min y-max z-min z-max)) + (define plot-bounds-rect (renderer-bounds-fixpoint rs given-bounds-rect)) - (let ([x-min (if x-min x-min px-min)] - [x-max (if x-max x-max px-max)] - [y-min (if y-min y-min py-min)] - [y-max (if y-max y-max py-max)] - [z-min (if z-min z-min pz-min)] - [z-max (if z-max z-max pz-max)]) - (when (or (not x-min) (not x-max) (x-min . >= . x-max)) - (error 'plot3d "could not determine x bounds; got: x-min = ~e, x-max = ~e" x-min x-max)) - (when (or (not y-min) (not y-max) (y-min . >= . y-max)) - (error 'plot3d "could not determine y bounds; got: y-min = ~e, y-max = ~e" y-min y-max)) - (when (or (not z-min) (not z-max) (z-min . >= . z-max)) - (error 'plot3d "could not determine z bounds; got: z-min = ~e, z-max = ~e" z-min z-max)) + (when (or (not (rect-regular? plot-bounds-rect)) + (rect-zero-area? plot-bounds-rect)) + (match-define (vector (ivl x-min x-max) (ivl y-min y-max) (ivl z-min z-max)) plot-bounds-rect) + (error 'plot "~a; determined x ∈ [~e,~e], y ∈ [~e,~e], z ∈ [~e,~e]" + "could not determine sensible plot bounds" x-min x-max y-min y-max z-min z-max)) + + (define bounds-rect (rect-inexact->exact plot-bounds-rect)) + + (define-values (all-x-ticks all-y-ticks all-z-ticks) + (for/lists (all-x-ticks all-y-ticks all-z-ticks) ([r (in-list rs)]) + ((renderer-ticks-fun r) bounds-rect))) + + (define x-ticks (remove-duplicates (append* all-x-ticks))) + (define y-ticks (remove-duplicates (append* all-y-ticks))) + (define z-ticks (remove-duplicates (append* all-z-ticks))) + + (parameterize ([plot3d-angle angle] + [plot3d-altitude altitude] + [plot-title title] + [plot-x-label x-label] + [plot-y-label y-label] + [plot-z-label z-label] + [plot-legend-anchor legend-anchor]) + (match-define (vector (ivl x-min x-max) (ivl y-min y-max) (ivl z-min z-max)) bounds-rect) + (define area (make-object 3d-plot-area% + x-ticks y-ticks z-ticks x-min x-max y-min y-max z-min z-max + dc x y width height)) + (send area start-plot) - (let ([x-min (inexact->exact x-min)] - [x-max (inexact->exact x-max)] - [y-min (inexact->exact y-min)] - [y-max (inexact->exact y-max)] - [z-min (inexact->exact z-min)] - [z-max (inexact->exact z-max)]) - (define-values (all-x-ticks all-y-ticks all-z-ticks) - (for/lists (all-x-ticks all-y-ticks all-z-ticks) ([r (in-list rs)]) - ((renderer3d-ticks-fun r) x-min x-max y-min y-max z-min z-max))) - - (define x-ticks (remove-duplicates (append* all-x-ticks))) - (define y-ticks (remove-duplicates (append* all-y-ticks))) - (define z-ticks (remove-duplicates (append* all-z-ticks))) - - (parameterize ([plot3d-angle angle] - [plot3d-altitude altitude] - [plot-title title] - [plot-x-label x-label] - [plot-y-label y-label] - [plot-z-label z-label] - [plot-legend-anchor legend-anchor]) - (define area (make-object 3d-plot-area% - x-ticks y-ticks z-ticks x-min x-max y-min y-max z-min z-max - dc x y width height)) - (send area start-plot) - - (define legend-entries - (flatten (for/list ([renderer (in-list rs)]) - (match-define (renderer3d render-proc ticks-fun bounds-fun - rx-min rx-max ry-min ry-max rz-min rz-max) - renderer) - (send area start-renderer rx-min rx-max ry-min ry-max rz-min rz-max) - (render-proc area)))) - - (send area end-plot) - - (when (and (not (empty? legend-entries)) - (or (not (plot-animating?)) - (not (equal? (plot-legend-anchor) 'center)))) - (send area put-legend legend-entries)) - - (when (plot-animating?) (send area put-angles)) - - (send area restore-drawing-params))))) + (define legend-entries + (flatten (for/list ([rend (in-list rs)]) + (match-define (renderer3d + (vector (ivl rx-min rx-max) (ivl ry-min ry-max) (ivl rz-min rz-max)) + _bf _tf render-proc) + rend) + (send area start-renderer rx-min rx-max ry-min ry-max rz-min rz-max) + (render-proc area)))) + + (send area end-plot) + + (when (and (not (empty? legend-entries)) + (or (not (plot-animating?)) + (not (equal? (plot-legend-anchor) 'center)))) + (send area put-legend legend-entries)) + + (when (plot-animating?) (send area put-angles)) + + (send area restore-drawing-params))) ;; =================================================================================================== ;; Plot to various other backends diff --git a/collects/plot/plot3d/point.rkt b/collects/plot/plot3d/point.rkt index 3dd016ea12..cf821a6def 100644 --- a/collects/plot/plot3d/point.rkt +++ b/collects/plot/plot3d/point.rkt @@ -3,10 +3,11 @@ (require racket/class racket/list racket/match racket/contract "../common/math.rkt" "../common/vector.rkt" - "../common/contract.rkt" "../common/contract-doc.rkt" + "../common/contract.rkt" + "../common/contract-doc.rkt" "../common/legend.rkt" "../common/parameters.rkt" - "renderer.rkt") + "../common/renderer.rkt") (provide points3d) @@ -42,6 +43,7 @@ [y-max (if y-max y-max (apply max* ys))] [z-min (if z-min z-min (apply min* zs))] [z-max (if z-max z-max (apply max* zs))]) - (renderer3d (points3d-render-proc vs sym color size line-width alpha label) - default-3d-ticks-fun null-3d-bounds-fun - x-min x-max y-min y-max z-min z-max))]))) + (renderer3d (vector (ivl x-min x-max) (ivl y-min y-max) (ivl z-min z-max)) + null-bounds-fun + default-ticks-fun + (points3d-render-proc vs sym color size line-width alpha label)))]))) diff --git a/collects/plot/plot3d/rectangle.rkt b/collects/plot/plot3d/rectangle.rkt index 10c3e7aa24..26942bee67 100644 --- a/collects/plot/plot3d/rectangle.rkt +++ b/collects/plot/plot3d/rectangle.rkt @@ -3,14 +3,15 @@ ;; Functions to create renderers for 3D histograms (require racket/match racket/list racket/contract racket/class - "../common/contract.rkt" "../common/contract-doc.rkt" + "../common/contract.rkt" + "../common/contract-doc.rkt" "../common/parameters.rkt" "../common/math.rkt" "../common/vector.rkt" "../common/legend.rkt" "../common/ticks.rkt" "../common/format.rkt" - "renderer.rkt") + "../common/renderer.rkt") (provide rectangles3d discrete-histogram3d) @@ -55,17 +56,17 @@ [y-max (if y-max y-max (apply max* rys))] [z-min (if z-min z-min (apply min* rzs))] [z-max (if z-max z-max (apply max* rzs))]) - (renderer3d (rectangles3d-render-proc rects color style line-color line-width line-style - alpha label) - default-3d-ticks-fun - null-3d-bounds-fun - x-min x-max y-min y-max z-min z-max))])) + (renderer3d (vector (ivl x-min x-max) (ivl y-min y-max) (ivl z-min z-max)) + null-bounds-fun + default-ticks-fun + (rectangles3d-render-proc rects color style line-color line-width line-style + alpha label)))])) ;; =================================================================================================== ;; Discrete histograms -(define ((discrete-histogram3d-ticks-fun c1s c2s tick-xs tick-ys) - _x-min _x-max _y-min _y-max z-min z-max) +(define ((discrete-histogram3d-ticks-fun c1s c2s tick-xs tick-ys) r) + (match-define (vector _xi _yi (ivl z-min z-max)) r) (define x-ticks (for/list ([cat (in-list c1s)] [x (in-list tick-xs)]) (tick x #t (->plot-label cat)))) @@ -128,8 +129,8 @@ (adjust/gap (ivl y1 y2) gap) (ivl 0 z))) x1s x2s y1s y2s all-zs)) - (renderer3d (rectangles3d-render-proc rects color style line-color line-width line-style - alpha label) + (renderer3d (vector (ivl x-min x-max) (ivl y-min y-max) (ivl z-min z-max)) + null-bounds-fun (discrete-histogram3d-ticks-fun c1s c2s tick-xs tick-ys) - null-3d-bounds-fun - x-min x-max y-min y-max z-min z-max))])) + (rectangles3d-render-proc rects color style line-color line-width line-style + alpha label)))])) diff --git a/collects/plot/plot3d/renderer.rkt b/collects/plot/plot3d/renderer.rkt deleted file mode 100644 index 2c320d70cd..0000000000 --- a/collects/plot/plot3d/renderer.rkt +++ /dev/null @@ -1,70 +0,0 @@ -#lang racket/base - -(require racket/list racket/match racket/contract - "../common/contract.rkt" - "../common/contract-doc.rkt" - "../common/math.rkt" - "../common/ticks.rkt" - "../common/parameters.rkt") - -(provide (all-defined-out)) - -;; =================================================================================================== -;; 3D plot renderers - -(struct renderer3d (render-proc ticks-fun bounds-fun x-min x-max y-min y-max z-min z-max) - #:transparent - #:guard - (λ (render-proc ticks-fun bounds-fun x-min x-max y-min y-max z-min z-max _) - (when (and x-min x-max (x-min . > . x-max)) - (error 'renderer3d "expected x-min <= x-max; got x-min = ~e and x-max = ~e" x-min x-max)) - (when (and y-min y-max (y-min . > . y-max)) - (error 'renderer3d "expected y-min <= y-max; got y-min = ~e and y-max = ~e" y-min y-max)) - (when (and z-min z-max (z-min . > . z-max)) - (error 'renderer3d "expected z-min <= z-max; got z-min = ~e and z-max = ~e" z-min z-max)) - (values render-proc ticks-fun bounds-fun x-min x-max y-min y-max z-min z-max))) - -(define (null-3d-render-proc area) empty) -(define (null-3d-ticks-fun x-min x-max y-min y-max z-min z-max) (values empty empty empty)) -(define (null-3d-bounds-fun x-min x-max y-min y-max z-min z-max) - (values x-min x-max y-min y-max z-min z-max)) - -(define null-renderer3d - (renderer3d null-3d-render-proc null-3d-ticks-fun null-3d-bounds-fun #f #f #f #f #f #f)) - -;; =================================================================================================== -;; Bounds functions - -(define (renderer3d-out-of-bounds? renderer x-min x-max y-min y-max z-min z-max) - (match-define (renderer3d _1 _2 _3 rx-min rx-max ry-min ry-max rz-min rz-max) renderer) - (or (and rx-max x-min (rx-max . < . x-min)) (and rx-min x-max (rx-min . > . x-max)) - (and ry-max y-min (ry-max . < . y-min)) (and ry-min y-max (ry-min . > . y-max)) - (and rz-max z-min (rz-max . < . z-min)) (and rz-min z-max (rz-min . > . z-max)))) - -;; Applies the renderer's bounds function, if the renderer's bounds intersect the given bounds. -;; This function is monotone regardless of whether the bounds function is monotone. -(define (renderer3d-apply-bounds renderer x-min x-max y-min y-max z-min z-max) - (cond - [(renderer3d-out-of-bounds? renderer x-min x-max y-min y-max z-min z-max) - (values x-min x-max y-min y-max z-min z-max)] - [else - (match-define (renderer3d _1 _2 bounds-fun rx-min rx-max ry-min ry-max rz-min rz-max) renderer) - (define-values (new-x-min new-x-max new-y-min new-y-max new-z-min new-z-max) - (bounds-fun (maybe-max rx-min x-min) (maybe-min rx-max x-max) - (maybe-max ry-min y-min) (maybe-min ry-max y-max) - (maybe-max rz-min z-min) (maybe-min rz-max z-max))) - (values (maybe-min x-min new-x-min) (maybe-max x-max new-x-max) - (maybe-min y-min new-y-min) (maybe-max y-max new-y-max) - (maybe-min z-min new-z-min) (maybe-max z-max new-z-max))])) - -;; =================================================================================================== -;; Tick functions - -(defproc (default-3d-ticks-fun - [x-min real?] [x-max real?] - [y-min real?] [y-max real?] - [z-min real?] [z-max real?] - ) (values (listof tick?) (listof tick?) (listof tick?)) - (values (default-x-ticks x-min x-max) - (default-y-ticks y-min y-max) - (default-z-ticks z-min z-max))) diff --git a/collects/plot/plot3d/surface.rkt b/collects/plot/plot3d/surface.rkt index f3a5e4e692..38d08adcf1 100644 --- a/collects/plot/plot3d/surface.rkt +++ b/collects/plot/plot3d/surface.rkt @@ -11,9 +11,8 @@ "../common/legend.rkt" "../common/sample.rkt" "../common/parameters.rkt" - "area.rkt" - "renderer.rkt" - "bounds.rkt") + "../common/renderer.rkt" + "area.rkt") (provide surface3d) @@ -61,8 +60,8 @@ [#:label label (or/c string? #f) #f] ) renderer3d? (define g (2d-function->sampler f)) - (renderer3d (surface3d-render-proc g samples color style - line-color line-width line-style alpha label) - default-3d-ticks-fun + (renderer3d (vector (ivl x-min x-max) (ivl y-min y-max) (ivl z-min z-max)) (surface3d-bounds-fun g samples) - x-min x-max y-min y-max z-min z-max)) + default-ticks-fun + (surface3d-render-proc g samples color style + line-color line-width line-style alpha label))) diff --git a/collects/plot/tests/axis-transform-tests.rkt b/collects/plot/tests/axis-transform-tests.rkt index d10a092e35..076ed55bc1 100644 --- a/collects/plot/tests/axis-transform-tests.rkt +++ b/collects/plot/tests/axis-transform-tests.rkt @@ -5,7 +5,7 @@ plot/utils plot/common/contract plot/common/contract-doc - plot/common/axis-transform + ;plot/common/axis-transform ) (x-axis-ticks? #f) diff --git a/collects/plot/tests/low-level-tests.rkt b/collects/plot/tests/low-level-tests.rkt new file mode 100755 index 0000000000..073f7773f9 --- /dev/null +++ b/collects/plot/tests/low-level-tests.rkt @@ -0,0 +1,301 @@ +#!/bin/sh +#| -*- racket -*- +exec gracket "$0" "$@" +|# +#lang racket + +(require rackunit racket/date + plot plot/utils plot/common/date-time plot/common/vector) + +(check-equal? (linear-seq 0 1 2 #:start? #t #:end? #t) '(0 1)) +(check-equal? (linear-seq 0 1 2 #:start? #t #:end? #f) '(0 2/3)) +(check-equal? (linear-seq 0 1 2 #:start? #f #:end? #t) '(1/3 1)) +(check-equal? (linear-seq 0 1 2 #:start? #f #:end? #f) '(1/4 3/4)) + +(check-exn exn:fail:contract? + (λ () (vector-field (λ (v [z 0]) v) -4 4 -4 4)) + "Exception should be 'two of the clauses in the or/c might both match' or similar") + +;; =================================================================================================== +;; Date rounding + +(check-equal? (utc-seconds-round-year (find-seconds 0 0 12 2 7 1970 #f)) + (find-seconds 0 0 0 1 1 1970 #f)) +(check-equal? (utc-seconds-round-year (find-seconds 0 0 13 2 7 1970 #f)) + (find-seconds 0 0 0 1 1 1971 #f)) +;; A leap year's middle is a half day earlier on the calendar: +(check-equal? (utc-seconds-round-year (find-seconds 0 0 0 2 7 1976 #f)) + (find-seconds 0 0 0 1 1 1976 #f)) +(check-equal? (utc-seconds-round-year (find-seconds 0 0 1 2 7 1976 #f)) + (find-seconds 0 0 0 1 1 1977 #f)) + +(check-equal? (utc-seconds-round-month (find-seconds 0 0 0 16 1 2010 #f)) + (find-seconds 0 0 0 1 1 2010 #f)) +(check-equal? (utc-seconds-round-month (find-seconds 0 0 0 17 1 2010 #f)) + (find-seconds 0 0 0 1 2 2010 #f)) +(check-equal? (utc-seconds-round-month (find-seconds 0 0 12 16 1 2010 #f)) + (find-seconds 0 0 0 1 1 2010 #f)) +(check-equal? (utc-seconds-round-month (find-seconds 0 0 13 16 1 2010 #f)) + (find-seconds 0 0 0 1 2 2010 #f)) +(check-equal? (utc-seconds-round-month (find-seconds 0 0 0 16 12 2010 #f)) + (find-seconds 0 0 0 1 12 2010 #f)) +(check-equal? (utc-seconds-round-month (find-seconds 0 0 0 17 12 2010 #f)) + (find-seconds 0 0 0 1 1 2011 #f)) + +;; =================================================================================================== +;; Time conversion + +(check-equal? (seconds->plot-time 0) (plot-time 0 0 0 0)) +(check-equal? (seconds->plot-time #e59.999999) (plot-time #e59.999999 0 0 0)) +(check-equal? (seconds->plot-time 60) (plot-time 0 1 0 0)) +(check-equal? (seconds->plot-time #e60.000001) (plot-time #e0.000001 1 0 0)) +(check-equal? (seconds->plot-time #e119.999999) (plot-time #e59.999999 1 0 0)) +(check-equal? (seconds->plot-time 120) (plot-time 0 2 0 0)) +(check-equal? (seconds->plot-time #e120.000001) (plot-time #e0.000001 2 0 0)) +(check-equal? (seconds->plot-time 3599) (plot-time 59 59 0 0)) +(check-equal? (seconds->plot-time 3600) (plot-time 0 0 1 0)) +(check-equal? (seconds->plot-time 3601) (plot-time 1 0 1 0)) +(check-equal? (seconds->plot-time (- seconds-per-day 1)) (plot-time 59 59 23 0)) +(check-equal? (seconds->plot-time seconds-per-day) (plot-time 0 0 0 1)) +(check-equal? (seconds->plot-time (- seconds-per-day)) (plot-time 0 0 0 -1)) +(check-equal? (seconds->plot-time (- (- seconds-per-day) 1)) (plot-time 59 59 23 -2)) + +(define sec-secs (sequence->list (in-range -60 61 #e0.571123))) +(define min-secs (sequence->list (in-range (- seconds-per-hour) (+ seconds-per-hour 1) + (* #e0.571123 seconds-per-minute)))) +(define hour-secs (sequence->list (in-range (- seconds-per-day) (+ seconds-per-day 1) + (* #e0.571123 seconds-per-hour)))) +(define day-secs (sequence->list (in-range (- seconds-per-week) (+ seconds-per-week 1) + (* #e0.571123 seconds-per-day)))) +(check-equal? (map (compose plot-time->seconds seconds->plot-time) sec-secs) sec-secs) +(check-equal? (map (compose plot-time->seconds seconds->plot-time) min-secs) min-secs) +(check-equal? (map (compose plot-time->seconds seconds->plot-time) hour-secs) hour-secs) +(check-equal? (map (compose plot-time->seconds seconds->plot-time) day-secs) day-secs) + +;; =================================================================================================== +;; Intervals + +(check-false (ivl-regular? (ivl #f #f))) +(check-false (ivl-regular? (ivl +nan.0 +nan.0))) + +(check-true (ivl-empty? (ivl-meet empty-ivl (ivl 0 3)))) + +;;; ivl-meet (similar to an intersection) + +;; All specified +(check-true (ivl-empty? (ivl-meet (ivl 0 1) (ivl 2 3)))) +(check-equal? (ivl-meet (ivl 0 2) (ivl 1 3)) (ivl 1 2)) +(check-equal? (ivl-meet (ivl 0 3) (ivl 1 2)) (ivl 1 2)) + +;; One not specified +;; <--- 1 2 -- 3 +(check-true (ivl-empty? (ivl-meet (ivl #f 1) (ivl 2 3)))) +;; 0 -- 1 2 ---> +(check-true (ivl-empty? (ivl-meet (ivl 0 1) (ivl 2 #f)))) +;; <-------- 2 +;; 1 ------- 3 +(check-equal? (ivl-meet (ivl #f 2) (ivl 1 3)) (ivl 1 2)) +;; 2 ---> +;; 0 ------------ 3 +(check-equal? (ivl-meet (ivl 2 #f) (ivl 0 3)) (ivl 2 3)) +;; <------------- 3 +;; 1 -- 2 +(check-equal? (ivl-meet (ivl #f 3) (ivl 1 2)) (ivl 1 2)) +;; 0 -------------> +;; 1 -- 2 +(check-equal? (ivl-meet (ivl 0 #f) (ivl 1 2)) (ivl 1 2)) + +;; Two not specified +;; <--- 1 2 ---> +(check-true (ivl-empty? (ivl-meet (ivl #f 1) (ivl 2 #f)))) +;; <--------------> +;; 1 -- 2 +(check-equal? (ivl-meet (ivl #f #f) (ivl 1 2)) (ivl 1 2)) +;; 1 --------> +;; <-------- 2 +(check-equal? (ivl-meet (ivl 1 #f) (ivl #f 2)) (ivl 1 2)) +;; <-------- 2 +;; <------------- 3 +(check-equal? (ivl-meet (ivl #f 2) (ivl #f 3)) (ivl #f 2)) +;; 0 -------------> +;; 1 --------> +(check-equal? (ivl-meet (ivl 0 #f) (ivl 1 #f)) (ivl 1 #f)) + +;; Three not specified +;; <--------------> +;; 1 --------> +(check-equal? (ivl-meet (ivl #f #f) (ivl 1 #f)) (ivl 1 #f)) +;; <--------------> +;; <-------- 2 +(check-equal? (ivl-meet (ivl #f #f) (ivl #f 2)) (ivl #f 2)) + +;; Four not specified +(check-equal? (ivl-meet (ivl #f #f) (ivl #f #f)) (ivl #f #f)) + +;; One infinite +;; <--- 1 2 -- 3 +(check-true (ivl-empty? (ivl-meet (ivl -inf.0 1) (ivl 2 3)))) +;; 0 -- 1 2 ---> +(check-true (ivl-empty? (ivl-meet (ivl 0 1) (ivl 2 +inf.0)))) +;; <-------- 2 +;; 1 ------- 3 +(check-equal? (ivl-meet (ivl -inf.0 2) (ivl 1 3)) (ivl 1 2)) +;; 2 ---> +;; 0 ------------ 3 +(check-equal? (ivl-meet (ivl 2 +inf.0) (ivl 0 3)) (ivl 2 3)) +;; <------------- 3 +;; 1 -- 2 +(check-equal? (ivl-meet (ivl -inf.0 3) (ivl 1 2)) (ivl 1 2)) +;; 0 -------------> +;; 1 -- 2 +(check-equal? (ivl-meet (ivl 0 +inf.0) (ivl 1 2)) (ivl 1 2)) + +;; Two infinite +;; <--- 1 2 ---> +(check-true (ivl-empty? (ivl-meet (ivl -inf.0 1) (ivl 2 +inf.0)))) +;; <--------------> +;; 1 -- 2 +(check-equal? (ivl-meet (ivl -inf.0 +inf.0) (ivl 1 2)) (ivl 1 2)) +;; 1 --------> +;; <-------- 2 +(check-equal? (ivl-meet (ivl 1 +inf.0) (ivl -inf.0 2)) (ivl 1 2)) +;; <-------- 2 +;; <------------- 3 +(check-equal? (ivl-meet (ivl -inf.0 2) (ivl -inf.0 3)) (ivl -inf.0 2)) +;; 0 -------------> +;; 1 --------> +(check-equal? (ivl-meet (ivl 0 +inf.0) (ivl 1 +inf.0)) (ivl 1 +inf.0)) + +;; Three infinite +;; <--------------> +;; 1 --------> +(check-equal? (ivl-meet (ivl -inf.0 +inf.0) (ivl 1 +inf.0)) (ivl 1 +inf.0)) +;; <--------------> +;; <-------- 2 +(check-equal? (ivl-meet (ivl -inf.0 +inf.0) (ivl -inf.0 2)) (ivl -inf.0 2)) + +;; Four infinite +(check-equal? (ivl-meet (ivl -inf.0 +inf.0) (ivl -inf.0 +inf.0)) (ivl -inf.0 +inf.0)) + +;;; ivl-join (similar to a union) + +(check-true (ivl-empty? (ivl-join empty-ivl empty-ivl))) +(check-equal? (ivl-join empty-ivl (ivl 0 3)) (ivl 0 3)) + +;; All specified +(check-equal? (ivl-join (ivl 0 1) (ivl 2 3)) (ivl 0 3)) +(check-equal? (ivl-join (ivl 0 2) (ivl 1 3)) (ivl 0 3)) +(check-equal? (ivl-join (ivl 0 3) (ivl 1 2)) (ivl 0 3)) + +;; One not specified +;; <--- 1 2 -- 3 +(check-equal? (ivl-join (ivl #f 1) (ivl 2 3)) (ivl 2 3)) +;; 0 -- 1 2 ---> +(check-equal? (ivl-join (ivl 0 1) (ivl 2 #f)) (ivl 0 1)) +;; <-------- 2 +;; 1 ------- 3 +(check-equal? (ivl-join (ivl #f 2) (ivl 1 3)) (ivl 1 3)) +;; 2 ---> +;; 0 ------------ 3 +(check-equal? (ivl-join (ivl 2 #f) (ivl 0 3)) (ivl 0 3)) +;; <------------- 3 +;; 1 -- 2 +(check-equal? (ivl-join (ivl #f 3) (ivl 1 2)) (ivl 1 3)) +;; 0 -------------> +;; 1 -- 2 +(check-equal? (ivl-join (ivl 0 #f) (ivl 1 2)) (ivl 0 2)) + +;; Two not specified +;; <--- 1 2 ---> +(check-equal? (ivl-join (ivl #f 1) (ivl 2 #f)) (ivl 1 2)) +;; <--------------> +;; 1 -- 2 +(check-equal? (ivl-join (ivl #f #f) (ivl 1 2)) (ivl 1 2)) +;; 1 --------> +;; <-------- 2 +(check-equal? (ivl-join (ivl 1 #f) (ivl #f 2)) (ivl 1 2)) +;; <-------- 2 +;; <------------- 3 +(check-equal? (ivl-join (ivl #f 2) (ivl #f 3)) (ivl #f 3)) +;; 0 -------------> +;; 1 --------> +(check-equal? (ivl-join (ivl 0 #f) (ivl 1 #f)) (ivl 0 #f)) + +;; Three not specified +;; <--------------> +;; 1 --------> +(check-equal? (ivl-join (ivl #f #f) (ivl 1 #f)) (ivl 1 #f)) +;; <--------------> +;; <-------- 2 +(check-equal? (ivl-join (ivl #f #f) (ivl #f 2)) (ivl #f 2)) + +;; Four not specified +(check-equal? (ivl-join (ivl #f #f) (ivl #f #f)) (ivl #f #f)) + +;; One infinite +;; <--- 1 2 -- 3 +(check-equal? (ivl-join (ivl -inf.0 1) (ivl 2 3)) (ivl -inf.0 3)) +;; 0 -- 1 2 ---> +(check-equal? (ivl-join (ivl 0 1) (ivl 2 +inf.0)) (ivl 0 +inf.0)) +;; <-------- 2 +;; 1 ------- 3 +(check-equal? (ivl-join (ivl -inf.0 2) (ivl 1 3)) (ivl -inf.0 3)) +;; 2 ---> +;; 0 ------------ 3 +(check-equal? (ivl-join (ivl 2 +inf.0) (ivl 0 3)) (ivl 0 +inf.0)) +;; <------------- 3 +;; 1 -- 2 +(check-equal? (ivl-join (ivl -inf.0 3) (ivl 1 2)) (ivl -inf.0 3)) +;; 0 -------------> +;; 1 -- 2 +(check-equal? (ivl-join (ivl 0 +inf.0) (ivl 1 2)) (ivl 0 +inf.0)) + +;; Two infinite +;; <--------------> +;; 1 -- 2 +(check-equal? (ivl-join (ivl -inf.0 +inf.0) (ivl 1 2)) (ivl -inf.0 +inf.0)) +;; 1 --------> +;; <-------- 2 +(check-equal? (ivl-join (ivl 1 +inf.0) (ivl -inf.0 2)) (ivl -inf.0 +inf.0)) +;; <--- 1 2 ---> +(check-equal? (ivl-join (ivl -inf.0 1) (ivl 2 +inf.0)) (ivl -inf.0 +inf.0)) +;; <-------- 2 +;; <------------- 3 +(check-equal? (ivl-join (ivl -inf.0 2) (ivl -inf.0 3)) (ivl -inf.0 3)) +;; 0 -------------> +;; 1 --------> +(check-equal? (ivl-join (ivl 0 +inf.0) (ivl 1 +inf.0)) (ivl 0 +inf.0)) + +;; Three infinite +;; <--------------> +;; 1 --------> +(check-equal? (ivl-join (ivl -inf.0 +inf.0) (ivl 1 +inf.0)) (ivl -inf.0 +inf.0)) +;; <--------------> +;; <-------- 2 +(check-equal? (ivl-join (ivl -inf.0 +inf.0) (ivl -inf.0 2)) (ivl -inf.0 +inf.0)) + +;; Four infinite +(check-equal? (ivl-join (ivl -inf.0 +inf.0) (ivl -inf.0 +inf.0)) (ivl -inf.0 +inf.0)) + +;; =================================================================================================== +;; Vectors + +(check-true (vector-andmap zero? #(0 0 0 0))) +(check-false (vector-andmap zero? #(0 0 1 0))) + +(check-true (vector-andmap (λ (x y) (and (= x 1) (= y 2))) + #(1 1 1 1) + #(2 2 2 2))) +(check-false (vector-andmap (λ (x y) (and (= x 1) (= y 2))) + #(1 1 1 1) + #(2 1 2 2))) + +(check-true (vector-ormap zero? #(0 0 1 0))) +(check-false (vector-ormap zero? #(1 1 1 1))) + +(check-true (vector-ormap (λ (x y) (and (= x 1) (= y 2))) + #(0 0 1 0) + #(0 0 2 0))) +(check-false (vector-ormap (λ (x y) (and (= x 1) (= y 2))) + #(0 0 1 0) + #(0 2 0 0))) diff --git a/collects/plot/tests/plot2d-tests.rkt b/collects/plot/tests/plot2d-tests.rkt index de14312afd..2d1f6f1bd1 100644 --- a/collects/plot/tests/plot2d-tests.rkt +++ b/collects/plot/tests/plot2d-tests.rkt @@ -148,6 +148,10 @@ (λ () (plot (list (function sqr #f -1) (function sqr 1 #f))))) +; draws both functions with x in [-1,2] (meaning nothing is drawn) +(plot (list (function sqr #f -1) + (function sqr 2 #f))) + ; draws first function with x in [-2,-1] (plot (list (function sqr #f -1) (function sqr 1 #f)) @@ -411,13 +415,13 @@ #:color n #:width 2 #:style n)))) #:x-min -2 #:x-max 2))) -(let () - (define (f x) (/ (sin x) x)) - (parameterize ([plot-x-transform (stretch-transform -1 1 10)] - [plot-y-ticks (fraction-ticks)]) - (plot (list (y-axis -1 #t #:ticks? #f) (y-axis 1 #t #:ticks? #f) - (function f -1 1 #:width 2 #:color 4) - (function f -14 -1 #:color 4 #:label "y = sin(x)/x") - (function f 1 14 #:color 4) - (point-label (vector 0 1) "y → 1 as x → 0" #:anchor 'bottom-right)) - #:y-max 1.2))) +(time + (define (f x) (/ (sin x) x)) + (parameterize ([plot-x-transform (stretch-transform -1 1 10)] + [plot-y-ticks (fraction-ticks)]) + (plot (list (y-axis -1 #t #:ticks? #f) (y-axis 1 #t #:ticks? #f) + (function f -1 1 #:width 2 #:color 4) + (function f -14 -1 #:color 4 #:label "y = sin(x)/x") + (function f 1 14 #:color 4) + (point-label (vector 0 1) "y → 1 as x → 0" #:anchor 'bottom-right)) + #:y-max 1.2))) diff --git a/collects/plot/tests/tick-tests.rkt b/collects/plot/tests/tick-tests.rkt index 7281d88b80..85993e925e 100644 --- a/collects/plot/tests/tick-tests.rkt +++ b/collects/plot/tests/tick-tests.rkt @@ -4,6 +4,47 @@ (plot-font-family 'swiss) +(define (ticks-scale fun t) + (match-define (invertible-function f g) fun) + (match-define (ticks layout format) t) + (ticks (λ (x-min x-max max-ticks transform) + (define ts (layout (f x-min) (f x-max) max-ticks transform)) + (for/list ([t (in-list ts)]) + (match-define (pre-tick x major?) t) + (pre-tick (g x) major?))) + (λ (x-min x-max ts) + (format (f x-min) (f x-max) (map (λ (t) + (match-define (pre-tick x major?) t) + (pre-tick (f x) major?)) + ts))))) + +(define (linear-scale m [b 0]) + (invertible-function (λ (x) (+ (* m x) b)) + (λ (y) (/ (- y b) m)))) + +(define exp-scale + (invertible-function exp log)) + +(parameterize ([plot-y-ticks (ticks-scale (linear-scale 2 1) (plot-y-ticks))]) + (plot (list (function sqr -2 2) + (function sin -4 4)))) + +(parameterize ([plot-y-ticks (ticks-scale exp-scale (log-ticks))]) + (plot (list (function sqr -2 2) + (function sin -4 4)))) + +(parameterize ([plot-y-ticks (ticks-scale exp-scale (log-ticks))]) + (plot (function values -10 10))) + +(parameterize ([plot-y-transform log-transform] + [plot-y-ticks (log-ticks)]) + (plot (function exp -10 10))) + +(parameterize ([plot-y-ticks (ticks-append (plot-y-ticks) + (ticks-scale (linear-scale 2 1) (currency-ticks)))]) + (plot (function values -4 4))) + +#| (plot (function (λ (x) (count pre-tick-major? ((linear-ticks) 0 x 8 id-transform))) 0.1 10)) @@ -80,3 +121,4 @@ (plot (contours (λ (x y) (* 1/2 (+ (sqr x) (sqr y)))) -1 1 -1 1 #:label "z")) (plot3d (contours3d (λ (x y) (* 1/2 (+ (sqr x) (sqr y)))) -1 1 -1 1 #:label "z")) +|# \ No newline at end of file diff --git a/collects/plot/utils.rkt b/collects/plot/utils.rkt index 53ea146643..09607def27 100644 --- a/collects/plot/utils.rkt +++ b/collects/plot/utils.rkt @@ -1,10 +1,13 @@ #lang racket/base (require "common/math.rkt") +(require "common/vector.rkt") (provide bounds->intervals linear-seq linear-seq* degrees->radians - radians->degrees) + radians->degrees + empty-ivl unknown-ivl ivl-empty? ivl-known? ivl-regular? ivl-meet ivl-join + empty-rect unknown-rect rect-empty? rect-known? rect-regular? rect-meet rect-join) (require "common/format.rkt") (provide digits-for-range diff --git a/collects/tests/plot/run-tests.rkt b/collects/tests/plot/run-tests.rkt deleted file mode 100755 index 55ec13eb06..0000000000 --- a/collects/tests/plot/run-tests.rkt +++ /dev/null @@ -1,74 +0,0 @@ -#!/bin/sh -#| -*- racket -*- -exec gracket "$0" "$@" -|# -#lang racket - -(require rackunit racket/date - plot plot/utils plot/common/date-time) - -(check-equal? (linear-seq 0 1 2 #:start? #t #:end? #t) '(0 1)) -(check-equal? (linear-seq 0 1 2 #:start? #t #:end? #f) '(0 2/3)) -(check-equal? (linear-seq 0 1 2 #:start? #f #:end? #t) '(1/3 1)) -(check-equal? (linear-seq 0 1 2 #:start? #f #:end? #f) '(1/4 3/4)) - -(check-exn exn:fail:contract? - (λ () (vector-field (λ (v [z 0]) v) -4 4 -4 4)) - "Exception should be 'two of the clauses in the or/c might both match' or similar") - -;; =================================================================================================== -;; Date rounding - -(check-equal? (utc-seconds-round-year (find-seconds 0 0 12 2 7 1970 #f)) - (find-seconds 0 0 0 1 1 1970 #f)) -(check-equal? (utc-seconds-round-year (find-seconds 0 0 13 2 7 1970 #f)) - (find-seconds 0 0 0 1 1 1971 #f)) -;; A leap year's middle is a half day earlier on the calendar: -(check-equal? (utc-seconds-round-year (find-seconds 0 0 0 2 7 1976 #f)) - (find-seconds 0 0 0 1 1 1976 #f)) -(check-equal? (utc-seconds-round-year (find-seconds 0 0 1 2 7 1976 #f)) - (find-seconds 0 0 0 1 1 1977 #f)) - -(check-equal? (utc-seconds-round-month (find-seconds 0 0 0 16 1 2010 #f)) - (find-seconds 0 0 0 1 1 2010 #f)) -(check-equal? (utc-seconds-round-month (find-seconds 0 0 0 17 1 2010 #f)) - (find-seconds 0 0 0 1 2 2010 #f)) -(check-equal? (utc-seconds-round-month (find-seconds 0 0 12 16 1 2010 #f)) - (find-seconds 0 0 0 1 1 2010 #f)) -(check-equal? (utc-seconds-round-month (find-seconds 0 0 13 16 1 2010 #f)) - (find-seconds 0 0 0 1 2 2010 #f)) -(check-equal? (utc-seconds-round-month (find-seconds 0 0 0 16 12 2010 #f)) - (find-seconds 0 0 0 1 12 2010 #f)) -(check-equal? (utc-seconds-round-month (find-seconds 0 0 0 17 12 2010 #f)) - (find-seconds 0 0 0 1 1 2011 #f)) - -;; =================================================================================================== -;; Time conversion - -(check-equal? (seconds->plot-time 0) (plot-time 0 0 0 0)) -(check-equal? (seconds->plot-time #e59.999999) (plot-time #e59.999999 0 0 0)) -(check-equal? (seconds->plot-time 60) (plot-time 0 1 0 0)) -(check-equal? (seconds->plot-time #e60.000001) (plot-time #e0.000001 1 0 0)) -(check-equal? (seconds->plot-time #e119.999999) (plot-time #e59.999999 1 0 0)) -(check-equal? (seconds->plot-time 120) (plot-time 0 2 0 0)) -(check-equal? (seconds->plot-time #e120.000001) (plot-time #e0.000001 2 0 0)) -(check-equal? (seconds->plot-time 3599) (plot-time 59 59 0 0)) -(check-equal? (seconds->plot-time 3600) (plot-time 0 0 1 0)) -(check-equal? (seconds->plot-time 3601) (plot-time 1 0 1 0)) -(check-equal? (seconds->plot-time (- seconds-per-day 1)) (plot-time 59 59 23 0)) -(check-equal? (seconds->plot-time seconds-per-day) (plot-time 0 0 0 1)) -(check-equal? (seconds->plot-time (- seconds-per-day)) (plot-time 0 0 0 -1)) -(check-equal? (seconds->plot-time (- (- seconds-per-day) 1)) (plot-time 59 59 23 -2)) - -(define sec-secs (sequence->list (in-range -60 61 #e0.571123))) -(define min-secs (sequence->list (in-range (- seconds-per-hour) (+ seconds-per-hour 1) - (* #e0.571123 seconds-per-minute)))) -(define hour-secs (sequence->list (in-range (- seconds-per-day) (+ seconds-per-day 1) - (* #e0.571123 seconds-per-hour)))) -(define day-secs (sequence->list (in-range (- seconds-per-week) (+ seconds-per-week 1) - (* #e0.571123 seconds-per-day)))) -(check-equal? (map (compose plot-time->seconds seconds->plot-time) sec-secs) sec-secs) -(check-equal? (map (compose plot-time->seconds seconds->plot-time) min-secs) min-secs) -(check-equal? (map (compose plot-time->seconds seconds->plot-time) hour-secs) hour-secs) -(check-equal? (map (compose plot-time->seconds seconds->plot-time) day-secs) day-secs) -