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

Combined renderer structs and fixpoint bounds determination

Browse Source
This commit is contained in:
Neil Toronto 2011-10-18 13:05:12 -06:00
parent f593d468f7
commit 4ca0729a2f
33 changed files with 889 additions and 672 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
collects/plot/common/axis-transform.rkt
View File

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

10
collects/plot/common/contract.rkt
View File

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

82
collects/plot/common/math.rkt
View File

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

108
collects/plot/common/renderer.rkt Normal file
View File

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

75
collects/plot/common/vector.rkt
View File

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

4
collects/plot/compat.rkt
View File

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

7
collects/plot/deprecated.rkt
View File

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

11
collects/plot/main.rkt
View File

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

90
collects/plot/plot2d/bounds.rkt
View File

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

20
collects/plot/plot2d/contour.rkt
View File

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

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

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

33
collects/plot/plot2d/interval.rkt
View File

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

2
collects/plot/plot2d/kde.rkt
View File

@ -7,7 +7,7 @@
"../common/utils.rkt"
"../common/sample.rkt"
"../common/parameters.rkt"
"renderer.rkt"
"../common/renderer.rkt"
"line.rkt")
(provide kde density)

23
collects/plot/plot2d/line.rkt
View File

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

94
collects/plot/plot2d/plot.rkt
View File

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

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

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

30
collects/plot/plot2d/rectangle.rkt
View File

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

58
collects/plot/plot2d/renderer.rkt
View File

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

69
collects/plot/plot3d/bounds.rkt
View File

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

19
collects/plot/plot3d/contour.rkt
View File

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

32
collects/plot/plot3d/isosurface.rkt
View File

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

10
collects/plot/plot3d/line.rkt
View File

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

117
collects/plot/plot3d/plot.rkt
View File

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

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

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

27
collects/plot/plot3d/rectangle.rkt
View File

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

70
collects/plot/plot3d/renderer.rkt
View File

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

13
collects/plot/plot3d/surface.rkt
View File

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

2
collects/plot/tests/axis-transform-tests.rkt
View File

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

301
collects/plot/tests/low-level-tests.rkt Executable file
View File

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

24
collects/plot/tests/plot2d-tests.rkt
View File

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

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

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

5
collects/plot/utils.rkt
View File

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

74
collects/tests/plot/run-tests.rkt
View File

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