Finished first draft of tick/axis overhaul
This commit is contained in:
Neil Toronto
parent
c6cc3dfb31
commit
f593d468f7
|
|
@ -14,6 +14,7 @@
|
|||
"contract.rkt"
|
||||
"draw.rkt"
|
||||
"math.rkt"
|
||||
"vector.rkt"
|
||||
"parameters.rkt")
|
||||
|
||||
(provide plot-area% (struct-out legend-entry))
|
||||
|
|
@ -250,105 +251,118 @@
|
|||
(send dc set-alpha old-alpha))
|
||||
|
||||
(define/public (draw-point v)
|
||||
(match-define (vector x y) v)
|
||||
(send dc draw-point x y))
|
||||
(when (vregular? v)
|
||||
(match-define (vector x y) v)
|
||||
(send dc draw-point x y)))
|
||||
|
||||
(define/public (draw-polygon vs [fill-style 'winding])
|
||||
(send dc draw-polygon (map coord->cons vs) 0 0 fill-style))
|
||||
(when (andmap vregular? vs)
|
||||
(send dc draw-polygon (map coord->cons vs) 0 0 fill-style)))
|
||||
|
||||
(define/public (draw-rectangle v1 v2)
|
||||
(match-define (vector x1 y1) v1)
|
||||
(match-define (vector x2 y2) v2)
|
||||
(draw-polygon
|
||||
(list (vector x1 y1) (vector x1 y2) (vector x2 y2) (vector x2 y1))))
|
||||
(when (and (vregular? v1) (vregular? v2))
|
||||
(match-define (vector x1 y1) v1)
|
||||
(match-define (vector x2 y2) v2)
|
||||
(draw-polygon
|
||||
(list (vector x1 y1) (vector x1 y2) (vector x2 y2) (vector x2 y1)))))
|
||||
|
||||
(define/public (draw-lines vs)
|
||||
(send dc draw-lines (map coord->cons vs)))
|
||||
(when (andmap vregular? vs)
|
||||
(send dc draw-lines (map coord->cons vs))))
|
||||
|
||||
(define/public (draw-line v1 v2)
|
||||
(match-define (vector x1 y1) v1)
|
||||
(match-define (vector x2 y2) v2)
|
||||
(send dc draw-line x1 y1 x2 y2))
|
||||
(when (and (vregular? v1) (vregular? v2))
|
||||
(match-define (vector x1 y1) v1)
|
||||
(match-define (vector x2 y2) v2)
|
||||
(send dc draw-line x1 y1 x2 y2)))
|
||||
|
||||
(define/public (draw-text str v [anchor 'top-left] [angle 0] #:outline? [outline? #f])
|
||||
(match-define (vector x y) v)
|
||||
|
||||
(when outline?
|
||||
(define alpha (send dc get-alpha))
|
||||
(define fg (send dc get-text-foreground))
|
||||
(when (vregular? v)
|
||||
(match-define (vector x y) v)
|
||||
|
||||
(send dc set-alpha (alpha-expt alpha 1/8))
|
||||
(send dc set-text-foreground (send dc get-background))
|
||||
(for* ([dx (list -1 0 1)]
|
||||
[dy (list -1 0 1)]
|
||||
#:when (not (and (zero? dx) (zero? dy))))
|
||||
(draw-text/anchor dc str (+ x dx) (+ y dy) anchor #t 0 angle))
|
||||
(send dc set-alpha alpha)
|
||||
(send dc set-text-foreground fg))
|
||||
|
||||
(draw-text/anchor dc str x y anchor #t 0 angle))
|
||||
(when outline?
|
||||
(define alpha (send dc get-alpha))
|
||||
(define fg (send dc get-text-foreground))
|
||||
|
||||
(send dc set-alpha (alpha-expt alpha 1/8))
|
||||
(send dc set-text-foreground (send dc get-background))
|
||||
(for* ([dx (list -1 0 1)]
|
||||
[dy (list -1 0 1)]
|
||||
#:when (not (and (zero? dx) (zero? dy))))
|
||||
(draw-text/anchor dc str (+ x dx) (+ y dy) anchor #t 0 angle))
|
||||
(send dc set-alpha alpha)
|
||||
(send dc set-text-foreground fg))
|
||||
|
||||
(draw-text/anchor dc str x y anchor #t 0 angle)))
|
||||
|
||||
(define/public (get-text-corners str v [anchor 'top-left] [angle 0])
|
||||
(match-define (vector x y) v)
|
||||
(get-text-corners/anchor dc str x y anchor #t 0 angle))
|
||||
(when (vregular? v)
|
||||
(match-define (vector x y) v)
|
||||
(get-text-corners/anchor dc str x y anchor #t 0 angle)))
|
||||
|
||||
(define/public (draw-arrow v1 v2)
|
||||
(match-define (vector x1 y1) v1)
|
||||
(match-define (vector x2 y2) v2)
|
||||
(define dx (- x2 x1))
|
||||
(define dy (- y2 y1))
|
||||
(define angle (if (and (zero? dy) (zero? dx)) 0 (atan dy dx)))
|
||||
(define dist (sqrt (+ (sqr dx) (sqr dy))))
|
||||
(define head-r (* 2/5 dist))
|
||||
(define head-angle (* 1/6 pi))
|
||||
(define dx1 (* (cos (+ angle head-angle)) head-r))
|
||||
(define dy1 (* (sin (+ angle head-angle)) head-r))
|
||||
(define dx2 (* (cos (- angle head-angle)) head-r))
|
||||
(define dy2 (* (sin (- angle head-angle)) head-r))
|
||||
(send dc draw-line x1 y1 x2 y2)
|
||||
(send dc draw-line x2 y2 (- x2 dx1) (- y2 dy1))
|
||||
(send dc draw-line x2 y2 (- x2 dx2) (- y2 dy2)))
|
||||
(when (and (vregular? v1) (vregular? v2))
|
||||
(match-define (vector x1 y1) v1)
|
||||
(match-define (vector x2 y2) v2)
|
||||
(define dx (- x2 x1))
|
||||
(define dy (- y2 y1))
|
||||
(define angle (if (and (zero? dy) (zero? dx)) 0 (atan dy dx)))
|
||||
(define dist (sqrt (+ (sqr dx) (sqr dy))))
|
||||
(define head-r (* 2/5 dist))
|
||||
(define head-angle (* 1/6 pi))
|
||||
(define dx1 (* (cos (+ angle head-angle)) head-r))
|
||||
(define dy1 (* (sin (+ angle head-angle)) head-r))
|
||||
(define dx2 (* (cos (- angle head-angle)) head-r))
|
||||
(define dy2 (* (sin (- angle head-angle)) head-r))
|
||||
(send dc draw-line x1 y1 x2 y2)
|
||||
(send dc draw-line x2 y2 (- x2 dx1) (- y2 dy1))
|
||||
(send dc draw-line x2 y2 (- x2 dx2) (- y2 dy2))))
|
||||
|
||||
;; -----------------------------------------------------------------------------------------------
|
||||
;; Glyph (point sym) primitives
|
||||
|
||||
(define/public ((make-draw-circle-glyph r) v)
|
||||
(match-define (vector x y) v)
|
||||
(send dc draw-ellipse (- x r -1/2) (- y r -1/2) (* 2 r) (* 2 r)))
|
||||
(when (vregular? v)
|
||||
(match-define (vector x y) v)
|
||||
(send dc draw-ellipse (- x r -1/2) (- y r -1/2) (* 2 r) (* 2 r))))
|
||||
|
||||
(define/public (make-draw-polygon-glyph r sides start-angle)
|
||||
(define angles (linear-seq start-angle (+ start-angle (* 2 pi)) (+ 1 sides)))
|
||||
(λ (v)
|
||||
(match-define (vector x y) v)
|
||||
(send dc draw-polygon (map (λ (a) (cons (+ x (* (cos a) r)) (+ y (* (sin a) r))))
|
||||
angles))))
|
||||
(when (vregular? v)
|
||||
(match-define (vector x y) v)
|
||||
(send dc draw-polygon (map (λ (a) (cons (+ x (* (cos a) r)) (+ y (* (sin a) r))))
|
||||
angles)))))
|
||||
|
||||
(define/public (make-draw-star-glyph r sides start-angle)
|
||||
(define angles (linear-seq start-angle (+ start-angle (* 2 pi)) (+ 1 (* 2 sides))))
|
||||
(λ (v)
|
||||
(match-define (vector x y) v)
|
||||
(define pts
|
||||
(for/list ([a (in-list angles)] [i (in-naturals)])
|
||||
(define r-cos-a (* r (cos a)))
|
||||
(define r-sin-a (* r (sin a)))
|
||||
(cond [(odd? i) (cons (+ x r-cos-a) (+ y r-sin-a))]
|
||||
[else (cons (+ x (* 1/2 r-cos-a)) (+ y (* 1/2 r-sin-a)))])))
|
||||
(send dc draw-polygon pts)))
|
||||
(when (vregular? v)
|
||||
(match-define (vector x y) v)
|
||||
(define pts
|
||||
(for/list ([a (in-list angles)] [i (in-naturals)])
|
||||
(define r-cos-a (* r (cos a)))
|
||||
(define r-sin-a (* r (sin a)))
|
||||
(cond [(odd? i) (cons (+ x r-cos-a) (+ y r-sin-a))]
|
||||
[else (cons (+ x (* 1/2 r-cos-a)) (+ y (* 1/2 r-sin-a)))])))
|
||||
(send dc draw-polygon pts))))
|
||||
|
||||
(define/public (make-draw-flare-glyph r sticks start-angle)
|
||||
(define step (/ (* 2 pi) sticks))
|
||||
(define angles (build-list sticks (λ (n) (+ start-angle (* n step)))))
|
||||
(λ (v)
|
||||
(match-define (vector x y) v)
|
||||
(for ([a (in-list angles)])
|
||||
(send dc draw-line x y (+ x (* (cos a) r)) (+ y (* (sin a) r))))))
|
||||
(when (vregular? v)
|
||||
(match-define (vector x y) v)
|
||||
(for ([a (in-list angles)])
|
||||
(send dc draw-line x y (+ x (* (cos a) r)) (+ y (* (sin a) r)))))))
|
||||
|
||||
(define/public (make-draw-tick r angle)
|
||||
(define dx (* (cos angle) r))
|
||||
(define dy (* (sin angle) r))
|
||||
(λ (v)
|
||||
(match-define (vector x y) v)
|
||||
(send dc draw-line (- x dx) (- y dy) (+ x dx) (+ y dy))))
|
||||
(when (vregular? v)
|
||||
(match-define (vector x y) v)
|
||||
(send dc draw-line (- x dx) (- y dy) (+ x dx) (+ y dy)))))
|
||||
|
||||
(define/public (draw-tick v r angle)
|
||||
((make-draw-tick r angle) v))
|
||||
|
|
@ -363,14 +377,15 @@
|
|||
(define dx2 (* (cos (- angle head-angle)) head-r))
|
||||
(define dy2 (* (sin (- angle head-angle)) head-r))
|
||||
(λ (v)
|
||||
(match-define (vector x y) v)
|
||||
(define head-x (+ x dx))
|
||||
(define head-y (+ y dy))
|
||||
(define tail-x (- x dx))
|
||||
(define tail-y (- y dy))
|
||||
(send dc draw-line head-x head-y tail-x tail-y)
|
||||
(send dc draw-line head-x head-y (- head-x dx1) (- head-y dy1))
|
||||
(send dc draw-line head-x head-y (- head-x dx2) (- head-y dy2))))
|
||||
(when (vregular? v)
|
||||
(match-define (vector x y) v)
|
||||
(define head-x (+ x dx))
|
||||
(define head-y (+ y dy))
|
||||
(define tail-x (- x dx))
|
||||
(define tail-y (- y dy))
|
||||
(send dc draw-line head-x head-y tail-x tail-y)
|
||||
(send dc draw-line head-x head-y (- head-x dx1) (- head-y dy1))
|
||||
(send dc draw-line head-x head-y (- head-x dx2) (- head-y dy2)))))
|
||||
|
||||
(define/public (draw-arrow-glyph v r angle)
|
||||
((make-draw-arrow-glyph r angle) v))
|
||||
|
|
@ -380,8 +395,9 @@
|
|||
(define dx (* 1/2 x-size))
|
||||
(define dy (* 1/2 y-size))
|
||||
(λ (v)
|
||||
(match-define (vector x y) v)
|
||||
(send dc draw-text str (- x dx) (- y dy) #t)))
|
||||
(when (vregular? v)
|
||||
(match-define (vector x y) v)
|
||||
(send dc draw-text str (- x dx) (- y dy) #t))))
|
||||
|
||||
(define ((mix-draw-glyph d1 d2) v)
|
||||
(d1 v)
|
||||
|
|
|
|||
|
|
@ -5,29 +5,70 @@
|
|||
"contract.rkt" "contract-doc.rkt")
|
||||
|
||||
(provide (struct-out invertible-function)
|
||||
make-axis-transform
|
||||
id-function
|
||||
axis-transform/c
|
||||
id-transform
|
||||
apply-transform
|
||||
make-axis-transform
|
||||
axis-transform-compose
|
||||
log-transform
|
||||
cbrt-transform
|
||||
hand-drawn-transform)
|
||||
hand-drawn-transform
|
||||
stretch-transform
|
||||
collapse-transform)
|
||||
|
||||
(define-struct/contract invertible-function ([f (real? . -> . real?)] [finv (real? . -> . real?)])
|
||||
#:transparent)
|
||||
|
||||
(define (invertible-compose f1 f2)
|
||||
(match-let ([(invertible-function f1 g1) f1]
|
||||
[(invertible-function f2 g2) f2])
|
||||
(invertible-function (compose f1 f2) (compose g2 g1))))
|
||||
|
||||
(define axis-transform/c (real? real? invertible-function? . -> . invertible-function?))
|
||||
|
||||
(defproc (id-transform [x-min real?] [x-max real?] [old-function invertible-function?]
|
||||
) invertible-function?
|
||||
old-function)
|
||||
|
||||
(define id-function (invertible-function (λ (x) x) (λ (x) x)))
|
||||
|
||||
(defproc (apply-transform [t axis-transform/c] [x-min real?] [x-max real?]) invertible-function?
|
||||
(t x-min x-max id-function))
|
||||
|
||||
;; Turns any total, surjective, monotone flonum op and its inverse into an axis transform
|
||||
(define ((make-axis-transform flop flinv) x-min x-max)
|
||||
(let ([x-min (exact->inexact x-min)]
|
||||
[x-max (exact->inexact x-max)])
|
||||
(define fx-min (flop x-min))
|
||||
(define fx-scale (fl/ (fl- x-max x-min)
|
||||
(fl- (flop x-max) fx-min)))
|
||||
(define (f x)
|
||||
(fl+ x-min (fl* (fl- (flop (exact->inexact x)) fx-min)
|
||||
fx-scale)))
|
||||
(define (finv y)
|
||||
(flinv (fl+ fx-min (fl/ (fl- (exact->inexact y) x-min)
|
||||
fx-scale))))
|
||||
(invertible-function f finv)))
|
||||
(define ((make-axis-transform f g) x-min x-max old-function)
|
||||
(define fx-min (f x-min))
|
||||
(define fx-scale (/ (- x-max x-min) (- (f x-max) fx-min)))
|
||||
(define (new-f x) (+ x-min (* (- (f x) fx-min) fx-scale)))
|
||||
(define (new-g y) (g (+ fx-min (/ (- y x-min) fx-scale))))
|
||||
(invertible-compose (invertible-function new-f new-g) old-function))
|
||||
|
||||
;; ===================================================================================================
|
||||
;; Axis transform combinators
|
||||
|
||||
(defproc (axis-transform-compose [t1 axis-transform/c] [t2 axis-transform/c]) axis-transform/c
|
||||
(λ (x-min x-max old-function)
|
||||
(t1 x-min x-max (t2 x-min x-max old-function))))
|
||||
|
||||
(defproc (axis-transform-append [t1 axis-transform/c] [t2 axis-transform/c] [x-mid real?]
|
||||
) axis-transform/c
|
||||
(λ (x-min x-max old-function)
|
||||
(match-define (invertible-function old-f old-g) old-function)
|
||||
(let ([x-mid (old-f x-mid)])
|
||||
(cond [(x-mid . >= . x-max) (t1 x-min x-max old-function)]
|
||||
[(x-mid . <= . x-min) (t2 x-min x-max old-function)]
|
||||
[else
|
||||
(match-define (invertible-function f1 g1) (t1 x-min x-mid old-function))
|
||||
(match-define (invertible-function f2 g2) (t2 x-mid x-max old-function))
|
||||
((make-axis-transform (λ (x) (cond [((old-f x) . < . x-mid) (f1 x)]
|
||||
[else (f2 x)]))
|
||||
(λ (x) (cond [(x . < . x-mid) (g1 x)]
|
||||
[else (g2 x)])))
|
||||
x-min x-max id-function)]))))
|
||||
|
||||
(defproc (axis-transform-bound [t axis-transform/c] [x-min real?] [x-max real?]) axis-transform/c
|
||||
(axis-transform-append (axis-transform-append id-transform t x-min) id-transform x-max))
|
||||
|
||||
;; ===================================================================================================
|
||||
;; Specific axis transforms
|
||||
|
|
@ -65,21 +106,60 @@
|
|||
(let ([x (exact->inexact x)])
|
||||
(fl* x (fl* x x))))
|
||||
|
||||
(define (real-log x)
|
||||
(fllog (exact->inexact x)))
|
||||
|
||||
(defproc (id-transform [x-min real?] [x-max real?]) invertible-function?
|
||||
(invertible-function values values))
|
||||
(define (real-exp x)
|
||||
(flexp (exact->inexact x)))
|
||||
|
||||
(defproc (log-transform [x-min real?] [x-max real?]) invertible-function?
|
||||
(defproc (log-transform [x-min real?] [x-max real?] [old-function invertible-function?]
|
||||
) invertible-function?
|
||||
(when ((exact->inexact x-min) . <= . 0)
|
||||
(raise-type-error 'log-transform "positive real" 0 x-min x-max))
|
||||
((make-axis-transform fllog flexp) x-min x-max))
|
||||
((make-axis-transform real-log real-exp) x-min x-max old-function))
|
||||
|
||||
(define cbrt-trans (make-axis-transform cbrt cube))
|
||||
(defproc (cbrt-transform [x-min real?] [x-max real?] [old-function invertible-function?]
|
||||
) invertible-function?
|
||||
((make-axis-transform cbrt cube) x-min x-max old-function))
|
||||
|
||||
(defproc (cbrt-transform [x-min real?] [x-max real?]) invertible-function?
|
||||
(cbrt-trans x-min x-max))
|
||||
(defproc (hand-drawn-transform [freq (>/c 0)]) axis-transform/c
|
||||
(λ (x-min x-max old-function)
|
||||
(define d (/ freq (- x-max x-min)))
|
||||
((make-axis-transform (sine-diag d) (sine-diag-inv d)) x-min x-max old-function)))
|
||||
|
||||
(defproc (hand-drawn-transform [freq (>/c 0)]) (real? real? . -> . invertible-function?)
|
||||
(λ (mn mx)
|
||||
(define d (/ freq (- mx mn)))
|
||||
((make-axis-transform (sine-diag d) (sine-diag-inv d)) mn mx)))
|
||||
;; ===================================================================================================
|
||||
|
||||
(define (stretch a b s)
|
||||
(define d (- b a))
|
||||
(define ds (* d s))
|
||||
(λ (x)
|
||||
(cond [(x . < . a) x]
|
||||
[(x . > . b) (+ (- x d) ds)]
|
||||
[else (+ a (* (- x a) s))])))
|
||||
|
||||
(defproc (stretch-transform [a real?] [b real?] [scale (and/c real? (not/c (=/c 0)))]
|
||||
) axis-transform/c
|
||||
(when (a . > . b) (error 'stretch-transform "expected a <= b; given ~e and ~e" a b))
|
||||
(λ (x-min x-max old-function)
|
||||
(match-define (invertible-function old-f old-g) old-function)
|
||||
(let ([a (old-f a)]
|
||||
[b (old-f b)])
|
||||
(define f (stretch a b scale))
|
||||
(define g (stretch (f a) (f b) (/ 1 scale)))
|
||||
((make-axis-transform f g) x-min x-max old-function))))
|
||||
|
||||
(defproc (collapse-transform [a real?] [b real?]) axis-transform/c
|
||||
(when (a . > . b) (error 'stretch-transform "expected a <= b; given ~e and ~e" a b))
|
||||
(λ (x-min x-max old-function)
|
||||
(match-define (invertible-function old-f old-g) old-function)
|
||||
(let ([a (old-f a)]
|
||||
[b (old-f b)])
|
||||
(define 1/2size (* 1/2 (- b a)))
|
||||
(define center (* 1/2 (+ a b)))
|
||||
(define (f x) (cond [(x . < . a) (+ x 1/2size)]
|
||||
[(x . > . b) (- x 1/2size)]
|
||||
[else center]))
|
||||
(define (g x) (cond [(x . < . center) (- x 1/2size)]
|
||||
[(x . > . center) (+ x 1/2size)]
|
||||
[else center]))
|
||||
((make-axis-transform f g) x-min x-max old-function))))
|
||||
|
|
|
|||
|
|
@ -9,7 +9,7 @@
|
|||
(prefix-in s. scribble/core)
|
||||
(prefix-in s. scribble/html-properties))
|
||||
|
||||
(provide defproc defparam defcontract doc-apply)
|
||||
(provide defproc defparam defthing defcontract doc-apply)
|
||||
|
||||
(begin-for-syntax
|
||||
(struct proc+doc (proc-transformer doc-transformer)
|
||||
|
|
@ -148,6 +148,24 @@
|
|||
(quasisyntax/loc stx
|
||||
(defparam name #,(parameter-name->arg-name #'name) contract default))]))
|
||||
|
||||
(define-syntax (defthing stx)
|
||||
(syntax-parse stx
|
||||
[(_ name:id contract:expr value:expr)
|
||||
(with-syntax ([value-name (make-value-name #'name)]
|
||||
[serialized-contract (serialize-syntax #'contract)])
|
||||
(syntax/loc stx
|
||||
(begin
|
||||
(define/contract value-name contract value)
|
||||
(define-syntax name
|
||||
(make-proc+doc
|
||||
#'value-name
|
||||
(λ (doc-stx)
|
||||
(syntax-case doc-stx ()
|
||||
[(ctx . pre-flows)
|
||||
(with-syntax ([doc-name (make-doc-name #'ctx #'name)]
|
||||
[doc-contract (unserialize-syntax #'ctx 'serialized-contract)])
|
||||
#'(s.defthing doc-name doc-contract . pre-flows))])))))))]))
|
||||
|
||||
;; Define a contract or a procedure that returns a contract
|
||||
(define-syntax (defcontract stx)
|
||||
(syntax-parse stx
|
||||
|
|
|
|||
122
collects/plot/common/currency.rkt
Normal file
122
collects/plot/common/currency.rkt
Normal file
|
|
@ -0,0 +1,122 @@
|
|||
#lang racket/base
|
||||
|
||||
(provide (all-defined-out))
|
||||
|
||||
(define currency-code->sign
|
||||
#hash((ALL . "Lek")
|
||||
(AFN . "\u60b")
|
||||
(ARS . "$")
|
||||
(AWG . "\u192")
|
||||
(AUD . "$")
|
||||
(AZN . "\u43c\u430\u43d")
|
||||
(BSD . "$")
|
||||
(BBD . "$")
|
||||
(BYR . "p.")
|
||||
(BZD . "BZ$")
|
||||
(BMD . "$")
|
||||
(BOB . "$b")
|
||||
(BAM . "KM")
|
||||
(BWP . "P")
|
||||
(BGN . "\u43b\u432")
|
||||
(BRL . "R$")
|
||||
(BND . "$")
|
||||
(KHR . "\u17db")
|
||||
(CAD . "$")
|
||||
(KYD . "$")
|
||||
(CLP . "$")
|
||||
(CNY . "\ua5")
|
||||
(COP . "$")
|
||||
(CRC . "\u20a1")
|
||||
(HRK . "kn")
|
||||
(CUP . "\u20b1")
|
||||
(CZK . "\u4b\u10d")
|
||||
(DKK . "kr")
|
||||
(DOP . "RD$")
|
||||
(XCD . "$")
|
||||
(EGP . "\ua3")
|
||||
(SVC . "$")
|
||||
(EEK . "kr")
|
||||
(EUR . "\u20ac")
|
||||
(FKP . "\ua3")
|
||||
(FJD . "$")
|
||||
(GHC . "\ua2")
|
||||
(GIP . "\ua3")
|
||||
(GTQ . "Q")
|
||||
(GGP . "\ua3")
|
||||
(GYD . "$")
|
||||
(HNL . "L")
|
||||
(HKD . "$")
|
||||
(HUF . "Ft")
|
||||
(ISK . "kr")
|
||||
(INR . "\u20B9")
|
||||
(IDR . "Rp")
|
||||
(IRR . "\ufdfc")
|
||||
(IMP . "\ua3")
|
||||
(ILS . "\u20aa")
|
||||
(JMD . "J$")
|
||||
(JPY . "\ua5")
|
||||
(JEP . "\ua3")
|
||||
(KZT . "\u43b\u432")
|
||||
(KPW . "\u20a9")
|
||||
(KRW . "\u20a9")
|
||||
(KGS . "\u43b\u432")
|
||||
(LAK . "\u20ad")
|
||||
(LVL . "Ls")
|
||||
(LBP . "\ua3")
|
||||
(LRD . "$")
|
||||
(LTL . "Lt")
|
||||
(MKD . "\u434\u435\u43d")
|
||||
(MYR . "RM")
|
||||
(MUR . "\u20a8")
|
||||
(MXN . "$")
|
||||
(MNT . "\u20ae")
|
||||
(MZN . "MT")
|
||||
(NAD . "$")
|
||||
(NPR . "\u20a8")
|
||||
(ANG . "\u192")
|
||||
(NZD . "$")
|
||||
(NIO . "C$")
|
||||
(NGN . "\u20a6")
|
||||
(KPW . "\u20a9")
|
||||
(NOK . "kr")
|
||||
(OMR . "\ufdfc")
|
||||
(PKR . "\u20a8")
|
||||
(PAB . "B/.")
|
||||
(PYG . "Gs")
|
||||
(PEN . "S/.")
|
||||
(PHP . "\u20b1")
|
||||
(PLN . "z\u142")
|
||||
(QAR . "\ufdfc")
|
||||
(RON . "lei")
|
||||
(RUB . "\u440\u443\u431")
|
||||
(SHP . "\ua3")
|
||||
(SAR . "\ufdfc")
|
||||
(RSD . "\u414\u438\u43d.")
|
||||
(SCR . "\u20a8")
|
||||
(SGD . "$")
|
||||
(SBD . "$")
|
||||
(SOS . "S")
|
||||
(ZAR . "R")
|
||||
(KRW . "\u20a9")
|
||||
(LKR . "\u20a8")
|
||||
(SEK . "kr")
|
||||
(CHF . "CHF")
|
||||
(SRD . "$")
|
||||
(SYP . "\ua3")
|
||||
(TWD . "NT$")
|
||||
(THB . "\ue3f")
|
||||
(TTD . "TT$")
|
||||
(TRY . "TL")
|
||||
(TRL . "\u20a4")
|
||||
(TVD . "$")
|
||||
(UAH . "\u20b4")
|
||||
(GBP . "\ua3")
|
||||
(USD . "$")
|
||||
(UYU . "$U")
|
||||
(UZS . "\u43b\u432")
|
||||
(VEF . "Bs")
|
||||
(VND . "\u20ab")
|
||||
(YER . "\ufdfc")
|
||||
(ZWD . "Z$")))
|
||||
|
||||
(define known-currency-codes (sort (hash-keys currency-code->sign) string<=? #:key symbol->string))
|
||||
186
collects/plot/common/date-time.rkt
Normal file
186
collects/plot/common/date-time.rkt
Normal file
|
|
@ -0,0 +1,186 @@
|
|||
#lang racket/base
|
||||
|
||||
(require racket/date racket/contract racket/match
|
||||
(prefix-in srfi-date: srfi/19)
|
||||
db
|
||||
"contract.rkt"
|
||||
"contract-doc.rkt"
|
||||
"math.rkt"
|
||||
"format.rkt")
|
||||
|
||||
(provide (all-defined-out))
|
||||
|
||||
(define seconds-per-minute 60)
|
||||
(define seconds-per-hour (* 60 seconds-per-minute))
|
||||
(define seconds-per-day (* 24 seconds-per-hour))
|
||||
(define seconds-per-week (* 7 seconds-per-day))
|
||||
(define avg-seconds-per-year (* #e365.2425 seconds-per-day))
|
||||
(define avg-seconds-per-month (* 1/12 avg-seconds-per-year))
|
||||
|
||||
;; ===================================================================================================
|
||||
;; UTC dates for plotting
|
||||
|
||||
;; A date is always represented by the number of seconds since the platform-specific, UTC epoch
|
||||
|
||||
(define (date*->seconds dt [local-time? #t])
|
||||
(match-define (date* s mn h d m y wd yd dst? tz ns tz-name)
|
||||
dt)
|
||||
(+ (date->seconds (date s mn h d m y wd yd dst? tz) local-time?)
|
||||
(/ ns 1000000000)))
|
||||
|
||||
(define (date*->utc-seconds dt)
|
||||
(- (date*->seconds dt #f) (date-time-zone-offset dt)))
|
||||
|
||||
(define (date->utc-seconds dt)
|
||||
(- (date->seconds dt #f) (date-time-zone-offset dt)))
|
||||
|
||||
(define (utc-seconds-second secs)
|
||||
(define w (floor secs))
|
||||
(define f (- secs w))
|
||||
(+ f (date-second (seconds->date w #f))))
|
||||
|
||||
(define (utc-seconds-round-year secs)
|
||||
(define dt (seconds->date secs #f))
|
||||
(define y1 (date-year dt))
|
||||
;; Find start of this year, start of next year, and difference between them in UTC seconds
|
||||
(define s1 (date->seconds (date 0 0 0 1 1 y1 0 0 #f 0) #f))
|
||||
(define s2 (date->seconds (date 0 0 0 1 1 (+ y1 1) 0 0 #f 0) #f))
|
||||
(define diff (- s2 s1))
|
||||
;; Round by 1) subtracting this year; 2) rounding to this year or next; 3) adding this year
|
||||
(+ (* (round (/ (- secs s1) diff)) diff) s1))
|
||||
|
||||
(define (utc-seconds-round-month secs)
|
||||
(define dt (seconds->date secs #f))
|
||||
(define m1 (date-month dt))
|
||||
(define y1 (date-year dt))
|
||||
;; Find start of this month, start of next month, and difference between them in UTC seconds
|
||||
(define s1 (date->seconds (date 0 0 0 1 m1 y1 0 0 #f 0) #f))
|
||||
(define-values (m2 y2) (cond [((+ m1 1) . > . 12) (values 1 (+ y1 1))]
|
||||
[else (values (+ m1 1) y1)]))
|
||||
(define s2 (date->seconds (date 0 0 0 1 m2 y2 0 0 #f 0) #f))
|
||||
(define diff (- s2 s1))
|
||||
;; Round by 1) subtracting this month; 2) rounding to this month or next; 3) adding this month
|
||||
(+ (* (round (/ (- secs s1) diff)) diff) s1))
|
||||
|
||||
;; ===================================================================================================
|
||||
;; Time
|
||||
|
||||
;; A date-independent representation of time
|
||||
|
||||
(define-struct/contract plot-time ([second (and/c (>=/c 0) (</c 60))]
|
||||
[minute (integer-in 0 59)]
|
||||
[hour (integer-in 0 23)]
|
||||
[day exact-integer?]
|
||||
) #:transparent)
|
||||
|
||||
(define (seconds->plot-time s)
|
||||
(let* ([s (inexact->exact s)]
|
||||
[day (floor (/ s seconds-per-day))]
|
||||
[s (- s (* day seconds-per-day))]
|
||||
[hour (floor (/ s seconds-per-hour))]
|
||||
[s (- s (* hour seconds-per-hour))]
|
||||
[minute (floor (/ s seconds-per-minute))]
|
||||
[s (- s (* minute seconds-per-minute))])
|
||||
(plot-time s minute hour day)))
|
||||
|
||||
(define (plot-time->seconds t)
|
||||
(match-define (plot-time second minute hour day) t)
|
||||
(+ second
|
||||
(* minute seconds-per-minute)
|
||||
(* hour seconds-per-hour)
|
||||
(* day seconds-per-day)))
|
||||
|
||||
(defproc (datetime->real [x (or/c plot-time? date? date*? sql-date? sql-time? sql-timestamp?)]) real?
|
||||
(match x
|
||||
[(? plot-time?) (plot-time->seconds x)]
|
||||
[(? date*?) (date*->utc-seconds x)]
|
||||
[(? date?) (date->utc-seconds x)]
|
||||
[(sql-date y m d) (date->utc-seconds (date 0 0 0 d m y 0 0 #t 0))]
|
||||
[(sql-time h m s ns tz) (plot-time->seconds (- (plot-time (+ s (/ ns 1000000000)) m h 0)
|
||||
(if tz tz 0)))]
|
||||
[(sql-timestamp y m d h mn s ns tz) (date*->utc-seconds
|
||||
(date* s mn h d m y 0 0 #t (if tz tz 0) ns "UTC"))]))
|
||||
|
||||
;; ===================================================================================================
|
||||
;; Formatting following SRFI 19, with alterations
|
||||
|
||||
#|
|
||||
Supported format specifiers:
|
||||
|
||||
~a locale's abbreviated weekday name (Sun...Sat)
|
||||
~A locale's full weekday name (Sunday...Saturday)
|
||||
~b locale's abbreviate month name (Jan...Dec)
|
||||
~B locale's full month day (January...December)
|
||||
~d day of month, zero padded (01...31)
|
||||
~D date (mm/dd/yy)
|
||||
~e day of month, blank padded ( 1...31)
|
||||
~h same as ~b
|
||||
~H hour, zero padded, 24-hour clock (00...23)
|
||||
~I hour, zero padded, 12-hour clock (01...12)
|
||||
~j day of year, zero padded
|
||||
~k hour, blank padded, 24-hour clock (00...23)
|
||||
~l hour, blank padded, 12-hour clock (01...12)
|
||||
~m month, zero padded (01...12)
|
||||
~M minute, zero padded (00...59)
|
||||
~N nanosecond, zero padded
|
||||
~p locale's AM or PM
|
||||
~r time, 12 hour clock, same as "~I:~M:~S ~p"
|
||||
~S second, zero padded (00...60)
|
||||
~f seconds+fractional seconds, using locale's decimal separator (e.g. 5.2).
|
||||
~s number of full seconds since "the epoch" (in UTC)
|
||||
~T time, 24 hour clock, same as "~H:~M:~S"
|
||||
~U week number of year with Sunday as first day of week (00...53)
|
||||
~V week number of year with Monday as first day of week (01...52)
|
||||
~w day of week (0...6)
|
||||
~W week number of year with Monday as first day of week (01...52)
|
||||
~x week number of year with Monday as first day of week (00...53)
|
||||
~X locale's date representation, for example: "07/31/00"
|
||||
~y last two digits of year (00...99)
|
||||
~Y year
|
||||
~1 ISO-8601 year-month-day format
|
||||
~3 ISO-8601 hour-minute-second format
|
||||
~5 ISO-8601 year-month-day-hour-minute-second format
|
||||
|#
|
||||
|
||||
(define (plot-date-formatter x-min x-max)
|
||||
(define digits (digits-for-range x-min x-max))
|
||||
(λ (fmt secs)
|
||||
(case fmt
|
||||
[(~f) (define s (utc-seconds-second secs))
|
||||
(define str (real->string/trunc s (max 0 digits)))
|
||||
(if (s . < . 10) (format "0~a" str) str)]
|
||||
[(~s) (real->plot-label secs digits)]
|
||||
[(~a ~A ~b ~B ~d ~D ~e ~h ~H ~I ~j ~k ~l ~m ~M ~N
|
||||
~p ~r ~S ~f ~s ~T ~U ~V ~w ~W ~x ~X ~y ~Y ~1 ~3 ~5)
|
||||
(match-define (date* s mn h d m y _wd _yd _dst? tz ns _tz-name)
|
||||
(seconds->date secs #f))
|
||||
(srfi-date:date->string (srfi-date:make-date ns s mn h d m y tz) (symbol->string fmt))]
|
||||
[else #f])))
|
||||
|
||||
#|
|
||||
Supported format specifiers:
|
||||
|
||||
~d day
|
||||
~H hour, zero padded, 24-hour clock (00...23)
|
||||
~I hour, zero padded, 12-hour clock (01...12)
|
||||
~k hour, blank padded, 24-hour clock ( 0...23)
|
||||
~l hour, blank padded, 12-hour clock ( 1...12)
|
||||
~p locale's AM or PM
|
||||
~M minute, zero padded (00...59)
|
||||
~S second, zero padded (00...60)
|
||||
~f seconds+fractional seconds, using locale's decimal separator (e.g. 5.2).
|
||||
~s second, formatted (nanoseconds, etc.)
|
||||
~r time, 12 hour clock, same as "~I:~M:~S ~p"
|
||||
~T time, 24 hour clock, same as "~H:~M:~S"
|
||||
~3 ISO-8601 hour-minute-second format
|
||||
|#
|
||||
|
||||
(define (plot-time-formatter x-min x-max)
|
||||
(define digits (digits-for-range x-min x-max))
|
||||
(λ (fmt secs)
|
||||
(case fmt
|
||||
[(~H ~I ~k ~l ~p ~M ~S ~f ~s ~r ~T ~3)
|
||||
((plot-date-formatter x-min x-max) fmt (real-modulo secs seconds-per-day))]
|
||||
[(~d) (define digits (digits-for-range (/ x-min seconds-per-day) (/ x-max seconds-per-day)))
|
||||
(real->plot-label (plot-time-day (seconds->plot-time secs)) digits)]
|
||||
[else #f])))
|
||||
|
|
@ -4,9 +4,46 @@
|
|||
|
||||
(require racket/string racket/list racket/pretty racket/contract racket/match
|
||||
"math.rkt"
|
||||
"contract.rkt" "contract-doc.rkt")
|
||||
"contract.rkt"
|
||||
"contract-doc.rkt")
|
||||
|
||||
(provide digits-for-range real->plot-label ->plot-label real->string/trunc)
|
||||
(provide integer->superscript
|
||||
real->decimal-string* real->string/trunc
|
||||
digits-for-range real->plot-label ->plot-label
|
||||
parse-format-string apply-formatter)
|
||||
|
||||
(define (string-map f str)
|
||||
(list->string (map f (string->list str))))
|
||||
|
||||
(defproc (integer->superscript [x exact-integer?]) string?
|
||||
(string-map (λ (c) (case c
|
||||
[(#\0) #\u2070]
|
||||
[(#\1) #\u00b9]
|
||||
[(#\2) #\u00b2]
|
||||
[(#\3) #\u00b3]
|
||||
[(#\4) #\u2074]
|
||||
[(#\5) #\u2075]
|
||||
[(#\6) #\u2076]
|
||||
[(#\7) #\u2077]
|
||||
[(#\8) #\u2078]
|
||||
[(#\9) #\u2079]
|
||||
[(#\+) #\u207a]
|
||||
[(#\-) #\u207b]
|
||||
[else c]))
|
||||
(number->string x)))
|
||||
|
||||
(defproc (real->decimal-string* [x real?]
|
||||
[min-digits exact-nonnegative-integer?]
|
||||
[max-digits exact-nonnegative-integer? min-digits]) string?
|
||||
(when (min-digits . > . max-digits)
|
||||
(error 'real->decimal-string* "expected min-digits <= max-digits; given ~e and ~e"
|
||||
min-digits max-digits))
|
||||
(define str (real->decimal-string x max-digits))
|
||||
(let loop ([i (string-length str)] [j (- max-digits min-digits)])
|
||||
(cond [(zero? j) (substring str 0 i)]
|
||||
[(zero? i) "0"] ; shouldn't happen, as real->decimal-string guarantees a "0." prefix
|
||||
[(char=? #\0 (string-ref str (- i 1))) (loop (- i 1) (- j 1))]
|
||||
[else (substring str 0 i)])))
|
||||
|
||||
(define (remove-trailing-zeros str)
|
||||
(let loop ([i (string-length str)])
|
||||
|
|
@ -19,7 +56,7 @@
|
|||
(defproc (digits-for-range [x-min real?] [x-max real?]
|
||||
[extra-digits exact-integer? 3]) exact-integer?
|
||||
(define range (abs (- x-max x-min)))
|
||||
(+ extra-digits (if (zero? range) 0 (- (floor-log10 range)))))
|
||||
(+ extra-digits (if (zero? range) 0 (- (floor-log/base 10 range)))))
|
||||
|
||||
(define (int-str->e-str str)
|
||||
(define n (string-length str))
|
||||
|
|
@ -27,37 +64,42 @@
|
|||
[else
|
||||
(define fst (substring str 0 1))
|
||||
(define rst (substring str 1 n))
|
||||
(format "~ae~a" (remove-trailing-zeros (format "~a.~a" fst rst)) (sub1 n))]))
|
||||
(format "~a×10~a"
|
||||
(remove-trailing-zeros (format "~a.~a" fst rst))
|
||||
(integer->superscript (sub1 n)))]))
|
||||
|
||||
#;
|
||||
(begin
|
||||
(require rackunit)
|
||||
(check-equal? (int-str->e-str "") "0")
|
||||
(check-equal? (int-str->e-str "0") "0")
|
||||
(check-equal? (int-str->e-str "10") "1e1"))
|
||||
(check-equal? (int-str->e-str "10") "1×10\u00b9"))
|
||||
|
||||
(define (frac-str->e-str str)
|
||||
(define n (string-length str))
|
||||
(let loop ([i 0])
|
||||
(cond [(= i n) "0"]
|
||||
[(char=? #\0 (string-ref str i)) (loop (add1 i))]
|
||||
[else
|
||||
(define fst (substring str i (add1 i)))
|
||||
(define rst (substring str (add1 i) n))
|
||||
(cond [(= 0 (string-length rst)) (format "~ae~a" fst (- (add1 i)))]
|
||||
[else (format "~a.~ae~a" fst rst (- (add1 i)))])])))
|
||||
[else (define fst (substring str i (add1 i)))
|
||||
(define rst (substring str (add1 i) n))
|
||||
(cond [(= 0 (string-length rst))
|
||||
(format "~a×10~a" fst (integer->superscript (- (add1 i))))]
|
||||
[else
|
||||
(format "~a.~a×10~a" fst rst (integer->superscript (- (add1 i))))])])))
|
||||
|
||||
#;
|
||||
(begin
|
||||
(require rackunit)
|
||||
(check-equal? (frac-str->e-str "") "0")
|
||||
(check-equal? (frac-str->e-str "0") "0")
|
||||
(check-equal? (frac-str->e-str "00") "0")
|
||||
(check-equal? (frac-str->e-str "1") "1e-1")
|
||||
(check-equal? (frac-str->e-str "01") "1e-2"))
|
||||
(check-equal? (frac-str->e-str "1") "1×10\u207b\u00b9")
|
||||
(check-equal? (frac-str->e-str "01") "1×10\u207b\u00b2"))
|
||||
|
||||
(define (zero-string n)
|
||||
(list->string (build-list n (λ _ #\0))))
|
||||
|
||||
(defproc (real->plot-label [x real?] [digits exact-integer?]) any
|
||||
(defproc (real->plot-label [x real?] [digits exact-integer?] [scientific? boolean? #t]) any
|
||||
(cond
|
||||
[(zero? x) "0"]
|
||||
[else
|
||||
|
|
@ -72,36 +114,43 @@
|
|||
(match-let ([(list _ int-str frac-str)
|
||||
(regexp-match #rx"(.*)\\.(.*)" (real->decimal-string y (max 0 digits)))])
|
||||
(values int-str (remove-trailing-zeros frac-str))))
|
||||
;; Get scientific notation for the integer and fractional parts
|
||||
(define int-e-str (int-str->e-str int-str))
|
||||
(define frac-e-str (frac-str->e-str frac-str))
|
||||
;(printf "int-str = ~v, frac-str = ~v~n" int-str frac-str)
|
||||
;(printf "int-e-str = ~v, frac-e-str = ~v~n" int-e-str frac-e-str)
|
||||
(define int-zero? (string=? int-str "0"))
|
||||
(define frac-zero? (string=? frac-str "0"))
|
||||
(define int-e-zero? (string=? int-e-str "0"))
|
||||
(define frac-e-zero? (string=? frac-e-str "0"))
|
||||
;; Build a list of possible output strings
|
||||
(define strs
|
||||
(list (cond [(and int-zero? frac-zero?) "0"]
|
||||
[int-zero? (format "~a.~a" front-sign frac-str)]
|
||||
[frac-zero? (format "~a~a" front-sign int-str)]
|
||||
[else (format "~a~a.~a" front-sign int-str frac-str)])
|
||||
(cond [(and int-e-zero? frac-zero?) "0"]
|
||||
[int-e-zero? (format "~a.~a" front-sign frac-str)]
|
||||
[frac-zero? (format "~a~a" front-sign int-e-str)]
|
||||
[else (format "~a(~a)~a.~a" front-sign int-e-str mid-sign frac-str)])
|
||||
(cond [(and int-zero? frac-e-zero?) "0"]
|
||||
[int-zero? (format "~a~a" front-sign frac-e-str)]
|
||||
[frac-e-zero? (format "~a~a" front-sign int-str)]
|
||||
[else (format "~a~a~a(~a)" front-sign int-str mid-sign frac-e-str)])
|
||||
(cond [(and int-e-zero? frac-e-zero?) "0"]
|
||||
[int-e-zero? (format "~a~a" front-sign frac-e-str)]
|
||||
[frac-e-zero? (format "~a~a" front-sign int-e-str)]
|
||||
[else
|
||||
(format "~a(~a)~a(~a)" front-sign int-e-str mid-sign frac-e-str)])))
|
||||
;; Return the shortest possible output string
|
||||
(argmin string-length strs))]))
|
||||
(cond
|
||||
[scientific?
|
||||
;; Get scientific notation for the integer and fractional parts
|
||||
(define int-e-str (int-str->e-str int-str))
|
||||
(define frac-e-str (frac-str->e-str frac-str))
|
||||
;(printf "int-str = ~v, frac-str = ~v~n" int-str frac-str)
|
||||
;(printf "int-e-str = ~v, frac-e-str = ~v~n" int-e-str frac-e-str)
|
||||
(define int-e-zero? (string=? int-e-str "0"))
|
||||
(define frac-e-zero? (string=? frac-e-str "0"))
|
||||
;; Build a list of possible output strings
|
||||
(define strs
|
||||
(list (cond [(and int-zero? frac-zero?) "0"]
|
||||
[int-zero? (format "~a.~a" front-sign frac-str)]
|
||||
[frac-zero? (format "~a~a" front-sign int-str)]
|
||||
[else (format "~a~a.~a" front-sign int-str frac-str)])
|
||||
(cond [(and int-e-zero? frac-zero?) "0"]
|
||||
[int-e-zero? (format "~a.~a" front-sign frac-str)]
|
||||
[frac-zero? (format "~a~a" front-sign int-e-str)]
|
||||
[else (format "~a(~a)~a.~a" front-sign int-e-str mid-sign frac-str)])
|
||||
(cond [(and int-zero? frac-e-zero?) "0"]
|
||||
[int-zero? (format "~a~a" front-sign frac-e-str)]
|
||||
[frac-e-zero? (format "~a~a" front-sign int-str)]
|
||||
[else (format "~a~a~a(~a)" front-sign int-str mid-sign frac-e-str)])
|
||||
(cond [(and int-e-zero? frac-e-zero?) "0"]
|
||||
[int-e-zero? (format "~a~a" front-sign frac-e-str)]
|
||||
[frac-e-zero? (format "~a~a" front-sign int-e-str)]
|
||||
[else
|
||||
(format "~a(~a)~a(~a)" front-sign int-e-str mid-sign frac-e-str)])))
|
||||
;; Return the shortest possible output string
|
||||
(argmin string-length strs)]
|
||||
[else
|
||||
(cond [(and int-zero? frac-zero?) "0"]
|
||||
[int-zero? (format "~a.~a" front-sign frac-str)]
|
||||
[frac-zero? (format "~a~a" front-sign int-str)]
|
||||
[else (format "~a~a.~a" front-sign int-str frac-str)])]))]))
|
||||
|
||||
(defproc (->plot-label [a any/c] [digits exact-integer? 7]) string?
|
||||
(let loop ([a a])
|
||||
|
|
@ -117,3 +166,24 @@
|
|||
;; Like real->decimal-string, but removes trailing zeros
|
||||
(defproc (real->string/trunc [x real?] [e exact-integer?]) string?
|
||||
(remove-trailing-zeros (real->decimal-string x (max 0 e))))
|
||||
|
||||
;; ===================================================================================================
|
||||
;; Format strings
|
||||
|
||||
(defproc (parse-format-string [str string?]) (listof (or/c string? symbol?))
|
||||
(define n (string-length str))
|
||||
(let loop ([i 0] [fmt-list empty])
|
||||
(cond [(i . >= . n) (reverse fmt-list)]
|
||||
[(i . = . (- n 1)) (reverse (cons (substring str i (+ i 1)) fmt-list))]
|
||||
[(char=? #\~ (string-ref str i))
|
||||
(loop (+ i 2) (cons (string->symbol (substring str i (+ i 2))) fmt-list))]
|
||||
[else (loop (+ i 1) (cons (substring str i (+ i 1)) fmt-list))])))
|
||||
|
||||
(define (apply-formatter [formatter (symbol? . -> . (or/c string? #f))]
|
||||
[fmt-list (listof (or/c string? symbol?))]
|
||||
[d any/c]) (listof string?)
|
||||
(for/list ([fmt (in-list fmt-list)])
|
||||
(cond [(eq? fmt '~~) "~"]
|
||||
[(symbol? fmt) (let ([val (formatter fmt d)])
|
||||
(if val val (symbol->string fmt)))]
|
||||
[(string? fmt) fmt])))
|
||||
|
|
|
|||
|
|
@ -20,17 +20,14 @@
|
|||
(send plot-area set-alpha 1)
|
||||
(send plot-area draw-line (vector x-min y) (vector x-max y)))))
|
||||
|
||||
(define (line-legend-entries label zs colors widths styles)
|
||||
(define z-min (first zs))
|
||||
(define z-max (last zs))
|
||||
(define digits (digits-for-range z-min z-max))
|
||||
(define (line-legend-entries label zs z-labels colors widths styles)
|
||||
(define hash
|
||||
(for/fold ([hash empty]) ([z (in-list zs)]
|
||||
[color (in-cycle (maybe-apply/list colors zs))]
|
||||
[width (in-cycle (maybe-apply/list widths zs))]
|
||||
[style (in-cycle (maybe-apply/list styles zs))])
|
||||
(define entry-label (real->plot-label z digits))
|
||||
(assoc-cons hash (list color width style) entry-label)))
|
||||
(for/fold ([hash empty]) ([z (in-list zs)]
|
||||
[z-label (in-list z-labels)]
|
||||
[color (in-cycle (maybe-apply/list colors zs))]
|
||||
[width (in-cycle (maybe-apply/list widths zs))]
|
||||
[style (in-cycle (maybe-apply/list styles zs))])
|
||||
(assoc-cons hash (list color width style) z-label)))
|
||||
|
||||
(reverse
|
||||
(for/list ([entry (in-list hash)])
|
||||
|
|
@ -92,15 +89,15 @@
|
|||
(send plot-area set-pen line2-color line2-width line2-style)
|
||||
(send plot-area draw-line (vector x-min y-min) (vector x-max y-min)))))
|
||||
|
||||
(define (interval-legend-entries label zs fill-colors fill-styles line-colors line-widths line-styles
|
||||
(define (interval-legend-entries label zs labels fill-colors fill-styles
|
||||
line-colors line-widths line-styles
|
||||
line1-colors line1-widths line1-styles
|
||||
line2-colors line2-widths line2-styles)
|
||||
(define z-min (first zs))
|
||||
(define z-max (last zs))
|
||||
(define digits (digits-for-range z-min z-max))
|
||||
(define hash
|
||||
(for/fold ([hash empty]) ([za (in-list zs)]
|
||||
[zb (in-list (rest zs))]
|
||||
[la (in-list labels)]
|
||||
[lb (in-list (rest labels))]
|
||||
[fill-color (in-cycle (maybe-apply/list fill-colors zs))]
|
||||
[fill-style (in-cycle (maybe-apply/list fill-styles zs))]
|
||||
[line-color (in-cycle (maybe-apply/list line-colors zs))]
|
||||
|
|
@ -112,8 +109,7 @@
|
|||
[line2-color (in-cycle (maybe-apply/list line2-colors zs))]
|
||||
[line2-width (in-cycle (maybe-apply/list line2-widths zs))]
|
||||
[line2-style (in-cycle (maybe-apply/list line2-styles zs))])
|
||||
(define entry-label
|
||||
(format "[~a,~a]" (real->plot-label za digits) (real->plot-label zb digits)))
|
||||
(define entry-label (format "[~a,~a]" la lb))
|
||||
(assoc-cons hash
|
||||
(list fill-color fill-style line-color line-width line-style
|
||||
line1-color line1-width line1-style
|
||||
|
|
@ -132,22 +128,21 @@
|
|||
line1-color line1-width line1-style
|
||||
line2-color line2-width line2-style))))
|
||||
|
||||
(define (contour-intervals-legend-entries label z-min z-max zs
|
||||
(define (contour-intervals-legend-entries label zs labels
|
||||
fill-colors fill-styles line-colors line-widths line-styles
|
||||
contour-colors contour-widths contour-styles)
|
||||
(define interval-zs (append (list z-min) zs (list z-max)))
|
||||
|
||||
(define n (- (length zs) 2))
|
||||
(define ccs (append (list 0)
|
||||
(sequence-take (in-cycle (maybe-apply/list contour-colors zs)) 0 (length zs))
|
||||
(sequence-take (in-cycle (maybe-apply/list contour-colors zs)) 0 n)
|
||||
(list 0)))
|
||||
(define cws (append (list 0)
|
||||
(sequence-take (in-cycle (maybe-apply/list contour-widths zs)) 0 (length zs))
|
||||
(sequence-take (in-cycle (maybe-apply/list contour-widths zs)) 0 n)
|
||||
(list 0)))
|
||||
(define css (append '(transparent)
|
||||
(sequence-take (in-cycle (maybe-apply/list contour-styles zs)) 0 (length zs))
|
||||
(sequence-take (in-cycle (maybe-apply/list contour-styles zs)) 0 n)
|
||||
'(transparent)))
|
||||
|
||||
(interval-legend-entries label interval-zs
|
||||
(interval-legend-entries label zs labels
|
||||
fill-colors fill-styles line-colors line-widths line-styles
|
||||
ccs cws css (rest ccs) (rest cws) (rest css)))
|
||||
|
||||
|
|
|
|||
|
|
@ -126,11 +126,17 @@
|
|||
(if x (if y (max* x y) x)
|
||||
(if y y #f))))
|
||||
|
||||
(define (floor-log10 x)
|
||||
(inexact->exact (floor (/ (log (abs x)) (log 10)))))
|
||||
(defproc (floor-log/base [b (and/c exact-integer? (>=/c 2))] [x (>/c 0)]) real?
|
||||
(define y (inexact->exact (floor (/ (log x) (log b)))))
|
||||
(cond [(exact? x)
|
||||
(let loop ([y y] [x (/ x (expt b y))])
|
||||
(cond [(x . >= . b) (loop (add1 y) (/ x b))]
|
||||
[(x . < . 1) (loop (sub1 y) (* x b))]
|
||||
[else y]))]
|
||||
[else y]))
|
||||
|
||||
(define (ceiling-log10 x)
|
||||
(inexact->exact (ceiling (/ (log (abs x)) (log 10)))))
|
||||
(define (ceiling-log/base b x)
|
||||
(inexact->exact (ceiling (/ (log (abs x)) (log b)))))
|
||||
|
||||
(define (bin-samples bin-bounds xs)
|
||||
(let* ([bin-bounds (filter (compose not nan?) (remove-duplicates bin-bounds))]
|
||||
|
|
|
|||
|
|
@ -5,7 +5,8 @@
|
|||
(require racket/contract
|
||||
"contract.rkt" "contract-doc.rkt"
|
||||
"draw.rkt"
|
||||
"axis-transform.rkt")
|
||||
"axis-transform.rkt"
|
||||
"ticks.rkt")
|
||||
|
||||
(provide (all-defined-out))
|
||||
|
||||
|
|
@ -50,6 +51,31 @@
|
|||
(cond [(plot-animating?) (max 2 (ceiling (* 1/4 samples)))]
|
||||
[else samples]))
|
||||
|
||||
;; Sampling
|
||||
|
||||
(defparam plot-x-transform axis-transform/c id-transform)
|
||||
(defparam plot-y-transform axis-transform/c id-transform)
|
||||
(defparam plot-z-transform axis-transform/c id-transform)
|
||||
|
||||
;; Ticks
|
||||
|
||||
(defparam plot-x-max-ticks exact-positive-integer? 5)
|
||||
(defparam plot-y-max-ticks exact-positive-integer? 5)
|
||||
(defparam plot-z-max-ticks exact-positive-integer? 8)
|
||||
|
||||
(defparam plot-x-ticks ticks? (linear-ticks))
|
||||
(defparam plot-y-ticks ticks? (linear-ticks))
|
||||
(defparam plot-z-ticks ticks? (linear-ticks))
|
||||
|
||||
(defproc (default-x-ticks [x-min real?] [x-max real?]) (listof tick?)
|
||||
((plot-x-ticks) x-min x-max (plot-x-max-ticks) (plot-x-transform)))
|
||||
|
||||
(defproc (default-y-ticks [y-min real?] [y-max real?]) (listof tick?)
|
||||
((plot-y-ticks) y-min y-max (plot-y-max-ticks) (plot-y-transform)))
|
||||
|
||||
(defproc (default-z-ticks [z-min real?] [z-max real?]) (listof tick?)
|
||||
((plot-z-ticks) z-min z-max (plot-z-max-ticks) (plot-z-transform)))
|
||||
|
||||
;; Lines
|
||||
|
||||
(defparam line-samples (and/c exact-integer? (>=/c 2)) 500)
|
||||
|
|
@ -134,18 +160,13 @@
|
|||
|
||||
(defparam polar-axes-number exact-positive-integer? 12)
|
||||
(defparam polar-axes-ticks? boolean? #t)
|
||||
(defparam polar-axes-max-ticks exact-positive-integer? 8)
|
||||
|
||||
(defparam label-anchor anchor/c 'left)
|
||||
(defparam label-angle real? 0)
|
||||
(defparam label-alpha (real-in 0 1) 1)
|
||||
(defparam label-point-size (>=/c 0) 4)
|
||||
|
||||
;; Sampling
|
||||
|
||||
(defparam plot-x-transform (real? real? . -> . invertible-function?) id-transform)
|
||||
(defparam plot-y-transform (real? real? . -> . invertible-function?) id-transform)
|
||||
(defparam plot-z-transform (real? real? . -> . invertible-function?) id-transform)
|
||||
|
||||
;; ===================================================================================================
|
||||
;; 3D-specific parameters
|
||||
|
||||
|
|
|
|||
|
|
@ -3,11 +3,14 @@
|
|||
;; Functions that sample from functions, and functions that create memoized samplers.
|
||||
|
||||
(require racket/match racket/flonum racket/math racket/contract racket/list
|
||||
"contract.rkt" "contract-doc.rkt"
|
||||
"contract.rkt"
|
||||
"contract-doc.rkt"
|
||||
"math.rkt"
|
||||
"axis-transform.rkt"
|
||||
"parameters.rkt"
|
||||
"contract.rkt")
|
||||
"contract.rkt"
|
||||
"format.rkt"
|
||||
"ticks.rkt")
|
||||
|
||||
(provide (all-defined-out))
|
||||
|
||||
|
|
@ -23,10 +26,10 @@
|
|||
[_ (map f xs)]))
|
||||
|
||||
(defproc (nonlinear-seq [start real?] [end real?] [num exact-nonnegative-integer?]
|
||||
[transform (real? real? . -> . invertible-function?)]
|
||||
[transform axis-transform/c]
|
||||
[#:start? start? boolean? #t]
|
||||
[#:end? end? boolean? #t]) (listof real?)
|
||||
(match-define (invertible-function _ finv) (transform start end))
|
||||
(match-define (invertible-function _ finv) (apply-transform transform start end))
|
||||
(map finv (linear-seq start end num #:start? start? #:end? end?)))
|
||||
|
||||
(define ((2d-polar->3d-function f) x y z)
|
||||
|
|
@ -103,3 +106,50 @@
|
|||
[ds (in-vector dss)]
|
||||
[d (in-vector ds)])
|
||||
d))
|
||||
|
||||
;; ===================================================================================================
|
||||
;; Common memoized samplers
|
||||
|
||||
(define function->sampler (make-function->sampler plot-x-transform))
|
||||
(define inverse->sampler (make-function->sampler plot-y-transform))
|
||||
(define 2d-function->sampler (make-2d-function->sampler plot-x-transform plot-y-transform))
|
||||
(define 3d-function->sampler
|
||||
(make-3d-function->sampler plot-x-transform plot-y-transform plot-z-transform))
|
||||
|
||||
;; ===================================================================================================
|
||||
;; Contour ticks
|
||||
|
||||
(defproc (contour-ticks [z-min real?] [z-max real?]
|
||||
[levels (or/c 'auto exact-positive-integer? (listof real?))]
|
||||
[intervals? boolean?]) (listof tick?)
|
||||
(define epsilon (expt 10 (- (digits-for-range z-min z-max))))
|
||||
(match-define (ticks layout format) (plot-z-ticks))
|
||||
(define ts
|
||||
(cond [(eq? levels 'auto) (filter pre-tick-major?
|
||||
(layout z-min z-max (plot-z-max-ticks) (plot-z-transform)))]
|
||||
[else (define zs (cond [(list? levels) (filter (λ (z) (<= z-min z z-max)) levels)]
|
||||
[else (linear-seq z-min z-max levels #:start? #f #:end? #f)]))
|
||||
(map (λ (z) (pre-tick z #t)) zs)]))
|
||||
(define all-ts
|
||||
(cond [intervals?
|
||||
(let* ([ts (cond [((abs (- z-min (pre-tick-value (first ts)))) . < . epsilon) ts]
|
||||
[else (cons (pre-tick z-min #t) ts)])]
|
||||
[ts (cond [((abs (- z-max (pre-tick-value (last ts)))) . < . epsilon) ts]
|
||||
[else (append ts (list (pre-tick z-max #t)))])])
|
||||
ts)]
|
||||
[else
|
||||
(let* ([ts (cond [((abs (- z-min (pre-tick-value (first ts)))) . >= . epsilon) ts]
|
||||
[else (rest ts)])]
|
||||
[ts (cond [((abs (- z-max (pre-tick-value (last ts)))) . >= . epsilon) ts]
|
||||
[else (take ts (- (length ts) 1))])])
|
||||
ts)]))
|
||||
(match-define (list (pre-tick zs majors) ...) all-ts)
|
||||
(define labels (format z-min z-max all-ts))
|
||||
(map tick zs majors labels))
|
||||
|
||||
(defproc (auto-contour-values [z-min real?] [z-max real?]) (listof real?)
|
||||
(define ts (default-z-ticks z-min z-max))
|
||||
(let* ([zs (map pre-tick-value (filter pre-tick-major? ts))]
|
||||
[zs (if (= (first zs) z-min) (rest zs) zs)]
|
||||
[zs (if (= (last zs) z-max) (take zs (sub1 (length zs))) zs)])
|
||||
zs))
|
||||
|
|
|
|||
|
|
@ -2,50 +2,620 @@
|
|||
|
||||
;; Data structure that represents a tick, and functions that produce ticks.
|
||||
|
||||
(require racket/string racket/list racket/contract racket/pretty
|
||||
(require racket/string racket/list racket/contract racket/pretty racket/match
|
||||
"math.rkt"
|
||||
"format.rkt"
|
||||
"utils.rkt"
|
||||
"contract.rkt" "contract-doc.rkt"
|
||||
"parameters.rkt")
|
||||
"contract.rkt"
|
||||
"contract-doc.rkt"
|
||||
"date-time.rkt"
|
||||
"axis-transform.rkt"
|
||||
"currency.rkt")
|
||||
|
||||
(provide (all-defined-out))
|
||||
(provide (struct-out pre-tick) (struct-out tick) (struct-out ticks)
|
||||
;; No ticks
|
||||
no-ticks-layout no-ticks-format no-ticks
|
||||
;; Linear ticks
|
||||
linear-ticks-base linear-ticks-divisors
|
||||
linear-ticks-layout linear-ticks-format linear-ticks
|
||||
;; Uniform ticks
|
||||
uniform-ticks-layout uniform-ticks
|
||||
;; Log-scale ticks
|
||||
log-ticks-base
|
||||
log-ticks-layout log-ticks-format log-ticks
|
||||
;; Date ticks
|
||||
date-ticks-formats 24h-descending-date-ticks-formats 12h-descending-date-ticks-formats
|
||||
date-ticks-layout date-ticks-format date-ticks
|
||||
;; Time ticks
|
||||
time-ticks-formats descending-time-ticks-formats
|
||||
time-ticks-layout time-ticks-format time-ticks
|
||||
;; Bit/byte ticks
|
||||
bit/byte-ticks-format bit/byte-ticks
|
||||
;; Currency ticks and formats
|
||||
currency-scale-suffixes
|
||||
us-currency-scale-suffixes uk-currency-scale-suffixes eu-currency-scale-suffixes
|
||||
currency-format-strings
|
||||
us-currency-format-strings uk-currency-format-strings eu-currency-format-strings
|
||||
currency-ticks-format currency-ticks
|
||||
;; Fractions
|
||||
fraction-ticks-format fraction-ticks
|
||||
)
|
||||
|
||||
(define-struct/contract tick
|
||||
([p real?] [label string?] [major? boolean?])
|
||||
#:transparent)
|
||||
(define-struct/contract pre-tick ([value real?] [major? boolean?]) #:transparent)
|
||||
(define-struct/contract (tick pre-tick) ([label string?]) #:transparent)
|
||||
|
||||
(define (tick-ps->majors ps major-skip)
|
||||
(define zero-idx (list-index 0 ps =))
|
||||
(define zero-idx-rem (if (zero-idx . < . 0) 0 (remainder zero-idx major-skip)))
|
||||
(for/list ([n (in-range (length ps))])
|
||||
(= (remainder n major-skip) zero-idx-rem)))
|
||||
(defcontract ticks-layout/c
|
||||
(real? real? exact-positive-integer? axis-transform/c . -> . (listof pre-tick?)))
|
||||
|
||||
(define (linear-ticks major-skip x-min x-max)
|
||||
(when (x-min . >= . x-max)
|
||||
(error 'default-range->ticks "expected x-min < x-max; got x-min = ~e and x-max = ~e" x-min x-max))
|
||||
(let ([x-min (inexact->exact x-min)]
|
||||
[x-max (inexact->exact x-max)])
|
||||
(define e (floor-log10 (- x-max x-min)))
|
||||
(define mag (expt 10 e))
|
||||
(define step (let ([y (/ (- x-max x-min) mag)])
|
||||
(cond [(y . < . 2) (* 1/5 mag)]
|
||||
[(y . < . 5) (* 1/2 mag)]
|
||||
[else mag])))
|
||||
(define start (* (ceiling (/ x-min step)) step))
|
||||
(define stop (* (floor (/ x-max step)) step))
|
||||
(define num (+ 1 (round (/ (- stop start) step))))
|
||||
(define ps (linear-seq start stop num))
|
||||
(define digits (digits-for-range x-min x-max))
|
||||
(define labels (map (λ (p) (real->plot-label p digits)) ps))
|
||||
(define majors (tick-ps->majors ps major-skip))
|
||||
(map tick ps labels majors)))
|
||||
(defcontract ticks-format/c
|
||||
(real? real? (listof pre-tick?) . -> . (listof string?)))
|
||||
|
||||
(defproc (default-ticks-fun [x-min real?] [x-max real?]) (listof tick?)
|
||||
(linear-ticks 2 x-min x-max))
|
||||
(define-struct/contract ticks ([layout ticks-layout/c] [format ticks-format/c]) #:transparent
|
||||
#:property prop:procedure
|
||||
(λ (t x-min x-max max-ticks transform)
|
||||
(match-define (ticks layout format) t)
|
||||
(define ts (layout x-min x-max max-ticks transform))
|
||||
(match-define (list (pre-tick xs majors) ...) ts)
|
||||
(map tick xs majors (format x-min x-max ts))))
|
||||
|
||||
(defproc (auto-contour-zs [z-min real?] [z-max real?]) (listof real?)
|
||||
(let* ([zs (map tick-p (default-ticks-fun z-min z-max))]
|
||||
[zs (if (= (first zs) z-min) (rest zs) zs)]
|
||||
[zs (if (= (last zs) z-max) (take zs (sub1 (length zs))) zs)])
|
||||
zs))
|
||||
;; ===================================================================================================
|
||||
;; Helpers
|
||||
|
||||
(define-syntax-rule (with-exact-bounds x-min x-max body ...)
|
||||
(cond [(x-min . >= . x-max)
|
||||
(error 'bounds-check "expected min < max; given min = ~e and max = ~e" x-min x-max)]
|
||||
[else (let ([x-min (inexact->exact x-min)]
|
||||
[x-max (inexact->exact x-max)])
|
||||
body ...)]))
|
||||
|
||||
(define (linear-seq-args x-min x-max step)
|
||||
(define start (* (ceiling (/ x-min step)) step))
|
||||
(define end (* (floor (/ x-max step)) step))
|
||||
(define num (+ 1 (inexact->exact (round (/ (- end start) step)))))
|
||||
(values start end num))
|
||||
|
||||
(define (linear-major-values/step x-min x-max step)
|
||||
(define-values (start end num) (linear-seq-args x-min x-max step))
|
||||
(linear-seq start end num))
|
||||
|
||||
(defproc (linear-minor-values/step [major-xs (listof real?)] [major-step real?]
|
||||
[minor-ticks exact-nonnegative-integer?]) (listof real?)
|
||||
(cond [(or (zero? minor-ticks) (empty? major-xs)) empty]
|
||||
[else
|
||||
(define major-start (first major-xs))
|
||||
(define minor-step (/ major-step (+ minor-ticks 1)))
|
||||
(for*/list ([x (in-list (cons (- major-start major-step) major-xs))]
|
||||
[i (in-range 1 (+ minor-ticks 1))])
|
||||
(+ x (* i minor-step)))]))
|
||||
|
||||
(defproc (tick-values->pre-ticks [major-xs (listof real?)] [minor-xs (listof real?)]
|
||||
) (listof pre-tick?)
|
||||
(define major-ts (map (λ (x) (pre-tick x #t)) major-xs))
|
||||
(define minor-ts (map (λ (x) (pre-tick x #f)) minor-xs))
|
||||
(sort (append major-ts minor-ts) < #:key pre-tick-value))
|
||||
|
||||
;; ===================================================================================================
|
||||
;; No ticks
|
||||
|
||||
(defthing no-ticks-layout ticks-layout/c
|
||||
(λ (x-min x-max max-ticks transform)
|
||||
empty))
|
||||
|
||||
(defthing no-ticks-format ticks-format/c
|
||||
(λ (x-min x-max ts)
|
||||
empty))
|
||||
|
||||
(defthing no-ticks ticks?
|
||||
(ticks no-ticks-layout no-ticks-format))
|
||||
|
||||
;; ===================================================================================================
|
||||
;; Linear ticks (default tick function, evenly spaced)
|
||||
|
||||
(defparam linear-ticks-base (and/c exact-integer? (>=/c 2)) 10)
|
||||
(defparam linear-ticks-divisors (listof exact-positive-integer?) '(1 2 5))
|
||||
|
||||
(defproc (linear-tick-step+divisor [x-min real?] [x-max real?]
|
||||
[max-ticks exact-positive-integer?]
|
||||
[base (and/c exact-integer? (>=/c 2))]
|
||||
[divisors (listof exact-positive-integer?)]
|
||||
) (values real? exact-positive-integer?)
|
||||
(define range (- x-max x-min))
|
||||
(define mag (expt base (floor-log/base base range)))
|
||||
(define ds (sort divisors >))
|
||||
(let/ec break
|
||||
(for* ([e (in-range (floor-log/base base max-ticks) -2 -1)]
|
||||
[d (in-list ds)])
|
||||
;(printf "new-d = ~v~n" (* d (expt base e)))
|
||||
(define step (/ mag d (expt base e)))
|
||||
(define-values (_start _end num) (linear-seq-args x-min x-max step))
|
||||
(when (num . <= . max-ticks)
|
||||
(break step d)))
|
||||
;(printf "default!~n")
|
||||
(values (/ range max-ticks) max-ticks)))
|
||||
|
||||
(defproc (linear-tick-values [x-min real?] [x-max real?]
|
||||
[max-ticks exact-positive-integer?]
|
||||
[base (and/c exact-integer? (>=/c 2))]
|
||||
[divisors (listof exact-positive-integer?)]
|
||||
) (values (listof real?) (listof real?))
|
||||
(with-exact-bounds
|
||||
x-min x-max
|
||||
(define-values (step d) (linear-tick-step+divisor x-min x-max max-ticks base divisors))
|
||||
(define major-xs (linear-major-values/step x-min x-max step))
|
||||
(define major-ticks (length major-xs))
|
||||
|
||||
(define ns (filter (λ (n) (zero? (remainder (* n d) base))) divisors))
|
||||
(define n
|
||||
(cond [(empty? ns) 1]
|
||||
[else (argmin (λ (n) (abs (- (* n major-ticks) max-ticks))) (sort ns <))]))
|
||||
(define minor-xs (linear-minor-values/step major-xs step (- n 1)))
|
||||
(values major-xs (filter (λ (x) (<= x-min x x-max)) minor-xs))))
|
||||
|
||||
(defproc (linear-ticks-layout [#:base base (and/c exact-integer? (>=/c 2)) (linear-ticks-base)]
|
||||
[#:divisors divisors (listof exact-positive-integer?)
|
||||
(linear-ticks-divisors)]
|
||||
) ticks-layout/c
|
||||
(λ (x-min x-max max-ticks transform)
|
||||
(define-values (major-xs minor-xs) (linear-tick-values x-min x-max max-ticks base divisors))
|
||||
(tick-values->pre-ticks major-xs minor-xs)))
|
||||
|
||||
(defproc (linear-ticks-format) ticks-format/c
|
||||
(λ (x-min x-max ts)
|
||||
(with-exact-bounds
|
||||
x-min x-max
|
||||
(define digits (digits-for-range x-min x-max))
|
||||
(for/list ([t (in-list ts)])
|
||||
(real->plot-label (pre-tick-value t) digits)))))
|
||||
|
||||
(defproc (linear-ticks [#:base base (and/c exact-integer? (>=/c 2)) (linear-ticks-base)]
|
||||
[#:divisors divisors (listof exact-positive-integer?) (linear-ticks-divisors)]
|
||||
) ticks?
|
||||
(ticks (linear-ticks-layout #:base base #:divisors divisors)
|
||||
(linear-ticks-format)))
|
||||
|
||||
;; ===================================================================================================
|
||||
;; Uniform spacing ticks
|
||||
|
||||
(defproc (uniform-ticks-layout [#:layout layout ticks-layout/c (linear-ticks-layout)]) ticks-layout/c
|
||||
(λ (x-min x-max max-ticks transform)
|
||||
(define ts (layout x-min x-max max-ticks transform))
|
||||
(define xs (map pre-tick-value ts))
|
||||
(define majors (map pre-tick-major? ts))
|
||||
(define new-xs (map (invertible-function-finv (apply-transform transform x-min x-max)) xs))
|
||||
(map pre-tick new-xs majors)))
|
||||
|
||||
(defproc (uniform-ticks [#:layout layout ticks-layout/c (linear-ticks-layout)]) ticks?
|
||||
(ticks (uniform-ticks-layout #:layout layout)
|
||||
(linear-ticks-format)))
|
||||
|
||||
;; ===================================================================================================
|
||||
;; Exponential ticks (use for log scale)
|
||||
|
||||
(defparam log-ticks-base (and/c exact-integer? (>=/c 2)) 10)
|
||||
|
||||
(defproc (log-ticks-layout [#:base base (and/c exact-integer? (>=/c 2)) (log-ticks-base)]
|
||||
) ticks-layout/c
|
||||
(λ (x-min x-max max-ticks transform)
|
||||
(with-exact-bounds
|
||||
x-min x-max
|
||||
(when ((exact->inexact x-min) . <= . 0)
|
||||
(raise-type-error 'log-ticks-layout "positive real" 0 x-min x-max))
|
||||
(define log-start (floor-log/base base x-min))
|
||||
(define log-end (ceiling-log/base base x-max))
|
||||
(define log-xs (for/list ([i (in-range log-start (add1 log-end))]) i))
|
||||
(define skip (max 1 (floor (/ (+ (length log-xs) 2) 5))))
|
||||
(filter (λ (t) (<= x-min (pre-tick-value t) x-max))
|
||||
(append*
|
||||
(for/list ([log-x (in-list log-xs)]
|
||||
[m (in-cycle (in-range skip))])
|
||||
(define x (expt base log-x))
|
||||
(cond [(= skip 1) (for/list ([i (in-range 0 (sub1 base) skip)])
|
||||
(pre-tick (+ x (* i x))
|
||||
(and (zero? i) (zero? m))))]
|
||||
[else (list (cond [(zero? m) (pre-tick x #t)]
|
||||
[else (pre-tick x #f)]))])))))))
|
||||
|
||||
(defproc (log-ticks-format [#:base base (and/c exact-integer? (>=/c 2)) (log-ticks-base)]
|
||||
) ticks-format/c
|
||||
(define base-str (number->string base))
|
||||
(λ (x-min x-max ts)
|
||||
(with-exact-bounds
|
||||
x-min x-max
|
||||
(define epsilon (expt 10 (- (digits-for-range x-min x-max))))
|
||||
(define base-digits (digits-for-range 0 base))
|
||||
(for/list ([t (in-list ts)])
|
||||
(define x (pre-tick-value t))
|
||||
(define log-x (floor-log/base base x))
|
||||
(define round? ((abs (- x (expt base log-x))) . < . epsilon))
|
||||
(define major-str (format "~a~a" base-str (integer->superscript log-x)))
|
||||
(cond [round? major-str]
|
||||
[else (format "~a×~a"
|
||||
(real->plot-label (/ x (expt base log-x)) base-digits)
|
||||
major-str)])))))
|
||||
|
||||
(defproc (log-ticks [#:base base (and/c exact-integer? (>=/c 2)) (log-ticks-base)]) ticks?
|
||||
(ticks (log-ticks-layout #:base base)
|
||||
(log-ticks-format #:base base)))
|
||||
|
||||
;; ===================================================================================================
|
||||
;; Date/time helpers
|
||||
|
||||
(defproc (find-linear-tick-step [x-min real?] [x-max real?] [max-ticks exact-positive-integer?]
|
||||
[steps (listof real?)]) real?
|
||||
(with-exact-bounds
|
||||
x-min x-max
|
||||
(let/ec break
|
||||
(for ([step (in-list (sort steps <))])
|
||||
(define-values (_start _end num) (linear-seq-args x-min x-max step))
|
||||
(when (num . <= . max-ticks)
|
||||
(break step)))
|
||||
#f)))
|
||||
|
||||
(define (count-unchanging-fields formatter fmt-list xs)
|
||||
(let ([fmt-list (filter symbol? fmt-list)])
|
||||
(define formatted-dates (for/list ([x (in-list xs)])
|
||||
(apply-formatter formatter fmt-list x)))
|
||||
(count equal?* (transpose formatted-dates))))
|
||||
|
||||
(define (choose-format-list formatter fmt-lists xs)
|
||||
(let ([fmt-lists (sort fmt-lists >
|
||||
#:key (λ (fmt-list) (count symbol? fmt-list))
|
||||
#:cache-keys? #t)])
|
||||
(argmin (λ (fmt-list) (count-unchanging-fields formatter fmt-list xs))
|
||||
fmt-lists)))
|
||||
|
||||
;; ===================================================================================================
|
||||
;; Date ticks
|
||||
|
||||
(define 12h-descending-date-ticks-formats
|
||||
'("~Y-~m-~d ~I:~M:~f~p"
|
||||
"~Y-~m-~d ~I:~M~p"
|
||||
"~Y-~m-~d ~I~p"
|
||||
"~Y-~m-~d"
|
||||
"~Y-~m"
|
||||
"~Y"
|
||||
|
||||
"~m-~d ~I:~M:~f~p"
|
||||
"~m-~d ~I:~M~p"
|
||||
"~m-~d ~I~p"
|
||||
"~m-~d"
|
||||
|
||||
"~I:~M:~f~p"
|
||||
"~I:~M~p"
|
||||
|
||||
"~M:~fs"
|
||||
|
||||
"~fs"))
|
||||
|
||||
(define 24h-descending-date-ticks-formats
|
||||
'("~Y-~m-~d ~H:~M:~f"
|
||||
"~Y-~m-~d ~H:~M"
|
||||
"~Y-~m-~d ~Hh"
|
||||
"~Y-~m-~d"
|
||||
"~Y-~m"
|
||||
"~Y"
|
||||
|
||||
"~m-~d ~H:~M:~f"
|
||||
"~m-~d ~H:~M"
|
||||
"~m-~d ~Hh"
|
||||
"~m-~d"
|
||||
|
||||
"~H:~M:~f"
|
||||
"~H:~M"
|
||||
|
||||
"~M:~fs"
|
||||
|
||||
"~fs"))
|
||||
|
||||
(defparam date-ticks-formats (listof string?) 24h-descending-date-ticks-formats)
|
||||
|
||||
;; Tick steps to try, in seconds
|
||||
(define date-steps
|
||||
(list 1 2 5 10 15 20 30 40 45
|
||||
seconds-per-minute
|
||||
(* 2 seconds-per-minute)
|
||||
(* 5 seconds-per-minute)
|
||||
(* 10 seconds-per-minute)
|
||||
(* 15 seconds-per-minute)
|
||||
(* 20 seconds-per-minute)
|
||||
(* 30 seconds-per-minute)
|
||||
seconds-per-hour
|
||||
(* 2 seconds-per-hour)
|
||||
(* 3 seconds-per-hour)
|
||||
(* 4 seconds-per-hour)
|
||||
(* 6 seconds-per-hour)
|
||||
(* 8 seconds-per-hour)
|
||||
(* 12 seconds-per-hour)
|
||||
seconds-per-day
|
||||
(* 2 seconds-per-day)
|
||||
(* 5 seconds-per-day)
|
||||
(* 10 seconds-per-day)
|
||||
seconds-per-week
|
||||
(* 2 seconds-per-week)
|
||||
avg-seconds-per-month
|
||||
(* 2 avg-seconds-per-month)
|
||||
(* 3 avg-seconds-per-month)
|
||||
(* 4 avg-seconds-per-month)
|
||||
(* 6 avg-seconds-per-month)
|
||||
(* 8 avg-seconds-per-month)
|
||||
(* 9 avg-seconds-per-month)
|
||||
avg-seconds-per-year
|
||||
(* 2 avg-seconds-per-year)
|
||||
(* 5 avg-seconds-per-year)))
|
||||
|
||||
(define (date-tick-values x-min x-max max-ticks)
|
||||
(with-exact-bounds
|
||||
x-min x-max
|
||||
(define range (- x-max x-min))
|
||||
(define step
|
||||
(cond [(range . < . (* max-ticks (first date-steps)))
|
||||
(define-values (step _)
|
||||
(linear-tick-step+divisor x-min x-max max-ticks 10 '(1 2 5)))
|
||||
step]
|
||||
[(range . > . (* max-ticks (last date-steps)))
|
||||
(define-values (step _)
|
||||
(linear-tick-step+divisor (/ x-min avg-seconds-per-year)
|
||||
(/ x-max avg-seconds-per-year)
|
||||
max-ticks 10 '(1 2 5)))
|
||||
(* step avg-seconds-per-year)]
|
||||
[else (find-linear-tick-step x-min x-max max-ticks date-steps)]))
|
||||
(define date-round
|
||||
(cond [(step . >= . avg-seconds-per-year) utc-seconds-round-year]
|
||||
[(step . >= . avg-seconds-per-month) utc-seconds-round-month]
|
||||
[else (λ (d) d)]))
|
||||
(define major-xs (linear-major-values/step x-min x-max step))
|
||||
(values (map date-round major-xs) empty)))
|
||||
|
||||
(defproc (date-ticks-layout) ticks-layout/c
|
||||
(λ (x-min x-max max-ticks transform)
|
||||
(define-values (major-xs minor-xs) (date-tick-values x-min x-max max-ticks))
|
||||
(tick-values->pre-ticks major-xs minor-xs)))
|
||||
|
||||
(defproc (date-ticks-format [#:formats formats (listof string?) (date-ticks-formats)]) ticks-format/c
|
||||
(define fmt-lists (map parse-format-string formats))
|
||||
(λ (x-min x-max ts)
|
||||
(with-exact-bounds
|
||||
x-min x-max
|
||||
(define formatter (plot-date-formatter x-min x-max))
|
||||
(define xs (map pre-tick-value ts))
|
||||
(define fmt-list (choose-format-list formatter fmt-lists xs))
|
||||
(for/list ([x (in-list xs)])
|
||||
(string-append* (apply-formatter formatter fmt-list x))))))
|
||||
|
||||
(defproc (date-ticks [#:formats formats (listof string?) (date-ticks-formats)]) ticks?
|
||||
(ticks (date-ticks-layout)
|
||||
(date-ticks-format #:formats formats)))
|
||||
|
||||
;; ===================================================================================================
|
||||
;; Time ticks
|
||||
|
||||
(define descending-time-ticks-formats
|
||||
'("~dd ~H:~M:~f"
|
||||
"~dd ~H:~M"
|
||||
"~dd ~Hh"
|
||||
"~dd"
|
||||
|
||||
"~H:~M:~f"
|
||||
"~H:~M"
|
||||
"~Hh"
|
||||
|
||||
"~M:~f"
|
||||
"~Mm"
|
||||
|
||||
"~ss"))
|
||||
|
||||
(defparam time-ticks-formats (listof string?) descending-time-ticks-formats)
|
||||
|
||||
;; Tick steps to try, in seconds
|
||||
(define time-steps
|
||||
(list 1 2 5 10 15 20 30 40 45
|
||||
seconds-per-minute
|
||||
(* 2 seconds-per-minute)
|
||||
(* 5 seconds-per-minute)
|
||||
(* 10 seconds-per-minute)
|
||||
(* 15 seconds-per-minute)
|
||||
(* 20 seconds-per-minute)
|
||||
(* 30 seconds-per-minute)
|
||||
(* 45 seconds-per-minute)
|
||||
seconds-per-hour
|
||||
(* 2 seconds-per-hour)
|
||||
(* 3 seconds-per-hour)
|
||||
(* 4 seconds-per-hour)
|
||||
(* 6 seconds-per-hour)
|
||||
(* 8 seconds-per-hour)
|
||||
(* 12 seconds-per-hour)
|
||||
(* 18 seconds-per-hour)
|
||||
seconds-per-day
|
||||
(* 2 seconds-per-day)
|
||||
(* 5 seconds-per-day)
|
||||
(* 10 seconds-per-day)
|
||||
(* 15 seconds-per-day)
|
||||
(* 30 seconds-per-day)
|
||||
(* 60 seconds-per-day)
|
||||
(* 90 seconds-per-day)))
|
||||
|
||||
(define (time-tick-values x-min x-max max-ticks)
|
||||
(with-exact-bounds
|
||||
x-min x-max
|
||||
(define range (- x-max x-min))
|
||||
(define step
|
||||
(cond [(range . < . (* max-ticks (first time-steps)))
|
||||
(define-values (step _)
|
||||
(linear-tick-step+divisor x-min x-max max-ticks 10 '(1 2 5)))
|
||||
step]
|
||||
[(range . > . (* max-ticks (last time-steps)))
|
||||
(define-values (step _)
|
||||
(linear-tick-step+divisor (/ x-min seconds-per-day)
|
||||
(/ x-max seconds-per-day)
|
||||
max-ticks 10 '(1 2 5)))
|
||||
(* step seconds-per-day)]
|
||||
[else
|
||||
(find-linear-tick-step x-min x-max max-ticks time-steps)]))
|
||||
(define major-xs (linear-major-values/step x-min x-max step))
|
||||
(values major-xs empty)))
|
||||
|
||||
(defproc (time-ticks-layout) ticks-layout/c
|
||||
(λ (x-min x-max max-ticks transform)
|
||||
(define-values (major-xs minor-xs) (time-tick-values x-min x-max max-ticks))
|
||||
(tick-values->pre-ticks major-xs minor-xs)))
|
||||
|
||||
(defproc (time-ticks-format [#:formats formats (listof string?) (time-ticks-formats)]) ticks-format/c
|
||||
(define fmt-lists (map parse-format-string formats))
|
||||
(λ (x-min x-max ts)
|
||||
(with-exact-bounds
|
||||
x-min x-max
|
||||
(define formatter (plot-time-formatter x-min x-max))
|
||||
(define xs (map pre-tick-value ts))
|
||||
(define fmt-list (choose-format-list formatter fmt-lists xs))
|
||||
(for/list ([x (in-list xs)])
|
||||
(string-append* (apply-formatter formatter fmt-list x))))))
|
||||
|
||||
(defproc (time-ticks [#:formats formats (listof string?) (time-ticks-formats)]) ticks?
|
||||
(ticks (time-ticks-layout)
|
||||
(time-ticks-format #:formats formats)))
|
||||
|
||||
;; ===================================================================================================
|
||||
;; Byte and bit ticks
|
||||
|
||||
;; "", Kilo, Mega, Giga, Tera, Peta, Exa, Zeta, Yotta
|
||||
(define byte-suffixes #("B" "KB" "MB" "GB" "TB" "PB" "EB" "ZB" "YB"))
|
||||
(define bit-suffixes #("b" "Kb" "Mb" "Gb" "Tb" "Pb" "Eb" "Zb" "Yb"))
|
||||
|
||||
(defproc (bit/byte-ticks-format [#:size size (or/c 'byte 'bit) 'byte]
|
||||
[#:kind kind (or/c 'CS 'SI) 'CS]) ticks-format/c
|
||||
(λ (x-min x-max ts)
|
||||
(with-exact-bounds
|
||||
x-min x-max
|
||||
(define suffixes (if (eq? size 'bit) bit-suffixes byte-suffixes))
|
||||
(define-values (base pow) (case kind
|
||||
[(SI) (values 10 3)]
|
||||
[else (values 2 10)]))
|
||||
(define x-largest (max* (abs x-min) (abs x-max)))
|
||||
(define b (floor-log/base (expt base pow) x-largest))
|
||||
(define format-str
|
||||
(cond [(and (b . >= . 0) (b . < . (vector-length suffixes)))
|
||||
(format "~a ~a" "~a" (vector-ref suffixes b))]
|
||||
[else
|
||||
(format "~a×~a~a ~a" "~a"
|
||||
base (integer->superscript (* b pow)) (vector-ref suffixes 0))]))
|
||||
(define unit (expt base (* b pow)))
|
||||
(define digits (digits-for-range (/ x-min unit) (/ x-max unit)))
|
||||
(for/list ([t (in-list ts)])
|
||||
(define unit-x (/ (pre-tick-value t) unit))
|
||||
(format format-str (real->plot-label unit-x digits #f))))))
|
||||
|
||||
(defproc (bit/byte-ticks [#:size size (or/c 'byte 'bit) 'byte]
|
||||
[#:kind kind (or/c 'CS 'SI) 'CS]) ticks?
|
||||
(define layout
|
||||
(case kind
|
||||
[(SI) (linear-ticks-layout #:base 10 #:divisors '(1 2 5))]
|
||||
[else (linear-ticks-layout #:base 2 #:divisors '(1 2))]))
|
||||
(ticks layout (bit/byte-ticks-format #:size size #:kind kind)))
|
||||
|
||||
;; ===================================================================================================
|
||||
;; Currency
|
||||
|
||||
;; US "short scale" suffixes
|
||||
(define us-currency-scale-suffixes '("" "K" "M" "B" "T"))
|
||||
;; The UK officially uses the short scale now
|
||||
;; Million is abbreviated "m" instead of "mn" because "mn" stands for minutes; also, the Daily
|
||||
;; Telegraph Style Guide totally says to use "m"
|
||||
(define uk-currency-scale-suffixes '("" "k" "m" "bn" "tr"))
|
||||
;; European countries use the long scale: million, milliard, billion
|
||||
(define eu-currency-scale-suffixes '("" "K" "M" "Md" "B"))
|
||||
;; The larger the scale suffixes get, the less standardized they are; so we stop at trillion (short)
|
||||
|
||||
;; US negative amounts are in parenthesis:
|
||||
(define us-currency-format-strings '("~$~w.~f~s" "(~$~w.~f~s)" "~$0"))
|
||||
;; The UK is more reasonable, using a negative sign for negative amounts:
|
||||
(define uk-currency-format-strings '("~$~w.~f ~s" "-~$~w.~f ~s" "~$0"))
|
||||
;; The more common EU format (e.g. France, Germany, Italy, Spain):
|
||||
(define eu-currency-format-strings '("~w,~f ~s~$" "-~w,~f ~s~$" "0 ~$"))
|
||||
|
||||
(defparam currency-scale-suffixes (listof string?) us-currency-scale-suffixes)
|
||||
(defparam currency-format-strings (list/c string? string? string?) us-currency-format-strings)
|
||||
|
||||
(struct amount-data (sign whole fractional unit suffix) #:transparent)
|
||||
|
||||
(define (currency-formatter x-min x-max)
|
||||
(λ (fmt data)
|
||||
(case fmt
|
||||
[(~$) (amount-data-sign data)]
|
||||
[(~w) (number->string (amount-data-whole data))]
|
||||
[(~f) (match-define (amount-data _sign _whole f unit _suffix) data)
|
||||
(define digits (digits-for-range (/ x-min unit) (/ x-max unit)))
|
||||
(cond [(= 1 unit) (substring (real->decimal-string* f 2 (max 2 digits)) 2)]
|
||||
[(zero? f) "0"]
|
||||
[else (substring (real->decimal-string* f 1 (max 1 digits)) 2)])]
|
||||
[(~s) (amount-data-suffix data)]
|
||||
[else #f])))
|
||||
|
||||
(defproc (currency-ticks-format [#:kind kind (or/c string? symbol?) 'USD]) ticks-format/c
|
||||
(λ (x-min x-max ts)
|
||||
(with-exact-bounds
|
||||
x-min x-max
|
||||
(define formatter (currency-formatter x-min x-max))
|
||||
(match-define (list positive-format-string negative-format-string zero-format-string)
|
||||
(currency-format-strings))
|
||||
(define positive-format-list (parse-format-string positive-format-string))
|
||||
(define negative-format-list (parse-format-string negative-format-string))
|
||||
(define zero-format-list (parse-format-string zero-format-string))
|
||||
(define suffixes (list->vector (currency-scale-suffixes)))
|
||||
(define n (vector-length suffixes))
|
||||
(define sign (cond [(string? kind) kind]
|
||||
[else (hash-ref currency-code->sign kind (λ () (symbol->string kind)))]))
|
||||
(define x-largest (max* (abs x-min) (abs x-max)))
|
||||
(define b (let ([b (floor-log/base 1000 x-largest)])
|
||||
(if (b . < . 0) (+ b 1) b)))
|
||||
(define suffix
|
||||
(cond [(and (b . >= . 0) (b . < . n)) (vector-ref suffixes b)]
|
||||
[else (format "×10~a" (integer->superscript (* b 3)))]))
|
||||
(define unit
|
||||
(cond [(= 0 (string-length suffix)) 1]
|
||||
[else (expt 1000 b)]))
|
||||
(for/list ([t (in-list ts)])
|
||||
(define x (pre-tick-value t))
|
||||
(define format-list (cond [(positive? x) positive-format-list]
|
||||
[(negative? x) negative-format-list]
|
||||
[else zero-format-list]))
|
||||
(define unit-x (/ (abs x) unit))
|
||||
(string-append*
|
||||
(apply-formatter formatter format-list
|
||||
(amount-data sign (floor unit-x) (- unit-x (floor unit-x)) unit suffix)))))))
|
||||
|
||||
(defproc (currency-ticks-layout) ticks-layout/c
|
||||
(linear-ticks-layout #:base 10 #:divisors '(1 2 4 5)))
|
||||
|
||||
(defproc (currency-ticks [#:kind kind (or/c string? symbol?) 'USD]) ticks?
|
||||
(ticks (currency-ticks-layout)
|
||||
(currency-ticks-format #:kind kind)))
|
||||
|
||||
;; ===================================================================================================
|
||||
;; Fractions
|
||||
|
||||
(defparam fraction-ticks-base (and/c exact-integer? (>=/c 2)) 10)
|
||||
(defparam fraction-ticks-divisors (listof exact-positive-integer?) '(1 2 3 4 5))
|
||||
|
||||
(define (format-fraction x)
|
||||
(cond [(inexact? x) (format-fraction (inexact->exact x))]
|
||||
[(x . < . 0) (format "-~a" (format-fraction (- x)))]
|
||||
[(x . = . 0) "0"]
|
||||
[(x . < . 1) (format "~a/~a" (numerator x) (denominator x))]
|
||||
[else
|
||||
(define d (denominator x))
|
||||
(cond [(d . = . 1) (format "~a" (numerator x))]
|
||||
[else
|
||||
(define w (floor x))
|
||||
(let ([x (- x w)])
|
||||
(format "~a ~a/~a" w (numerator x) (denominator x)))])]))
|
||||
|
||||
(defproc (fraction-ticks-format) ticks-format/c
|
||||
(λ (x-min x-max ts)
|
||||
(for/list ([t (in-list ts)])
|
||||
(format-fraction (pre-tick-value t)))))
|
||||
|
||||
(defproc (fraction-ticks [#:base base (and/c exact-integer? (>=/c 2)) (fraction-ticks-base)]
|
||||
[#:divisors divisors (listof exact-positive-integer?)
|
||||
(fraction-ticks-divisors)]) ticks?
|
||||
(ticks (linear-ticks #:base base #:divisors divisors)
|
||||
(fraction-ticks-format)))
|
||||
|
|
|
|||
|
|
@ -37,3 +37,23 @@
|
|||
(let ([sorted-lst (sort lst)])
|
||||
(make-hash (map cons sorted-lst (f sorted-lst)))))
|
||||
(map (λ (e) (hash-ref h e)) lst))
|
||||
|
||||
(define (transpose lsts)
|
||||
(apply map list lsts))
|
||||
|
||||
(define (equal?* xs)
|
||||
(cond [(empty? xs) #f]
|
||||
[(empty? (rest xs)) #t]
|
||||
[else (and (equal? (first xs) (second xs))
|
||||
(equal?* (rest xs)))]))
|
||||
|
||||
(define (group-neighbors lst equiv?)
|
||||
(reverse
|
||||
(map reverse
|
||||
(cond
|
||||
[(empty? lst) empty]
|
||||
[else
|
||||
(for/fold ([res (list (list (first lst)))]) ([e (in-list (rest lst))])
|
||||
(cond
|
||||
[(andmap (λ (e2) (equiv? e e2)) (first res)) (cons (cons e (first res)) (rest res))]
|
||||
[else (list* (list e) res)]))]))))
|
||||
|
|
|
|||
|
|
@ -6,13 +6,14 @@
|
|||
;; Plotting
|
||||
"common/contract.rkt"
|
||||
"common/contract-doc.rkt"
|
||||
"common/ticks.rkt"
|
||||
;"common/ticks.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
|
||||
points error-bars vector-field
|
||||
plot-title plot-x-label plot-y-label plot-z-label
|
||||
plot-foreground plot-background
|
||||
|
|
@ -72,8 +73,8 @@
|
|||
[#:lncolor lncolor (list/c byte? byte? byte?) '(255 0 0)]
|
||||
[#:out-file out-file (or/c path-string? output-port? #f) #f]
|
||||
) (is-a?/c image-snip%)
|
||||
(define x-ticks (default-ticks-fun x-min x-max))
|
||||
(define y-ticks (default-ticks-fun y-min y-max))
|
||||
(define x-ticks (new.default-x-ticks x-min x-max))
|
||||
(define y-ticks (new.default-y-ticks y-min y-max))
|
||||
|
||||
(parameterize ([new.plot-title title]
|
||||
[new.plot-x-label x-label]
|
||||
|
|
@ -110,9 +111,9 @@
|
|||
[#:lncolor lncolor (list/c byte? byte? byte?) '(255 0 0)]
|
||||
[#:out-file out-file (or/c path-string? output-port? #f) #f]
|
||||
) (is-a?/c image-snip%)
|
||||
(define x-ticks (default-ticks-fun x-min x-max))
|
||||
(define y-ticks (default-ticks-fun y-min y-max))
|
||||
(define z-ticks (default-ticks-fun z-min z-max))
|
||||
(define x-ticks (new.default-x-ticks x-min x-max))
|
||||
(define y-ticks (new.default-y-ticks y-min y-max))
|
||||
(define z-ticks (new.default-z-ticks z-min z-max))
|
||||
|
||||
(parameterize ([new.plot-title title]
|
||||
[new.plot-x-label x-label]
|
||||
|
|
|
|||
|
|
@ -12,8 +12,10 @@
|
|||
(all-from-out "common/contract.rkt"))
|
||||
|
||||
(require "common/axis-transform.rkt")
|
||||
(provide invertible-function?
|
||||
id-transform log-transform cbrt-transform hand-drawn-transform)
|
||||
(provide (all-from-out "common/axis-transform.rkt"))
|
||||
|
||||
(require "common/ticks.rkt")
|
||||
(provide (all-from-out "common/ticks.rkt"))
|
||||
|
||||
(require "common/math.rkt")
|
||||
(provide (contract-out (struct ivl ([min real?] [max real?]))))
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
#lang racket/base
|
||||
|
||||
(require racket/draw racket/class racket/contract racket/match racket/math racket/list
|
||||
(require racket/draw racket/class racket/contract racket/match racket/math racket/list racket/string
|
||||
"../common/area.rkt"
|
||||
"../common/ticks.rkt"
|
||||
"../common/vector.rkt"
|
||||
|
|
@ -10,14 +10,14 @@
|
|||
"../common/sample.rkt"
|
||||
"../common/legend.rkt"
|
||||
"../common/parameters.rkt"
|
||||
"clip.rkt"
|
||||
"sample.rkt")
|
||||
"../common/utils.rkt"
|
||||
"clip.rkt")
|
||||
|
||||
(provide 2d-plot-area%)
|
||||
|
||||
(define 2d-plot-area%
|
||||
(class plot-area%
|
||||
(init-field x-ticks y-ticks x-min x-max y-min y-max)
|
||||
(init-field rx-ticks ry-ticks x-min x-max y-min y-max)
|
||||
(init dc dc-x-min dc-y-min dc-x-size dc-y-size)
|
||||
(inherit
|
||||
set-alpha set-pen set-major-pen set-minor-pen set-brush set-background set-text-foreground
|
||||
|
|
@ -31,25 +31,22 @@
|
|||
|
||||
(reset-drawing-params)
|
||||
|
||||
(define max-y-tick-label-width
|
||||
(for/fold ([max-w 0]) ([t (in-list y-ticks)])
|
||||
(cond [(tick-major? t) (define-values (w h _1 _2)
|
||||
(get-text-extent (tick-label t)))
|
||||
(max max-w w)]
|
||||
[else max-w])))
|
||||
(define x-ticks (filter (λ (t) (<= x-min (pre-tick-value t) x-max)) rx-ticks))
|
||||
(define y-ticks (filter (λ (t) (<= y-min (pre-tick-value t) y-max)) ry-ticks))
|
||||
|
||||
(define char-height (get-char-height))
|
||||
(define (max-tick-label-width ts)
|
||||
(apply max 0 (for/list ([t (in-list ts)] #:when (pre-tick-major? t))
|
||||
(get-text-width (tick-label t)))))
|
||||
|
||||
(define max-x-tick-label-width (max-tick-label-width x-ticks))
|
||||
(define max-y-tick-label-width (max-tick-label-width y-ticks))
|
||||
|
||||
(define char-height (get-char-height))
|
||||
|
||||
(define last-x-tick-label-width
|
||||
(cond [(empty? x-ticks) 0]
|
||||
[else
|
||||
(define last-x-tick (argmax tick-p x-ticks))
|
||||
(cond [(tick-major? last-x-tick) (define-values (w _1 _2 _3)
|
||||
(get-text-extent
|
||||
(tick-label last-x-tick)))
|
||||
w]
|
||||
[else 0])]))
|
||||
(let ([x-ticks (filter pre-tick-major? x-ticks)])
|
||||
(cond [(empty? x-ticks) 0]
|
||||
[else (get-text-width (tick-label (argmax pre-tick-value x-ticks)))])))
|
||||
|
||||
(define dc-x-max (+ dc-x-min dc-x-size))
|
||||
(define dc-y-max (+ dc-y-min dc-y-size))
|
||||
|
|
@ -169,18 +166,19 @@
|
|||
(equal? (plot-y-transform) id-transform)))
|
||||
|
||||
(define plot->view
|
||||
(cond [identity-transforms? (λ (v) v)]
|
||||
[else
|
||||
(match-define (invertible-function fx _) ((plot-x-transform) x-min x-max))
|
||||
(match-define (invertible-function fy _) ((plot-y-transform) y-min y-max))
|
||||
(λ (v)
|
||||
(match-define (vector x y) v)
|
||||
(vector (fx x) (fy y)))]))
|
||||
(cond
|
||||
[identity-transforms? (λ (v) v)]
|
||||
[else
|
||||
(match-define (invertible-function fx _) (apply-transform (plot-x-transform) x-min x-max))
|
||||
(match-define (invertible-function fy _) (apply-transform (plot-y-transform) y-min y-max))
|
||||
(λ (v)
|
||||
(match-define (vector x y) v)
|
||||
(vector (fx x) (fy y)))]))
|
||||
|
||||
(define/public (plot->dc v)
|
||||
(view->dc (plot->view v)))
|
||||
|
||||
;; -------------------------------------------------------------------------
|
||||
;; ===============================================================================================
|
||||
;; Plot decoration
|
||||
|
||||
(define (draw-borders)
|
||||
|
|
@ -189,33 +187,56 @@
|
|||
(draw-rectangle (vector area-x-min area-y-min)
|
||||
(vector area-x-max area-y-max)))
|
||||
|
||||
(define (collapse-ticks ts dc-pos)
|
||||
(define (dc-dist t1 t2) (abs (- (dc-pos t1) (dc-pos t2))))
|
||||
(let ([ts (sort ts < #:key pre-tick-value)])
|
||||
(define tss
|
||||
(group-neighbors ts (λ (t1 t2) ((dc-dist t1 t2) . <= . (* 2 (plot-line-width))))))
|
||||
(for/list ([ts (in-list tss)])
|
||||
(match-define (list (tick xs majors labels) ...) ts)
|
||||
(define x (let ([xs (remove-duplicates xs)])
|
||||
(/ (apply + xs) (length xs))))
|
||||
(define major? (ormap values majors))
|
||||
(define label (string-join (remove-duplicates (map tick-label (filter pre-tick-major? ts)))
|
||||
"|"))
|
||||
(tick x major? label))))
|
||||
|
||||
(define collapsed-x-ticks
|
||||
(collapse-ticks x-ticks (λ (t) (vector-ref (plot->dc (vector (pre-tick-value t) y-min)) 0))))
|
||||
(define collapsed-y-ticks
|
||||
(collapse-ticks y-ticks (λ (t) (vector-ref (plot->dc (vector x-min (pre-tick-value t))) 1))))
|
||||
|
||||
(define (draw-x-ticks)
|
||||
(define half (* 1/2 (plot-tick-size)))
|
||||
(for ([t (in-list x-ticks)])
|
||||
(match-define (tick x x-str major?) t)
|
||||
(define radius (* 1/2 (plot-tick-size)))
|
||||
(define 1/2radius (* 1/2 radius))
|
||||
(for ([t (in-list collapsed-x-ticks)])
|
||||
(match-define (tick x major? _) t)
|
||||
(if major? (set-major-pen) (set-minor-pen))
|
||||
(put-tick (vector x y-min) half 1/2pi)
|
||||
(put-tick (vector x y-max) half 1/2pi)))
|
||||
(put-tick (vector x y-min) (if major? radius 1/2radius) 1/2pi)
|
||||
(put-tick (vector x y-max) (if major? radius 1/2radius) 1/2pi)))
|
||||
|
||||
(define (draw-y-ticks)
|
||||
(define half (* 1/2 (plot-tick-size)))
|
||||
(for ([t (in-list y-ticks)])
|
||||
(match-define (tick y y-str major?) t)
|
||||
(define radius (* 1/2 (plot-tick-size)))
|
||||
(define 1/2radius (* 1/2 radius))
|
||||
(for ([t (in-list collapsed-y-ticks)])
|
||||
(match-define (tick y major? _) t)
|
||||
(if major? (set-major-pen) (set-minor-pen))
|
||||
(put-tick (vector x-min y) half 0)
|
||||
(put-tick (vector x-max y) half 0)))
|
||||
(put-tick (vector x-min y) (if major? radius 1/2radius) 0)
|
||||
(put-tick (vector x-max y) (if major? radius 1/2radius) 0)))
|
||||
|
||||
(define (draw-x-tick-labels)
|
||||
(define offset (vector 0 (+ (pen-gap) (* 1/2 (plot-tick-size)))))
|
||||
(for ([t (in-list (filter tick-major? x-ticks))])
|
||||
(match-define (tick x x-str major?) t)
|
||||
(draw-text x-str (v+ (plot->dc (vector x y-min)) offset) 'top)))
|
||||
(for ([t (in-list collapsed-x-ticks)])
|
||||
(match-define (tick x major? label) t)
|
||||
(when (and major? ((string-length label) . > . 0))
|
||||
(draw-text label (v+ (plot->dc (vector x y-min)) offset) 'top))))
|
||||
|
||||
(define (draw-y-tick-labels)
|
||||
(define offset (vector (+ (pen-gap) (* 1/2 (plot-tick-size))) 0))
|
||||
(for ([t (in-list (filter tick-major? y-ticks))])
|
||||
(match-define (tick y y-str major?) t)
|
||||
(draw-text y-str (v- (plot->dc (vector x-min y)) offset) 'right)))
|
||||
(for ([t (in-list collapsed-y-ticks)])
|
||||
(match-define (tick y major? label) t)
|
||||
(when (and major? ((string-length label) . > . 0))
|
||||
(draw-text label (v- (plot->dc (vector x-min y)) offset) 'right))))
|
||||
|
||||
(define (draw-title)
|
||||
(define-values (title-x-size _1 _2 _3)
|
||||
|
|
|
|||
|
|
@ -6,14 +6,15 @@
|
|||
"../common/math.rkt"
|
||||
"../common/draw.rkt"
|
||||
"../common/marching-squares.rkt"
|
||||
"../common/contract.rkt" "../common/contract-doc.rkt"
|
||||
"../common/contract.rkt"
|
||||
"../common/contract-doc.rkt"
|
||||
"../common/legend.rkt"
|
||||
"../common/sample.rkt"
|
||||
"../common/parameters.rkt"
|
||||
"../common/ticks.rkt"
|
||||
"../common/vector.rkt"
|
||||
"renderer.rkt"
|
||||
"sample.rkt")
|
||||
"../common/format.rkt"
|
||||
"renderer.rkt")
|
||||
|
||||
(provide contours contour-intervals)
|
||||
|
||||
|
|
@ -30,10 +31,7 @@
|
|||
(when (empty? zs) (return empty))
|
||||
(values (apply min* zs) (apply max* zs))))
|
||||
|
||||
(define zs
|
||||
(cond [(list? levels) levels]
|
||||
[(eq? levels 'auto) (auto-contour-zs z-min z-max)]
|
||||
[else (linear-seq z-min z-max levels #:start? #f #:end? #f)]))
|
||||
(match-define (list (tick zs _ labels) ...) (contour-ticks z-min z-max levels #f))
|
||||
|
||||
(define cs (maybe-apply/list colors zs))
|
||||
(define ws (maybe-apply/list widths zs))
|
||||
|
|
@ -64,7 +62,7 @@
|
|||
(match-define (vector x1 y1 x2 y2) (scale-normalized-line line xa xb ya yb))
|
||||
(send area put-line (vector x1 y1) (vector x2 y2)))))
|
||||
|
||||
(cond [label (line-legend-entries label zs colors widths styles)]
|
||||
(cond [label (line-legend-entries label zs labels colors widths styles)]
|
||||
[else empty])))
|
||||
|
||||
(defproc (contours
|
||||
|
|
@ -100,12 +98,8 @@
|
|||
(when (empty? flat-zs) (return empty))
|
||||
(values (apply min* flat-zs) (apply max* flat-zs))))
|
||||
|
||||
(define contour-zs
|
||||
(cond [(list? levels) levels]
|
||||
[(eq? levels 'auto) (auto-contour-zs z-min z-max)]
|
||||
[else (linear-seq z-min z-max levels #:start? #f #:end? #f)]))
|
||||
(match-define (list (tick zs _ labels) ...) (contour-ticks z-min z-max levels #t))
|
||||
|
||||
(define zs (append (list z-min) contour-zs (list z-max)))
|
||||
(define cs (map ->brush-color (maybe-apply/list colors zs)))
|
||||
(define fss (map ->brush-style (maybe-apply/list styles zs)))
|
||||
(define pss (map (λ (fill-style) (if (eq? fill-style 'solid) 'solid 'transparent)) fss))
|
||||
|
|
@ -163,8 +157,7 @@
|
|||
area)
|
||||
|
||||
(cond [label (contour-intervals-legend-entries
|
||||
label z-min z-max contour-zs
|
||||
cs fss cs '(1) pss contour-colors contour-widths contour-styles)]
|
||||
label zs labels cs fss cs '(1) pss contour-colors contour-widths contour-styles)]
|
||||
[else empty])))
|
||||
|
||||
(defproc (contour-intervals
|
||||
|
|
|
|||
|
|
@ -6,19 +6,21 @@
|
|||
"../common/ticks.rkt"
|
||||
"../common/math.rkt"
|
||||
"../common/format.rkt"
|
||||
"../common/contract.rkt" "../common/contract-doc.rkt"
|
||||
"../common/contract.rkt"
|
||||
"../common/contract-doc.rkt"
|
||||
"../common/legend.rkt"
|
||||
"../common/vector.rkt"
|
||||
"../common/area.rkt"
|
||||
"../common/sample.rkt"
|
||||
"../common/parameters.rkt"
|
||||
"../common/axis-transform.rkt"
|
||||
"renderer.rkt"
|
||||
"area.rkt"
|
||||
"line.rkt"
|
||||
"interval.rkt"
|
||||
"point.rkt"
|
||||
"contour.rkt"
|
||||
"sample.rkt")
|
||||
"clip.rkt")
|
||||
|
||||
(provide x-axis y-axis axes
|
||||
polar-axes
|
||||
|
|
@ -38,72 +40,128 @@
|
|||
(define x-ticks (send area get-x-ticks))
|
||||
(define half (* 1/2 (plot-tick-size)))
|
||||
|
||||
(send area set-minor-pen)
|
||||
(send area set-alpha 1/2)
|
||||
(send area set-major-pen)
|
||||
(send area put-line (vector x-min y) (vector x-max y))
|
||||
|
||||
(when ticks?
|
||||
(for ([t (in-list x-ticks)])
|
||||
(match-define (tick x _ major?) t)
|
||||
(match-define (tick x major? _) t)
|
||||
(if major? (send area set-major-pen) (send area set-minor-pen))
|
||||
(send area put-tick (vector x y) half 1/2pi)))
|
||||
|
||||
empty)
|
||||
|
||||
(define ((x-axis-ticks-fun y) x-min x-max y-min y-max)
|
||||
(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))
|
||||
|
||||
(define ((y-axis-render-proc x ticks?) area)
|
||||
(define y-min (send area get-y-min))
|
||||
(define y-max (send area get-y-max))
|
||||
(define y-ticks (send area get-y-ticks))
|
||||
(define half (* 1/2 (plot-tick-size)))
|
||||
|
||||
(send area set-minor-pen)
|
||||
(send area set-alpha 1/2)
|
||||
(send area set-major-pen)
|
||||
(send area put-line (vector x y-min) (vector x y-max))
|
||||
|
||||
(when ticks?
|
||||
(for ([t (in-list y-ticks)])
|
||||
(match-define (tick y _ major?) t)
|
||||
(match-define (tick y major? _) t)
|
||||
(if major? (send area set-major-pen) (send area set-minor-pen))
|
||||
(send area put-tick (vector x y) half 0)))
|
||||
|
||||
empty)
|
||||
|
||||
(defproc (x-axis [y real? 0] [#:ticks? ticks? boolean? (x-axis-ticks?)]) renderer2d?
|
||||
(renderer2d (x-axis-render-proc y ticks?) null-2d-ticks-fun null-2d-bounds-fun #f #f #f #f))
|
||||
(define ((y-axis-ticks-fun x) x-min x-max y-min y-max)
|
||||
(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] [#:ticks? ticks? boolean? (y-axis-ticks?)]) renderer2d?
|
||||
(renderer2d (y-axis-render-proc x ticks?) null-2d-ticks-fun null-2d-bounds-fun #f #f #f #f))
|
||||
(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))
|
||||
|
||||
(defproc (axes [x real? 0] [y real? 0]
|
||||
(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?)]
|
||||
[#:y-ticks? y-ticks? boolean? (y-axis-ticks?)]
|
||||
) (listof renderer2d?)
|
||||
(list (x-axis y #:ticks? x-ticks?)
|
||||
(y-axis x #:ticks? y-ticks?)))
|
||||
(list (x-axis y add-y-tick? #:ticks? x-ticks?)
|
||||
(y-axis x add-x-tick? #:ticks? y-ticks?)))
|
||||
|
||||
;; ===================================================================================================
|
||||
;; Polar axes
|
||||
|
||||
(define (build-polar-axes num x-min x-max y-min y-max)
|
||||
(define step (/ (* 2 pi) num))
|
||||
(define θs (build-list num (λ (n) (* n step))))
|
||||
(define max-r (max (vmag (vector x-min y-min)) (vmag (vector x-min y-max))
|
||||
(vmag (vector x-max y-max)) (vmag (vector x-max y-min))))
|
||||
(define-values (r-mins r-maxs)
|
||||
(for/lists (r-mins r-maxs) ([θ (in-list θs)])
|
||||
(define-values (v1 v2)
|
||||
(clip-line (vector 0 0) (vector (* max-r (cos θ)) (* max-r (sin θ)))
|
||||
x-min x-max y-min y-max))
|
||||
(values (if v1 (vmag v1) #f)
|
||||
(if v2 (vmag v2) #f))))
|
||||
(for/lists (θs r-mins r-maxs) ([θ (in-list θs)] [r-min (in-list r-mins)] [r-max (in-list r-maxs)]
|
||||
#:when (and r-min r-max (not (= r-min r-max))))
|
||||
(values θ r-min r-max)))
|
||||
|
||||
(define ((polar-axes-render-proc num ticks?) area)
|
||||
(define x-min (send area get-x-min))
|
||||
(define x-max (send area get-x-max))
|
||||
(define y-min (send area get-y-min))
|
||||
(define y-max (send area get-y-max))
|
||||
|
||||
(define step (/ (* 2 pi) num))
|
||||
(define θs (build-list num (λ (n) (* n step))))
|
||||
(define-values (θs r-mins r-maxs) (build-polar-axes num x-min x-max y-min y-max))
|
||||
|
||||
(send area set-minor-pen)
|
||||
(let ([r (* 2 (max (- x-min) x-max (- y-min) y-max))])
|
||||
(for ([θ (in-list θs)])
|
||||
(send area put-line (vector 0 0) (vector (* r (cos θ)) (* r (sin θ))))))
|
||||
;; Draw the axes
|
||||
(send area set-alpha 1/2)
|
||||
(send area set-major-pen)
|
||||
(for ([θ (in-list θs)] [r-min (in-list r-mins)] [r-max (in-list r-maxs)])
|
||||
(send area put-line
|
||||
(vector (* r-min (cos θ)) (* r-min (sin θ)))
|
||||
(vector (* r-max (cos θ)) (* r-max (sin θ)))))
|
||||
|
||||
(define ticks (remove-duplicates (map (λ (t) (abs (tick-p t)))
|
||||
(send area get-x-ticks))))
|
||||
|
||||
(send area set-minor-pen 'long-dash)
|
||||
(for ([r (in-list ticks)])
|
||||
(define pts (for/list ([θ (in-list (linear-seq 0 (* 2 pi) 100))])
|
||||
(vector (* r (cos θ)) (* r (sin θ)))))
|
||||
(send area put-lines pts))
|
||||
(when ticks?
|
||||
(define corner-rs
|
||||
(list (vmag (vector x-min y-min)) (vmag (vector x-min y-max))
|
||||
(vmag (vector x-max y-max)) (vmag (vector x-max y-min))))
|
||||
(define r-min (if (and (<= x-min 0 x-max) (<= y-min 0 y-max)) 0 (apply min corner-rs)))
|
||||
(define r-max (apply max corner-rs))
|
||||
(define ts ((linear-ticks) r-min r-max (polar-axes-max-ticks) id-transform))
|
||||
|
||||
(send area set-alpha 1/2)
|
||||
(for ([t (in-list ts)])
|
||||
(match-define (tick r major? label) t)
|
||||
(if major? (send area set-major-pen) (send area set-minor-pen 'long-dash))
|
||||
(define pts (for/list ([θ (in-list (linear-seq 0 (* 2 pi) 100))])
|
||||
(vector (* r (cos θ)) (* r (sin θ)))))
|
||||
(send area put-lines pts))
|
||||
|
||||
(when (not (empty? θs))
|
||||
;; find the longest axis
|
||||
(define mag (expt 10 (- (digits-for-range r-min r-max))))
|
||||
(match-define (list mθ mr-min mr-max)
|
||||
;; find the longest, rounded to drown out floating-point error
|
||||
(argmax (λ (lst) (* (round (/ (- (third lst) (second lst)) mag)) mag))
|
||||
(map list θs r-mins r-maxs)))
|
||||
|
||||
(send area set-alpha 1)
|
||||
(for ([t (in-list ts)])
|
||||
(match-define (tick r major? label) t)
|
||||
(when (and major? (<= mr-min r mr-max))
|
||||
(send area put-text label (vector (* r (cos mθ)) (* r (sin mθ)))
|
||||
'center 0 #:outline? #t)))))
|
||||
|
||||
empty)
|
||||
|
||||
|
|
@ -121,9 +179,10 @@
|
|||
(define y-max (send area get-y-max))
|
||||
(define x-ticks (send area get-x-ticks))
|
||||
|
||||
(send area set-pen (plot-foreground) (* 1/2 (plot-line-width)) 'long-dash)
|
||||
(send area set-alpha 1/2)
|
||||
(for ([t (in-list x-ticks)])
|
||||
(match-define (tick x _ major?) t)
|
||||
(match-define (tick x major? _) t)
|
||||
(if major? (send area set-major-pen) (send area set-minor-pen 'long-dash))
|
||||
(send area put-line (vector x y-min) (vector x y-max)))
|
||||
|
||||
empty)
|
||||
|
|
@ -133,9 +192,10 @@
|
|||
(define x-max (send area get-x-max))
|
||||
(define y-ticks (send area get-y-ticks))
|
||||
|
||||
(send area set-pen (plot-foreground) (* 1/2 (plot-line-width)) 'long-dash)
|
||||
(send area set-alpha 1/2)
|
||||
(for ([t (in-list y-ticks)])
|
||||
(match-define (tick y _ major?) t)
|
||||
(match-define (tick y major? _) t)
|
||||
(if major? (send area set-major-pen) (send area set-minor-pen 'long-dash))
|
||||
(send area put-line (vector x-min y) (vector x-max y)))
|
||||
|
||||
empty)
|
||||
|
|
|
|||
|
|
@ -5,14 +5,14 @@
|
|||
(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/sample.rkt"
|
||||
"../common/parameters.rkt"
|
||||
"renderer.rkt"
|
||||
"bounds.rkt"
|
||||
"sample.rkt")
|
||||
"bounds.rkt")
|
||||
|
||||
(provide lines-interval parametric-interval polar-interval function-interval inverse-interval)
|
||||
|
||||
|
|
|
|||
|
|
@ -1,7 +1,8 @@
|
|||
#lang racket/base
|
||||
|
||||
(require racket/flonum racket/list racket/promise racket/math racket/contract
|
||||
"../common/contract.rkt" "../common/contract-doc.rkt"
|
||||
"../common/contract.rkt"
|
||||
"../common/contract-doc.rkt"
|
||||
"../common/math.rkt"
|
||||
"../common/utils.rkt"
|
||||
"../common/sample.rkt"
|
||||
|
|
|
|||
|
|
@ -6,13 +6,13 @@
|
|||
"../common/math.rkt"
|
||||
"../common/vector.rkt"
|
||||
"../common/ticks.rkt"
|
||||
"../common/contract.rkt" "../common/contract-doc.rkt"
|
||||
"../common/contract.rkt"
|
||||
"../common/contract-doc.rkt"
|
||||
"../common/legend.rkt"
|
||||
"../common/sample.rkt"
|
||||
"../common/parameters.rkt"
|
||||
"renderer.rkt"
|
||||
"bounds.rkt"
|
||||
"sample.rkt")
|
||||
"bounds.rkt")
|
||||
|
||||
(provide lines parametric polar function inverse)
|
||||
|
||||
|
|
|
|||
|
|
@ -131,6 +131,9 @@
|
|||
(define x-transform (plot-x-transform))
|
||||
(define y-transform (plot-y-transform))
|
||||
(define z-transform (plot-z-transform))
|
||||
(define x-ticks (plot-x-ticks))
|
||||
(define y-ticks (plot-y-ticks))
|
||||
(define z-ticks (plot-z-ticks))
|
||||
(define animating? (plot-animating?))
|
||||
|
||||
(dc (λ (dc x y)
|
||||
|
|
@ -146,6 +149,9 @@
|
|||
[plot-x-transform x-transform]
|
||||
[plot-y-transform y-transform]
|
||||
[plot-z-transform z-transform]
|
||||
[plot-x-ticks x-ticks]
|
||||
[plot-y-ticks y-ticks]
|
||||
[plot-z-ticks z-ticks]
|
||||
[plot-animating? animating?])
|
||||
(plot/dc renderer-tree dc x y width height
|
||||
#:x-min x-min #:x-max x-max #:y-min y-min #:y-max y-max
|
||||
|
|
|
|||
|
|
@ -101,8 +101,8 @@
|
|||
(define ((discrete-histogram-ticks-fun cats tick-xs) _x-min _x-max y-min y-max)
|
||||
(define x-ticks
|
||||
(for/list ([cat (in-list cats)] [x (in-list tick-xs)])
|
||||
(tick x (->plot-label cat) #t)))
|
||||
(values x-ticks (default-ticks-fun y-min y-max)))
|
||||
(tick x #t (->plot-label cat))))
|
||||
(values x-ticks (default-y-ticks y-min y-max)))
|
||||
|
||||
(defproc (discrete-histogram
|
||||
[cat-vals (listof (vector/c any/c real?))]
|
||||
|
|
|
|||
|
|
@ -1,9 +1,11 @@
|
|||
#lang racket/base
|
||||
|
||||
(require racket/list racket/match racket/contract
|
||||
"../common/contract.rkt" "../common/contract-doc.rkt"
|
||||
"../common/contract.rkt"
|
||||
"../common/contract-doc.rkt"
|
||||
"../common/math.rkt"
|
||||
"../common/ticks.rkt")
|
||||
"../common/ticks.rkt"
|
||||
"../common/parameters.rkt")
|
||||
|
||||
(provide (all-defined-out))
|
||||
|
||||
|
|
@ -52,5 +54,5 @@
|
|||
|
||||
(defproc (default-2d-ticks-fun [x-min real?] [x-max real?] [y-min real?] [y-max real?]
|
||||
) (values (listof tick?) (listof tick?))
|
||||
(values (default-ticks-fun x-min x-max)
|
||||
(default-ticks-fun y-min y-max)))
|
||||
(values (default-x-ticks x-min x-max)
|
||||
(default-y-ticks y-min y-max)))
|
||||
|
|
|
|||
|
|
@ -1,12 +0,0 @@
|
|||
#lang racket/base
|
||||
|
||||
(require racket/contract
|
||||
"../common/contract.rkt"
|
||||
"../common/sample.rkt"
|
||||
"../common/parameters.rkt")
|
||||
|
||||
(provide (all-defined-out))
|
||||
|
||||
(define function->sampler (make-function->sampler plot-x-transform))
|
||||
(define inverse->sampler (make-function->sampler plot-y-transform))
|
||||
(define 2d-function->sampler (make-2d-function->sampler plot-x-transform plot-y-transform))
|
||||
|
|
@ -11,14 +11,13 @@
|
|||
"../common/parameters.rkt"
|
||||
"matrix.rkt"
|
||||
"shape.rkt"
|
||||
"clip.rkt"
|
||||
"sample.rkt")
|
||||
"clip.rkt")
|
||||
|
||||
(provide 3d-plot-area%)
|
||||
|
||||
(define 3d-plot-area%
|
||||
(class plot-area%
|
||||
(init-field x-ticks y-ticks z-ticks x-min x-max y-min y-max z-min z-max)
|
||||
(init-field rx-ticks ry-ticks rz-ticks x-min x-max y-min y-max z-min z-max)
|
||||
(init dc dc-x-min dc-y-min dc-x-size dc-y-size)
|
||||
(inherit
|
||||
set-alpha set-pen set-major-pen set-minor-pen set-brush set-background set-text-foreground
|
||||
|
|
@ -32,6 +31,10 @@
|
|||
|
||||
(reset-drawing-params)
|
||||
|
||||
(define x-ticks (filter (λ (t) (<= x-min (pre-tick-value t) x-max)) rx-ticks))
|
||||
(define y-ticks (filter (λ (t) (<= y-min (pre-tick-value t) y-max)) ry-ticks))
|
||||
(define z-ticks (filter (λ (t) (<= z-min (pre-tick-value t) z-max)) rz-ticks))
|
||||
|
||||
(define char-height (get-char-height))
|
||||
|
||||
(define clipping? #f)
|
||||
|
|
@ -104,19 +107,20 @@
|
|||
(equal? (plot-z-transform) id-transform)))
|
||||
|
||||
(define center
|
||||
(cond [identity-axis-transforms?
|
||||
(λ (v)
|
||||
(match-define (vector x y z) v)
|
||||
(vector (- x x-mid) (- y y-mid) (- z z-mid)))]
|
||||
[else
|
||||
(match-define (invertible-function fx _) ((plot-x-transform) x-min x-max))
|
||||
(match-define (invertible-function fy _) ((plot-y-transform) y-min y-max))
|
||||
(match-define (invertible-function fz _) ((plot-z-transform) z-min z-max))
|
||||
(λ (v)
|
||||
(match-define (vector x y z) v)
|
||||
(if do-axis-transforms?
|
||||
(vector (- (fx x) x-mid) (- (fy y) y-mid) (- (fz z) z-mid))
|
||||
(vector (- x x-mid) (- y y-mid) (- z z-mid))))]))
|
||||
(cond
|
||||
[identity-axis-transforms?
|
||||
(λ (v)
|
||||
(match-define (vector x y z) v)
|
||||
(vector (- x x-mid) (- y y-mid) (- z z-mid)))]
|
||||
[else
|
||||
(match-define (invertible-function fx _) (apply-transform (plot-x-transform) x-min x-max))
|
||||
(match-define (invertible-function fy _) (apply-transform (plot-y-transform) y-min y-max))
|
||||
(match-define (invertible-function fz _) (apply-transform (plot-z-transform) z-min z-max))
|
||||
(λ (v)
|
||||
(match-define (vector x y z) v)
|
||||
(if do-axis-transforms?
|
||||
(vector (- (fx x) x-mid) (- (fy y) y-mid) (- (fz z) z-mid))
|
||||
(vector (- x x-mid) (- y y-mid) (- z z-mid))))]))
|
||||
|
||||
(define transform-matrix/no-rho
|
||||
(m3* (m3-rotate-z theta) (m3-scale (/ x-size) (/ y-size) (/ z-size))))
|
||||
|
|
@ -187,13 +191,12 @@
|
|||
(define x-labels-y-min? ((cos theta) . >= . 0))
|
||||
(define y-labels-x-min? ((sin theta) . >= . 0))
|
||||
|
||||
(define max-x-tick-label-width
|
||||
(cond [(empty? x-ticks) 0]
|
||||
[else (apply max (map (λ (t) (get-text-width (tick-label t))) x-ticks))]))
|
||||
(define (max-tick-label-width ts)
|
||||
(apply max 0 (for/list ([t (in-list ts)] #:when (pre-tick-major? t))
|
||||
(get-text-width (tick-label t)))))
|
||||
|
||||
(define max-y-tick-label-width
|
||||
(cond [(empty? y-ticks) 0]
|
||||
[else (apply max (map (λ (t) (get-text-width (tick-label t))) y-ticks))]))
|
||||
(define max-x-tick-label-width (max-tick-label-width x-ticks))
|
||||
(define max-y-tick-label-width (max-tick-label-width y-ticks))
|
||||
|
||||
;; Label drawing parameters
|
||||
|
||||
|
|
@ -242,10 +245,10 @@
|
|||
[(s . < . (sin (degrees->radians 67.5))) (if x-labels-y-min? 'top-left 'top-right)]
|
||||
[else (if x-labels-y-min? 'top-left 'top-right)]))
|
||||
|
||||
(define fx (invertible-function-f ((plot-x-transform) x-min x-max)))
|
||||
(for/list ([t (in-list (filter tick-major? x-ticks))])
|
||||
(match-define (tick x x-str major?) t)
|
||||
(list x-str (v+ (plot->dc (vector (fx x) y z-min)) offset) anchor 0)))
|
||||
(define fx (invertible-function-f (apply-transform (plot-x-transform) x-min x-max)))
|
||||
(for/list ([t (in-list x-ticks)] #:when (pre-tick-major? t))
|
||||
(match-define (tick x _ label) t)
|
||||
(list label (v+ (plot->dc (vector (fx x) y z-min)) offset) anchor 0)))
|
||||
|
||||
(define (get-y-tick-label-params)
|
||||
(define x-axis-angle (plot-dir->dc-angle (vector 1 0 0)))
|
||||
|
|
@ -261,10 +264,10 @@
|
|||
[(c . > . (cos (degrees->radians 157.5))) (if y-labels-x-min? 'top-left 'top-right)]
|
||||
[else (if y-labels-x-min? 'top-left 'top-right)]))
|
||||
|
||||
(define fy (invertible-function-f ((plot-y-transform) y-min y-max)))
|
||||
(for/list ([t (in-list (filter tick-major? y-ticks))])
|
||||
(match-define (tick y y-str major?) t)
|
||||
(list y-str (v+ (plot->dc (vector x (fy y) z-min)) offset) anchor 0)))
|
||||
(define fy (invertible-function-f (apply-transform (plot-y-transform) y-min y-max)))
|
||||
(for/list ([t (in-list y-ticks)] #:when (pre-tick-major? t))
|
||||
(match-define (tick y _ label) t)
|
||||
(list label (v+ (plot->dc (vector x (fy y) z-min)) offset) anchor 0)))
|
||||
|
||||
(define (get-z-tick-label-params)
|
||||
(define dist (+ (pen-gap) (* 1/2 (plot-tick-size))))
|
||||
|
|
@ -272,10 +275,10 @@
|
|||
(define x (if x-labels-y-min? x-min x-max))
|
||||
(define y (if y-labels-x-min? y-max y-min))
|
||||
|
||||
(define fz (invertible-function-f ((plot-z-transform) z-min z-max)))
|
||||
(for/list ([t (in-list (filter tick-major? z-ticks))])
|
||||
(match-define (tick z z-str major?) t)
|
||||
(list z-str (v+ (plot->dc (vector x y (fz z))) offset) 'bottom-right 0)))
|
||||
(define fz (invertible-function-f (apply-transform (plot-z-transform) z-min z-max)))
|
||||
(for/list ([t (in-list z-ticks)] #:when (pre-tick-major? t))
|
||||
(match-define (tick z _ label) t)
|
||||
(list label (v+ (plot->dc (vector x y (fz z))) offset) 'bottom-right 0)))
|
||||
|
||||
(define (get-label-params)
|
||||
(append (if (plot-x-label) (list (get-x-label-params)) empty)
|
||||
|
|
@ -351,37 +354,40 @@
|
|||
|
||||
(define (put-x-ticks)
|
||||
(define radius (* 1/2 (plot-tick-size)))
|
||||
(define 1/2radius (* 1/2 radius))
|
||||
(define angle (plot-dir->dc-angle (vector 0 1 0)))
|
||||
(define fx (invertible-function-f ((plot-x-transform) x-min x-max)))
|
||||
(define fx (invertible-function-f (apply-transform (plot-x-transform) x-min x-max)))
|
||||
(for ([t (in-list x-ticks)])
|
||||
(match-define (tick x x-str major?) t)
|
||||
(match-define (tick x major? _) t)
|
||||
(if major? (put-major-pen) (put-minor-pen))
|
||||
; x ticks on the y-min and y-max border
|
||||
(for ([y (list y-min y-max)])
|
||||
(put-tick (vector (fx x) y z-min) radius angle))))
|
||||
(put-tick (vector (fx x) y z-min) (if major? radius 1/2radius) angle))))
|
||||
|
||||
(define (put-y-ticks)
|
||||
(define radius (* 1/2 (plot-tick-size)))
|
||||
(define 1/2radius (* 1/2 radius))
|
||||
(define angle (plot-dir->dc-angle (vector 1 0 0)))
|
||||
(define fy (invertible-function-f ((plot-y-transform) y-min y-max)))
|
||||
(define fy (invertible-function-f (apply-transform (plot-y-transform) y-min y-max)))
|
||||
(for ([t (in-list y-ticks)])
|
||||
(match-define (tick y y-str major?) t)
|
||||
(match-define (tick y major? _) t)
|
||||
(if major? (put-major-pen) (put-minor-pen))
|
||||
; y ticks on the x-min border
|
||||
(for ([x (list x-min x-max)])
|
||||
(put-tick (vector x (fy y) z-min) radius angle))))
|
||||
(put-tick (vector x (fy y) z-min) (if major? radius 1/2radius) angle))))
|
||||
|
||||
(define (put-z-ticks)
|
||||
(define radius (* 1/2 (plot-tick-size)))
|
||||
(define 1/2radius (* 1/2 radius))
|
||||
(define angle 0)
|
||||
(define fz (invertible-function-f ((plot-z-transform) z-min z-max)))
|
||||
(define fz (invertible-function-f (apply-transform (plot-z-transform) z-min z-max)))
|
||||
(for ([t (in-list z-ticks)])
|
||||
(match-define (tick z z-str major?) t)
|
||||
(match-define (tick z major? _) t)
|
||||
(if major? (put-major-pen) (put-minor-pen))
|
||||
; z ticks on all four axes
|
||||
(for* ([x (list x-min x-max)]
|
||||
[y (list y-min y-max)])
|
||||
(put-tick (vector x y (fz z)) radius angle))))
|
||||
(put-tick (vector x y (fz z)) (if major? radius 1/2radius) angle))))
|
||||
|
||||
(define (draw-labels)
|
||||
(for ([params (in-list (get-label-params))])
|
||||
|
|
@ -656,7 +662,7 @@
|
|||
;; Right
|
||||
(if ((sin theta) . < . 0)
|
||||
(list (vector x2 y1 z1) (vector x2 y2 z1) (vector x2 y2 z2) (vector x2 y1 z2))
|
||||
empty))
|
||||
empty))
|
||||
c)))
|
||||
|
||||
(define/public (put-glyphs vs symbol size)
|
||||
|
|
|
|||
|
|
@ -1,7 +1,8 @@
|
|||
#lang racket/base
|
||||
|
||||
(require racket/class racket/match racket/list racket/flonum racket/contract
|
||||
"../common/contract.rkt" "../common/contract-doc.rkt"
|
||||
"../common/contract.rkt"
|
||||
"../common/contract-doc.rkt"
|
||||
"../common/math.rkt"
|
||||
"../common/vector.rkt"
|
||||
"../common/marching-squares.rkt"
|
||||
|
|
@ -11,7 +12,6 @@
|
|||
"../common/sample.rkt"
|
||||
"../common/parameters.rkt"
|
||||
"renderer.rkt"
|
||||
"sample.rkt"
|
||||
"bounds.rkt")
|
||||
|
||||
(provide contours3d contour-intervals3d)
|
||||
|
|
@ -23,10 +23,8 @@
|
|||
(define-values (x-min x-max y-min y-max z-min z-max) (send area get-bounds))
|
||||
(match-define (list xs ys zss) (f x-min x-max (animated-samples samples)
|
||||
y-min y-max (animated-samples samples)))
|
||||
(define zs
|
||||
(cond [(list? levels) levels]
|
||||
[(eq? levels 'auto) (auto-contour-zs z-min z-max)]
|
||||
[else (linear-seq z-min z-max levels #:start? #f #:stop? #f)]))
|
||||
|
||||
(match-define (list (tick zs _ labels) ...) (contour-ticks z-min z-max levels #f))
|
||||
|
||||
(define cs (maybe-apply/list colors zs))
|
||||
(define ws (maybe-apply/list widths zs))
|
||||
|
|
@ -61,7 +59,7 @@
|
|||
(center-coord (list (vector xa ya z1) (vector xb ya z2)
|
||||
(vector xa yb z3) (vector xb yb z4)))))))
|
||||
|
||||
(cond [label (line-legend-entries label zs colors widths styles)]
|
||||
(cond [label (line-legend-entries label zs labels colors widths styles)]
|
||||
[else empty]))
|
||||
|
||||
(defproc (contours3d
|
||||
|
|
@ -94,12 +92,8 @@
|
|||
(match-define (list xs ys zss) (f x-min x-max (animated-samples samples)
|
||||
y-min y-max (animated-samples samples)))
|
||||
|
||||
(define contour-zs
|
||||
(cond [(list? levels) levels]
|
||||
[(eq? levels 'auto) (auto-contour-zs z-min z-max)]
|
||||
[else (linear-seq z-min z-max levels #:start? #f #:end? #f)]))
|
||||
(match-define (list (tick zs _ labels) ...) (contour-ticks z-min z-max levels #t))
|
||||
|
||||
(define zs (append (list z-min) contour-zs (list z-max)))
|
||||
(define cs (maybe-apply/list colors zs))
|
||||
(define lcs (maybe-apply/list line-colors zs))
|
||||
(define lws (maybe-apply/list line-widths zs))
|
||||
|
|
@ -140,7 +134,7 @@
|
|||
area)
|
||||
|
||||
(cond [label (contour-intervals-legend-entries
|
||||
label z-min z-max contour-zs colors '(solid) line-colors line-widths line-styles
|
||||
label zs labels colors '(solid) line-colors line-widths line-styles
|
||||
contour-colors contour-widths contour-styles)]
|
||||
[else empty]))
|
||||
|
||||
|
|
|
|||
|
|
@ -4,13 +4,13 @@
|
|||
"../common/marching-cubes.rkt"
|
||||
"../common/math.rkt"
|
||||
"../common/vector.rkt"
|
||||
"../common/contract.rkt" "../common/contract-doc.rkt"
|
||||
"../common/contract.rkt"
|
||||
"../common/contract-doc.rkt"
|
||||
"../common/draw.rkt"
|
||||
"../common/legend.rkt"
|
||||
"../common/sample.rkt"
|
||||
"../common/parameters.rkt"
|
||||
"renderer.rkt"
|
||||
"sample.rkt")
|
||||
"renderer.rkt")
|
||||
|
||||
(provide isosurface3d isosurfaces3d polar3d)
|
||||
|
||||
|
|
|
|||
|
|
@ -3,12 +3,12 @@
|
|||
(require racket/class racket/match racket/list 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/sample.rkt"
|
||||
"../common/parameters.rkt"
|
||||
"renderer.rkt"
|
||||
"sample.rkt")
|
||||
"renderer.rkt")
|
||||
|
||||
(provide lines3d parametric3d)
|
||||
|
||||
|
|
|
|||
|
|
@ -153,6 +153,9 @@
|
|||
(define x-transform (plot-x-transform))
|
||||
(define y-transform (plot-y-transform))
|
||||
(define z-transform (plot-z-transform))
|
||||
(define x-ticks (plot-x-ticks))
|
||||
(define y-ticks (plot-y-ticks))
|
||||
(define z-ticks (plot-z-ticks))
|
||||
(define animating? (plot-animating?))
|
||||
(define samples (plot3d-samples))
|
||||
(define ambient-light (plot3d-ambient-light))
|
||||
|
|
@ -172,6 +175,9 @@
|
|||
[plot-x-transform x-transform]
|
||||
[plot-y-transform y-transform]
|
||||
[plot-z-transform z-transform]
|
||||
[plot-x-ticks x-ticks]
|
||||
[plot-y-ticks y-ticks]
|
||||
[plot-z-ticks z-ticks]
|
||||
[plot-animating? animating?]
|
||||
[plot3d-samples samples]
|
||||
[plot3d-ambient-light ambient-light]
|
||||
|
|
|
|||
|
|
@ -68,11 +68,11 @@
|
|||
_x-min _x-max _y-min _y-max z-min z-max)
|
||||
(define x-ticks
|
||||
(for/list ([cat (in-list c1s)] [x (in-list tick-xs)])
|
||||
(tick x (->plot-label cat) #t)))
|
||||
(tick x #t (->plot-label cat))))
|
||||
(define y-ticks
|
||||
(for/list ([cat (in-list c2s)] [y (in-list tick-ys)])
|
||||
(tick y (->plot-label cat) #t)))
|
||||
(values x-ticks y-ticks (default-ticks-fun z-min z-max)))
|
||||
(tick y #t (->plot-label cat))))
|
||||
(values x-ticks y-ticks (default-z-ticks z-min z-max)))
|
||||
|
||||
(define (adjust/gap i gap)
|
||||
(match-define (ivl x1 x2) i)
|
||||
|
|
|
|||
|
|
@ -1,9 +1,11 @@
|
|||
#lang racket/base
|
||||
|
||||
(require racket/list racket/match racket/contract
|
||||
"../common/contract.rkt" "../common/contract-doc.rkt"
|
||||
"../common/contract.rkt"
|
||||
"../common/contract-doc.rkt"
|
||||
"../common/math.rkt"
|
||||
"../common/ticks.rkt")
|
||||
"../common/ticks.rkt"
|
||||
"../common/parameters.rkt")
|
||||
|
||||
(provide (all-defined-out))
|
||||
|
||||
|
|
@ -63,6 +65,6 @@
|
|||
[y-min real?] [y-max real?]
|
||||
[z-min real?] [z-max real?]
|
||||
) (values (listof tick?) (listof tick?) (listof tick?))
|
||||
(values (default-ticks-fun x-min x-max)
|
||||
(default-ticks-fun y-min y-max)
|
||||
(default-ticks-fun z-min z-max)))
|
||||
(values (default-x-ticks x-min x-max)
|
||||
(default-y-ticks y-min y-max)
|
||||
(default-z-ticks z-min z-max)))
|
||||
|
|
|
|||
|
|
@ -1,12 +0,0 @@
|
|||
#lang racket/base
|
||||
|
||||
(require racket/contract
|
||||
"../common/contract.rkt"
|
||||
"../common/sample.rkt"
|
||||
"../common/parameters.rkt")
|
||||
|
||||
(provide (all-defined-out))
|
||||
|
||||
(define 2d-function->sampler (make-2d-function->sampler plot-x-transform plot-y-transform))
|
||||
(define 3d-function->sampler
|
||||
(make-3d-function->sampler plot-x-transform plot-y-transform plot-z-transform))
|
||||
|
|
@ -1,7 +1,8 @@
|
|||
#lang racket/base
|
||||
|
||||
(require racket/class racket/match racket/list racket/flonum racket/contract
|
||||
"../common/contract.rkt" "../common/contract-doc.rkt"
|
||||
"../common/contract.rkt"
|
||||
"../common/contract-doc.rkt"
|
||||
"../common/math.rkt"
|
||||
"../common/vector.rkt"
|
||||
"../common/marching-squares.rkt"
|
||||
|
|
@ -12,7 +13,6 @@
|
|||
"../common/parameters.rkt"
|
||||
"area.rkt"
|
||||
"renderer.rkt"
|
||||
"sample.rkt"
|
||||
"bounds.rkt")
|
||||
|
||||
(provide surface3d)
|
||||
|
|
|
|||
301
collects/plot/tests/axis-transform-tests.rkt
Normal file
301
collects/plot/tests/axis-transform-tests.rkt
Normal file
|
|
@ -0,0 +1,301 @@
|
|||
#lang racket
|
||||
|
||||
(require racket/flonum
|
||||
plot
|
||||
plot/utils
|
||||
plot/common/contract
|
||||
plot/common/contract-doc
|
||||
plot/common/axis-transform
|
||||
)
|
||||
|
||||
(x-axis-ticks? #f)
|
||||
(y-axis-ticks? #f)
|
||||
|
||||
(values
|
||||
(parameterize ([plot-x-transform log-transform])
|
||||
(plot (list (function values 1 5)
|
||||
(function cos 1 5 #:color 3))))
|
||||
(parameterize ([plot-x-transform cbrt-transform])
|
||||
(plot (list (function values -2 2)
|
||||
(function cos -2 2 #:color 3))))
|
||||
(parameterize ([plot-x-transform log-transform]
|
||||
[plot-y-transform cbrt-transform])
|
||||
(define xs (nonlinear-seq 1 5 20 log-transform))
|
||||
(define ys (nonlinear-seq -1 5 20 cbrt-transform))
|
||||
(plot (points (map vector xs ys)))))
|
||||
|
||||
(let ()
|
||||
(define trans1 (hand-drawn-transform 25))
|
||||
(define trans2 (hand-drawn-transform 100))
|
||||
(values
|
||||
(parameterize ([plot-x-transform trans1])
|
||||
(plot (list (function values -2 2)
|
||||
(function cos -2 2 #:color 3))))
|
||||
(parameterize ([plot-x-transform trans2])
|
||||
(plot (list (function values -2 2)
|
||||
(function cos -2 2 #:color 3))))
|
||||
(parameterize ([plot-x-transform trans1]
|
||||
[plot-y-transform trans2])
|
||||
(define xs (nonlinear-seq -2 2 20 trans1))
|
||||
(define ys (nonlinear-seq -2 2 20 trans2))
|
||||
(plot (points (map vector xs ys))))))
|
||||
|
||||
(let ()
|
||||
(define trans1 (stretch-transform -1/2 1/2 4))
|
||||
(define trans2 (stretch-transform -1/2 1/2 1/4))
|
||||
(values
|
||||
(parameterize ([plot-x-transform trans1]
|
||||
[plot-y-transform trans2])
|
||||
(plot (list (y-axis -1/2) (y-axis 1/2)
|
||||
(x-axis -1/2) (x-axis 1/2)
|
||||
(function values -2 2)
|
||||
(function cos -2 2 #:color 3))))
|
||||
(parameterize ([plot-x-transform trans1]
|
||||
[plot-y-transform trans2])
|
||||
(define xs (nonlinear-seq -2 2 20 trans1))
|
||||
(define ys (nonlinear-seq -2 2 20 trans2))
|
||||
(plot (points (map vector xs ys))))))
|
||||
|
||||
(let ()
|
||||
(define trans1 (axis-transform-compose id-transform (stretch-transform -1 1 1/4)))
|
||||
(define trans2 (axis-transform-compose (stretch-transform -1 1 1/4) id-transform))
|
||||
(values
|
||||
(parameterize ([plot-x-transform trans1])
|
||||
(plot (list (y-axis -1) (y-axis 1)
|
||||
(function values -2 2)
|
||||
(function cos -2 2 #:color 3))))
|
||||
(parameterize ([plot-x-transform trans2])
|
||||
(plot (list (y-axis -1) (y-axis 1)
|
||||
(function values -2 2)
|
||||
(function cos -2 2 #:color 3))))
|
||||
(parameterize ([plot-x-transform trans1]
|
||||
[plot-y-transform trans2])
|
||||
(define xs (nonlinear-seq -2 2 20 trans1))
|
||||
(define ys (nonlinear-seq -2 2 20 trans2))
|
||||
(plot (points (map vector xs ys))))))
|
||||
|
||||
(let ()
|
||||
(define t1 (stretch-transform -2 -1 4))
|
||||
(define t2 (stretch-transform 1 2 4))
|
||||
(values
|
||||
(parameterize ([plot-x-transform (axis-transform-compose t1 t2)])
|
||||
(plot (list (y-axis -2) (y-axis -1 #t)
|
||||
(y-axis 1 #t) (y-axis 2)
|
||||
(function values -3 3)
|
||||
(function cos -3 3 #:color 3))))
|
||||
(parameterize ([plot-x-transform (axis-transform-compose t2 t1)])
|
||||
(plot (list (y-axis -2) (y-axis -1 #t)
|
||||
(y-axis 1 #t) (y-axis 2)
|
||||
(function values -3 3)
|
||||
(function cos -3 3 #:color 3))))
|
||||
(parameterize ([plot-x-transform (axis-transform-compose t2 t1)]
|
||||
[plot-y-transform (axis-transform-compose t1 t2)])
|
||||
(define xs (nonlinear-seq -3 3 20 (axis-transform-compose t2 t1)))
|
||||
(define ys (nonlinear-seq -3 3 20 (axis-transform-compose t1 t2)))
|
||||
(plot (points (map vector xs ys))))))
|
||||
|
||||
(let ()
|
||||
(define t1 (stretch-transform -2 0 4))
|
||||
(define t2 (stretch-transform -1 1 1/4))
|
||||
(define t3 (stretch-transform 2 3 4))
|
||||
(define trans1 (axis-transform-compose (axis-transform-compose t3 t2) t1))
|
||||
(define trans2 (axis-transform-compose (axis-transform-compose t2 t1) t3))
|
||||
(values
|
||||
(parameterize ([plot-x-transform trans1])
|
||||
(plot (list (y-axis -2) (y-axis 0)
|
||||
(y-axis -1) (y-axis 1)
|
||||
(y-axis 2) (y-axis 3)
|
||||
(function values -3 4)
|
||||
(function cos -3 4 #:color 3))))
|
||||
(parameterize ([plot-x-transform trans2])
|
||||
(plot (list (y-axis -2) (y-axis 0)
|
||||
(y-axis -1) (y-axis 1)
|
||||
(y-axis 2) (y-axis 3)
|
||||
(function values -3 4)
|
||||
(function cos -3 4 #:color 3))))
|
||||
(parameterize ([plot-x-transform trans1]
|
||||
[plot-y-transform trans2])
|
||||
(define xs (nonlinear-seq -3 4 20 trans1))
|
||||
(define ys (nonlinear-seq -3 4 20 trans2))
|
||||
(plot (points (map vector xs ys))))))
|
||||
|
||||
(let ()
|
||||
(define trans1 (axis-transform-compose (stretch-transform 2 3 4) log-transform))
|
||||
(define trans2 (axis-transform-compose log-transform (stretch-transform 2 3 4)))
|
||||
(values
|
||||
(parameterize ([plot-x-transform trans1])
|
||||
(plot (list (y-axis 2) (y-axis 3)
|
||||
(function values 1 5)
|
||||
(function cos 1 5 #:color 3))))
|
||||
(parameterize ([plot-x-transform trans2])
|
||||
(plot (list (y-axis 2) (y-axis 3)
|
||||
(function values 1 5)
|
||||
(function cos 1 5 #:color 3))))
|
||||
(parameterize ([plot-x-transform trans1]
|
||||
[plot-y-transform trans2])
|
||||
(define xs (nonlinear-seq 1 5 20 trans1))
|
||||
(define ys (nonlinear-seq 1 5 20 trans2))
|
||||
(plot (points (map vector xs ys))))))
|
||||
|
||||
(let ()
|
||||
(define trans (collapse-transform -1 1))
|
||||
(values
|
||||
(parameterize ([plot-x-transform trans])
|
||||
(plot (list (y-axis 1)
|
||||
(function values -2 2)
|
||||
(function cos -2 2 #:color 3))))
|
||||
(parameterize ([plot-x-transform trans]
|
||||
[plot-y-transform trans])
|
||||
(define xs (nonlinear-seq -2 2 20 trans))
|
||||
(plot (points (map vector xs xs))))))
|
||||
|
||||
(let ()
|
||||
(define trans1 (axis-transform-compose (collapse-transform 2 3) log-transform))
|
||||
(define trans2 (axis-transform-compose log-transform (collapse-transform 2 3)))
|
||||
(values
|
||||
(parameterize ([plot-x-transform trans1])
|
||||
(plot (list (y-axis 3)
|
||||
(function values 1 5)
|
||||
(function cos 1 5 #:color 3))))
|
||||
(parameterize ([plot-x-transform trans2])
|
||||
(plot (list (y-axis 3)
|
||||
(function values 1 5)
|
||||
(function cos 1 5 #:color 3))))
|
||||
(parameterize ([plot-x-transform trans1]
|
||||
[plot-y-transform trans2])
|
||||
(define xs (nonlinear-seq 1 5 20 trans1))
|
||||
(define ys (nonlinear-seq 1 5 20 trans2))
|
||||
(plot (points (map vector xs ys))))))
|
||||
|
||||
(let ()
|
||||
(define trans1 (axis-transform-compose (stretch-transform -1 1 4)
|
||||
(collapse-transform -1/2 1/2)))
|
||||
(define trans2 (axis-transform-compose (collapse-transform -1/2 1/2)
|
||||
(stretch-transform -1 1 4)))
|
||||
(values
|
||||
(parameterize ([plot-x-transform trans1])
|
||||
(plot (list (y-axis -1) (y-axis 1)
|
||||
(y-axis -1/2) (y-axis 1/2)
|
||||
(function values -2 2)
|
||||
(function cos -2 2 #:color 3))))
|
||||
(parameterize ([plot-x-transform trans2])
|
||||
(plot (list (y-axis -1) (y-axis 1)
|
||||
(y-axis -1/2) (y-axis 1/2)
|
||||
(function values -2 2)
|
||||
(function cos -2 2 #:color 3))))
|
||||
(parameterize ([plot-x-transform trans1]
|
||||
[plot-y-transform trans2])
|
||||
(define xs (nonlinear-seq -2 2 20 trans1))
|
||||
(define ys (nonlinear-seq -2 2 20 trans2))
|
||||
(plot (points (map vector xs ys))))))
|
||||
|
||||
(let ()
|
||||
(define trans1 (axis-transform-compose (collapse-transform -1 1) (collapse-transform -1/2 1/2)))
|
||||
(define trans2 (axis-transform-compose (collapse-transform -1/2 1/2) (collapse-transform -1 1)))
|
||||
(values
|
||||
(parameterize ([plot-x-transform trans1])
|
||||
(plot (list (y-axis 1) (y-axis 1/2)
|
||||
(function values -2 2)
|
||||
(function cos -2 2 #:color 3))))
|
||||
(parameterize ([plot-x-transform trans2])
|
||||
(plot (list (y-axis 1) (y-axis 1/2)
|
||||
(function values -2 2)
|
||||
(function cos -2 2 #:color 3))))
|
||||
(parameterize ([plot-x-transform trans1]
|
||||
[plot-y-transform trans2])
|
||||
(define xs (nonlinear-seq -2 2 20 trans1))
|
||||
(define ys (nonlinear-seq -2 2 20 trans2))
|
||||
(plot (points (map vector xs ys))))))
|
||||
|
||||
(parameterize ([plot-x-transform (collapse-transform -1 1)])
|
||||
(plot (function values 0 2)))
|
||||
|
||||
(parameterize ([plot-x-transform (collapse-transform -1 1)])
|
||||
(plot (function values -2 0)))
|
||||
|
||||
(parameterize ([plot-x-transform (axis-transform-append id-transform log-transform 0.1)])
|
||||
(plot (function sin -4 4)))
|
||||
|
||||
(let ()
|
||||
(define trans (axis-transform-append id-transform log-transform 2))
|
||||
(define ticks (log-ticks #:base 10))
|
||||
(values
|
||||
(parameterize ([plot-x-transform trans]
|
||||
[plot-x-ticks ticks])
|
||||
(plot (list (function values 1 15)
|
||||
(function cos 1 15 #:color 3))))
|
||||
(parameterize ([plot-x-transform trans]
|
||||
[plot-y-transform trans])
|
||||
(define xs (nonlinear-seq 1 15 20 trans))
|
||||
(plot (points (map vector xs xs))))))
|
||||
|
||||
(let ()
|
||||
(define t1 (stretch-transform 2 3 4))
|
||||
(define t2 (stretch-transform 7 8 4))
|
||||
(define trans1 (axis-transform-compose (axis-transform-append t1 t2 5) log-transform))
|
||||
(define trans2 (axis-transform-compose log-transform (axis-transform-append t1 t2 5)))
|
||||
(values
|
||||
(parameterize ([plot-x-transform trans1])
|
||||
(plot (list (for/list ([x (in-list '(2 3 7 8))]) (y-axis x))
|
||||
(function values 1 9))))
|
||||
(parameterize ([plot-x-transform trans2])
|
||||
(plot (list (for/list ([x (in-list '(2 3 7 8))]) (y-axis x))
|
||||
(function values 1 9))))
|
||||
(parameterize ([plot-x-transform trans1]
|
||||
[plot-y-transform trans2])
|
||||
(define xs (nonlinear-seq 1 9 50 trans1))
|
||||
(define ys (nonlinear-seq 1 9 50 trans2))
|
||||
(plot (points (map vector xs ys))))))
|
||||
|
||||
(let ()
|
||||
(define trans1 (axis-transform-append log-transform id-transform 5))
|
||||
(define trans2 (axis-transform-append id-transform log-transform 5))
|
||||
(values
|
||||
(parameterize ([plot-x-transform trans1])
|
||||
(plot (list (y-axis 5)
|
||||
(function values 6 10)
|
||||
(function cos 6 10 #:color 3))))
|
||||
(parameterize ([plot-x-transform trans2])
|
||||
(plot (list (y-axis 5)
|
||||
(function values 6 10)
|
||||
(function cos 6 10 #:color 3))))
|
||||
(parameterize ([plot-x-transform trans1]
|
||||
[plot-y-transform trans2])
|
||||
(define xs (nonlinear-seq 6 10 20 trans1))
|
||||
(define ys (nonlinear-seq 6 10 20 trans2))
|
||||
(plot (points (map vector xs ys))))
|
||||
(parameterize ([plot-x-transform trans1])
|
||||
(plot (list (y-axis 5)
|
||||
(function values 1 4)
|
||||
(function cos 1 4 #:color 3))))
|
||||
(parameterize ([plot-x-transform trans2])
|
||||
(plot (list (y-axis 5)
|
||||
(function values 1 4)
|
||||
(function cos 1 4 #:color 3))))
|
||||
(parameterize ([plot-x-transform trans1]
|
||||
[plot-y-transform trans2])
|
||||
(define xs (nonlinear-seq 1 4 20 trans1))
|
||||
(define ys (nonlinear-seq 1 4 20 trans2))
|
||||
(plot (points (map vector xs ys))))))
|
||||
|
||||
(parameterize ([plot-x-transform (axis-transform-compose (collapse-transform 2 6)
|
||||
log-transform)]
|
||||
[plot-x-ticks (log-ticks)])
|
||||
(plot (list (y-axis 2 #t) (y-axis 6 #t)
|
||||
(function values 1 10))))
|
||||
|
||||
(let ()
|
||||
(define trans1 (axis-transform-bound log-transform 0.1 5))
|
||||
(define trans2 (axis-transform-bound (stretch-transform 1 2 4) 1 2))
|
||||
(values
|
||||
(parameterize ([plot-x-transform trans1])
|
||||
(plot (list (y-axis 0.1) (y-axis 5)
|
||||
(function values -3 9))))
|
||||
(parameterize ([plot-x-transform trans2])
|
||||
(plot (list (y-axis 1) (y-axis 2)
|
||||
(function values 0 3))))
|
||||
(parameterize ([plot-x-transform trans1]
|
||||
[plot-y-transform trans2])
|
||||
(define xs (nonlinear-seq -3 9 20 trans1))
|
||||
(define ys (nonlinear-seq 0 3 20 trans2))
|
||||
(plot (points (map vector xs ys))))))
|
||||
|
|
@ -10,10 +10,17 @@
|
|||
|
||||
(plot empty #:x-min -1 #:x-max 1 #:y-min -1 #:y-max 1)
|
||||
|
||||
(plot (list (axes 1 2) (function values -4 4)))
|
||||
(plot (list (function values -4 4) (axes 1 2 #t #t)))
|
||||
|
||||
(time (plot (function values 0 1000)))
|
||||
|
||||
(parameterize ([plot-x-ticks (log-ticks #:base 4)]
|
||||
[plot-x-transform log-transform]
|
||||
[plot-y-max-ticks 10]
|
||||
[plot-y-ticks (linear-ticks)]
|
||||
[plot-y-transform log-transform])
|
||||
(plot (function values 1 243)))
|
||||
|
||||
(parameterize ([plot-background "black"]
|
||||
[plot-foreground "white"]
|
||||
[plot-background-alpha 1/2]
|
||||
|
|
@ -403,3 +410,14 @@
|
|||
13 (λ (n) (function (make-fun n) 0 2
|
||||
#: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)))
|
||||
|
|
|
|||
82
collects/plot/tests/tick-tests.rkt
Normal file
82
collects/plot/tests/tick-tests.rkt
Normal file
|
|
@ -0,0 +1,82 @@
|
|||
#lang racket
|
||||
|
||||
(require plot (only-in plot/common/math floor-log/base real-modulo))
|
||||
|
||||
(plot-font-family 'swiss)
|
||||
|
||||
(plot (function (λ (x) (count pre-tick-major? ((linear-ticks) 0 x 8 id-transform)))
|
||||
0.1 10))
|
||||
|
||||
(plot (function (λ (x) (count pre-tick-major? ((linear-ticks) 0 x 40 id-transform)))
|
||||
1 100))
|
||||
|
||||
(parameterize ([plot-x-ticks (linear-ticks #:base 2 #:divisors '(1 2))]
|
||||
#;[plot-y-ticks (linear-ticks #:base (* 1 2 3 4 5) #:divisors '(1 2 3 4 5))])
|
||||
(plot (function cos 0.013 2.1176)))
|
||||
|
||||
(parameterize ([plot-x-transform log-transform]
|
||||
[plot-x-ticks (ticks (log-ticks-layout)
|
||||
(fraction-ticks-format))]
|
||||
[plot-y-ticks (fraction-ticks)])
|
||||
(plot (function (λ (x) (+ 1 (cos x))) 0.0001 12)))
|
||||
|
||||
(parameterize ([plot-x-ticks (date-ticks)]
|
||||
[plot-x-max-ticks 3]
|
||||
[plot-y-ticks (currency-ticks)])
|
||||
(plot (function values -1 1)))
|
||||
|
||||
(parameterize ([plot-x-ticks (date-ticks)]
|
||||
[currency-format-strings uk-currency-format-strings]
|
||||
[currency-scale-suffixes uk-currency-scale-suffixes]
|
||||
[plot-y-ticks (currency-ticks #:kind 'GBP)])
|
||||
(plot (function values 101232512 2321236192)))
|
||||
|
||||
(parameterize ([currency-format-strings eu-currency-format-strings]
|
||||
[currency-scale-suffixes eu-currency-scale-suffixes]
|
||||
[plot-x-ticks (currency-ticks #:kind 'EUR)]
|
||||
[plot-y-ticks (currency-ticks)])
|
||||
(plot (function (λ (x) (* x 1.377)) 8000000 10000000)
|
||||
#:title "EUR-USD Conversion, 2011-10-13"
|
||||
#:x-label "Euros"
|
||||
#:y-label "Dollars"))
|
||||
|
||||
(parameterize ([plot-x-ticks no-ticks])
|
||||
(plot (function sin -1 4)))
|
||||
|
||||
(parameterize ([plot-x-transform log-transform]
|
||||
[plot-y-transform log-transform]
|
||||
[plot-x-ticks (log-ticks #:base 10)]
|
||||
[plot-y-ticks (log-ticks #:base 2)])
|
||||
(plot (function values 0.1 10)))
|
||||
|
||||
(parameterize ([plot-x-transform log-transform]
|
||||
[plot-y-transform (stretch-transform -1 1 4)]
|
||||
[plot-x-ticks (ticks (uniform-ticks-layout)
|
||||
(log-ticks-format #:base 10))]
|
||||
[plot-y-ticks (ticks (uniform-ticks-layout)
|
||||
(currency-ticks-format #:kind 'USD))])
|
||||
(plot (function log 0.1 10)))
|
||||
|
||||
(parameterize ([plot-x-transform log-transform]
|
||||
[plot-x-ticks (log-ticks #:base 10)])
|
||||
(plot (function values 10000000000000 1000000000000000)))
|
||||
|
||||
(plot (polar-axes) #:x-min -1 #:x-max 1 #:y-min -1 #:y-max 1)
|
||||
|
||||
(plot (polar-axes) #:x-min 0 #:x-max 3 #:y-min 0 #:y-max 3)
|
||||
|
||||
(plot (polar-axes) #:x-min 1 #:x-max 4 #:y-min 1 #:y-max 4)
|
||||
|
||||
(plot (polar-axes #:number 12) #:x-min 10 #:x-max 12 #:y-min 10 #:y-max 12)
|
||||
|
||||
(parameterize ([plot-z-transform log-transform]
|
||||
[plot-z-ticks (log-ticks)]
|
||||
[contour-samples (plot3d-samples)])
|
||||
(values
|
||||
(plot (contours (λ (x y) (exp (- (+ (sqr x) (sqr y))))) -2 2 -2 2 #:label "z"))
|
||||
(plot (contour-intervals (λ (x y) (exp (- (+ (sqr x) (sqr y))))) -2 2 -2 2 #:label "z"))
|
||||
(plot3d (contours3d (λ (x y) (exp (- (+ (sqr x) (sqr y))))) -2 2 -2 2 #:label "z"))
|
||||
(plot3d (contour-intervals3d (λ (x y) (exp (- (+ (sqr x) (sqr y))))) -2 2 -2 2 #:label "z"))))
|
||||
|
||||
(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"))
|
||||
|
|
@ -4,7 +4,8 @@ exec gracket "$0" "$@"
|
|||
|#
|
||||
#lang racket
|
||||
|
||||
(require rackunit plot plot/utils)
|
||||
(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))
|
||||
|
|
@ -14,3 +15,60 @@ exec gracket "$0" "$@"
|
|||
(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)
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user