Polar axes use r ticks
Removed r and d transforms (r needs design, d is useless)
This commit is contained in:
Neil Toronto
parent
4ae9ecf28e
commit
596e8b3775
|
|
@ -23,7 +23,7 @@
|
|||
|
||||
(defthing id-function invertible-function? (invertible-function (λ (x) x) (λ (x) x)))
|
||||
|
||||
(defproc (apply-transform [t axis-transform/c] [x-min real?] [x-max real?]) invertible-function?
|
||||
(defproc (apply-axis-transform [t axis-transform/c] [x-min real?] [x-max real?]) invertible-function?
|
||||
(t x-min x-max id-function))
|
||||
|
||||
;; Turns any total, surjective, monotone flonum op and its inverse into an axis transform
|
||||
|
|
|
|||
|
|
@ -43,7 +43,7 @@
|
|||
(defparam plot-x-max-ticks exact-positive-integer? 5)
|
||||
(defparam plot-y-max-ticks exact-positive-integer? 5)
|
||||
(defparam plot-z-max-ticks exact-positive-integer? 8)
|
||||
(defparam plot-d-max-ticks exact-positive-integer? 5)
|
||||
(defparam plot-d-max-ticks exact-positive-integer? 6)
|
||||
(defparam plot-r-max-ticks exact-positive-integer? 8)
|
||||
|
||||
(defparam plot-x-far-max-ticks exact-positive-integer? 5)
|
||||
|
|
@ -131,32 +131,23 @@
|
|||
(defparam plot-x-transform axis-transform/c id-transform)
|
||||
(defparam plot-y-transform axis-transform/c id-transform)
|
||||
(defparam plot-z-transform axis-transform/c id-transform)
|
||||
(defparam plot-d-transform axis-transform/c id-transform)
|
||||
(defparam plot-r-transform axis-transform/c id-transform)
|
||||
|
||||
(defparam plot-x-ticks ticks? (linear-ticks))
|
||||
(defparam plot-y-ticks ticks? (linear-ticks))
|
||||
(defparam plot-z-ticks ticks? (linear-ticks))
|
||||
(defparam plot-d-ticks ticks? (linear-ticks))
|
||||
(defparam plot-d-ticks ticks? (linear-ticks #:divisors '(1 2 4 5)))
|
||||
(defparam plot-r-ticks ticks? (linear-ticks))
|
||||
|
||||
(defparam plot-x-far-ticks ticks? (ticks-mimic plot-x-ticks))
|
||||
(defparam plot-y-far-ticks ticks? (ticks-mimic plot-y-ticks))
|
||||
(defparam plot-z-far-ticks ticks? (ticks-mimic plot-z-ticks))
|
||||
|
||||
(struct axis (transform ticks) #:transparent)
|
||||
(define-parameter-group plot-d-axis (plot-d-transform plot-d-ticks) #:struct axis)
|
||||
(define-parameter-group plot-r-axis (plot-r-transform plot-r-ticks) #:struct axis)
|
||||
(struct axis (transform ticks far-ticks) #:transparent)
|
||||
(define-parameter-group plot-x-axis (plot-x-transform plot-x-ticks plot-x-far-ticks) #:struct axis)
|
||||
(define-parameter-group plot-y-axis (plot-y-transform plot-y-ticks plot-y-far-ticks) #:struct axis)
|
||||
(define-parameter-group plot-z-axis (plot-z-transform plot-z-ticks plot-z-far-ticks) #:struct axis)
|
||||
|
||||
(struct dual-axis (transform ticks far-ticks) #:transparent)
|
||||
(define-parameter-group plot-x-axis (plot-x-transform plot-x-ticks plot-x-far-ticks)
|
||||
#:struct dual-axis)
|
||||
(define-parameter-group plot-y-axis (plot-y-transform plot-y-ticks plot-y-far-ticks)
|
||||
#:struct dual-axis)
|
||||
(define-parameter-group plot-z-axis (plot-z-transform plot-z-ticks plot-z-far-ticks)
|
||||
#:struct dual-axis)
|
||||
|
||||
(define-parameter-group plot-axes (plot-x-axis plot-y-axis plot-z-axis plot-d-axis plot-r-axis)
|
||||
(define-parameter-group plot-axes (plot-x-axis plot-y-axis plot-z-axis plot-d-ticks plot-r-ticks)
|
||||
#:struct list)
|
||||
|
||||
(defproc (default-x-ticks [x-min real?] [x-max real?]) (listof tick?) #:document-body
|
||||
|
|
@ -276,12 +267,10 @@
|
|||
(defparam x-axis-ticks? boolean? #t)
|
||||
(defparam y-axis-ticks? boolean? #t)
|
||||
(defparam z-axis-ticks? boolean? #t)
|
||||
(defparam polar-axes-ticks? boolean? #t)
|
||||
|
||||
(defparam x-axis-labels? boolean? #f)
|
||||
(defparam y-axis-labels? boolean? #f)
|
||||
(defparam z-axis-labels? boolean? #f)
|
||||
(defparam polar-axes-labels? boolean? #t)
|
||||
|
||||
(defparam x-axis-far? boolean? #f)
|
||||
(defparam y-axis-far? boolean? #f)
|
||||
|
|
@ -290,9 +279,11 @@
|
|||
(defparam x-axis-alpha (real-in 0 1) 1)
|
||||
(defparam y-axis-alpha (real-in 0 1) 1)
|
||||
(defparam z-axis-alpha (real-in 0 1) 1)
|
||||
(defparam polar-axes-alpha (real-in 0 1) 1/2)
|
||||
|
||||
(defparam polar-axes-number exact-positive-integer? 12)
|
||||
(defparam polar-axes-number exact-nonnegative-integer? 12)
|
||||
(defparam polar-axes-ticks? boolean? #t)
|
||||
(defparam polar-axes-labels? boolean? #t)
|
||||
(defparam polar-axes-alpha (real-in 0 1) 1/2)
|
||||
|
||||
(defparam label-anchor anchor/c 'left)
|
||||
(defparam label-angle real? 0)
|
||||
|
|
@ -324,7 +315,7 @@
|
|||
(color-seq* (list (->pen-color 5) (->pen-color 0) (->pen-color 1))
|
||||
(length zs)))
|
||||
|
||||
(defparam isosurface-levels exact-positive-integer? 3)
|
||||
(defparam isosurface-levels (or/c 'auto exact-positive-integer? (listof real?)) 'auto)
|
||||
(defparam isosurface-colors plot-colors/c default-isosurface-colors)
|
||||
(defparam isosurface-line-colors plot-colors/c default-isosurface-line-colors)
|
||||
(defparam isosurface-line-widths pen-widths/c '(1/3))
|
||||
|
|
|
|||
|
|
@ -38,10 +38,8 @@
|
|||
(match-define (vector xi yi) r)
|
||||
(cond [(ivl-known? xi)
|
||||
(match-define (ivl x-min x-max) xi)
|
||||
(match-define (list xs ys) (f x-min x-max samples))
|
||||
(define rys (filter regular? ys))
|
||||
(cond [(not (empty? rys)) (vector xi (ivl (apply min* rys) (apply max* rys)))]
|
||||
[else r])]
|
||||
(match-define (sample xs ys y-min y-max) (f x-min x-max samples))
|
||||
(vector xi (ivl y-min y-max))]
|
||||
[else r])))
|
||||
|
||||
(defproc (inverse-bounds-fun [f sampler/c] [samples exact-nonnegative-integer?]) bounds-fun/c
|
||||
|
|
@ -49,10 +47,8 @@
|
|||
(match-define (vector xi yi) r)
|
||||
(cond [(ivl-known? yi)
|
||||
(match-define (ivl y-min y-max) yi)
|
||||
(match-define (list ys xs) (f y-min y-max samples))
|
||||
(define rxs (filter regular? xs))
|
||||
(cond [(not (empty? rxs)) (vector (ivl (apply min* rxs) (apply max* rxs)) yi)]
|
||||
[else r])]
|
||||
(match-define (sample ys xs x-min x-max) (f y-min y-max samples))
|
||||
(vector (ivl x-min x-max) yi)]
|
||||
[else r])))
|
||||
|
||||
(defproc (function-interval-bounds-fun [f1 sampler/c] [f2 sampler/c]
|
||||
|
|
@ -73,10 +69,9 @@
|
|||
(cond [(and (ivl-known? xi) (ivl-known? yi))
|
||||
(match-define (ivl x-min x-max) xi)
|
||||
(match-define (ivl y-min y-max) yi)
|
||||
(match-define (list xs ys zss) (f x-min x-max samples y-min y-max samples))
|
||||
(define zs (filter regular? (2d-sample->list zss)))
|
||||
(cond [(not (empty? zs)) (vector xi yi (ivl (apply min* zs) (apply max* zs)))]
|
||||
[else r])]
|
||||
(match-define (2d-sample xs ys zss z-min z-max)
|
||||
(f x-min x-max samples y-min y-max samples))
|
||||
(vector xi yi (ivl z-min z-max))]
|
||||
[else r])))
|
||||
|
||||
;; ===================================================================================================
|
||||
|
|
|
|||
|
|
@ -53,7 +53,7 @@
|
|||
[transform axis-transform/c]
|
||||
[#:start? start? boolean? #t]
|
||||
[#:end? end? boolean? #t]) (listof real?)
|
||||
(match-define (invertible-function _ finv) (apply-transform transform start end))
|
||||
(match-define (invertible-function _ finv) (apply-axis-transform transform start end))
|
||||
(map finv (linear-seq start end num #:start? start? #:end? end?)))
|
||||
|
||||
(struct mapped-function (f fmap) #:transparent
|
||||
|
|
@ -70,21 +70,21 @@
|
|||
;; ===================================================================================================
|
||||
;; Making memoized samplers
|
||||
|
||||
(defcontract sample/c (list/c (listof real?) (listof real?)))
|
||||
(defcontract sampler/c (real? real? exact-nonnegative-integer? . -> . sample/c))
|
||||
(struct sample (xs ys y-min y-max) #:transparent)
|
||||
(struct 2d-sample (xs ys zss z-min z-max) #:transparent)
|
||||
(struct 3d-sample (xs ys zs dsss d-min d-max) #:transparent)
|
||||
|
||||
(defcontract sample/c (list/c (listof real?) (listof real?)))
|
||||
(defcontract sampler/c (real? real? exact-nonnegative-integer? . -> . sample?))
|
||||
|
||||
(defcontract 2d-sample/c (list/c (listof real?) (listof real?)
|
||||
(vectorof (vectorof real?))))
|
||||
(defcontract 2d-sampler/c (real? real? exact-nonnegative-integer?
|
||||
real? real? exact-nonnegative-integer?
|
||||
. -> . 2d-sample/c))
|
||||
. -> . 2d-sample?))
|
||||
|
||||
(defcontract 3d-sample/c (list/c (listof real?) (listof real?) (listof real?)
|
||||
(vectorof (vectorof (vectorof real?)))))
|
||||
(defcontract 3d-sampler/c (real? real? exact-nonnegative-integer?
|
||||
real? real? exact-nonnegative-integer?
|
||||
real? real? exact-nonnegative-integer?
|
||||
. -> . 3d-sample/c))
|
||||
. -> . 3d-sample?))
|
||||
|
||||
(defproc (make-function->sampler [transform-thnk (-> axis-transform/c)]
|
||||
) ((real? . -> . real?) . -> . sampler/c)
|
||||
|
|
@ -95,7 +95,12 @@
|
|||
(hash-ref! memo (vector x-min x-max x-samples tx)
|
||||
(λ ()
|
||||
(define xs (nonlinear-seq x-min x-max x-samples tx))
|
||||
(list xs (map* f xs)))))))
|
||||
(define ys (map* f xs))
|
||||
(define rys (filter regular? ys))
|
||||
(define-values (y-min y-max)
|
||||
(cond [(empty? rys) (values #f #f)]
|
||||
[else (values (apply min* rys) (apply max* rys))]))
|
||||
(sample xs ys y-min y-max))))))
|
||||
|
||||
(defproc (make-2d-function->sampler [transform-x-thnk (-> axis-transform/c)]
|
||||
[transform-y-thnk (-> axis-transform/c)]
|
||||
|
|
@ -109,9 +114,16 @@
|
|||
(λ ()
|
||||
(define xs (nonlinear-seq x-min x-max x-samples tx))
|
||||
(define ys (nonlinear-seq y-min y-max y-samples ty))
|
||||
(list xs ys (for/vector #:length y-samples ([y (in-list ys)])
|
||||
(define z-min #f)
|
||||
(define z-max #f)
|
||||
(define zss (for/vector #:length y-samples ([y (in-list ys)])
|
||||
(for/vector #:length x-samples ([x (in-list xs)])
|
||||
(f x y)))))))))
|
||||
(let ([z (f x y)])
|
||||
(when (regular? z)
|
||||
(unless (and z-min (z . >= . z-min)) (set! z-min z))
|
||||
(unless (and z-max (z . <= . z-max)) (set! z-max z)))
|
||||
z))))
|
||||
(2d-sample xs ys zss z-min z-max))))))
|
||||
|
||||
(defproc (make-3d-function->sampler [transform-x-thnk (-> axis-transform/c)]
|
||||
[transform-y-thnk (-> axis-transform/c)]
|
||||
|
|
@ -130,18 +142,14 @@
|
|||
(define xs (nonlinear-seq x-min x-max x-samples tx))
|
||||
(define ys (nonlinear-seq y-min y-max y-samples ty))
|
||||
(define zs (nonlinear-seq z-min z-max z-samples tz))
|
||||
(list xs ys zs (for/vector #:length z-samples ([z (in-list zs)])
|
||||
(for/vector #:length y-samples ([y (in-list ys)])
|
||||
(for/vector #:length x-samples ([x (in-list xs)])
|
||||
(f x y z))))))))))
|
||||
|
||||
(defproc (2d-sample->list [zss (vectorof (vectorof real?))]) (listof real?)
|
||||
(for*/list ([zs (in-vector zss)]
|
||||
[z (in-vector zs)])
|
||||
z))
|
||||
|
||||
(defproc (3d-sample->list [dsss (vectorof (vectorof (vectorof real?)))]) (listof real?)
|
||||
(for*/list ([dss (in-vector dsss)]
|
||||
[ds (in-vector dss)]
|
||||
[d (in-vector ds)])
|
||||
d))
|
||||
(define d-min #f)
|
||||
(define d-max #f)
|
||||
(define dsss (for/vector #:length z-samples ([z (in-list zs)])
|
||||
(for/vector #:length y-samples ([y (in-list ys)])
|
||||
(for/vector #:length x-samples ([x (in-list xs)])
|
||||
(let ([d (f x y z)])
|
||||
(when (regular? d)
|
||||
(unless (and d-min (d . >= . d-min)) (set! d-min d))
|
||||
(unless (and d-max (d . <= . d-max)) (set! d-max d)))
|
||||
d)))))
|
||||
(3d-sample xs ys zs dsss d-min d-max))))))
|
||||
|
|
|
|||
|
|
@ -49,3 +49,23 @@
|
|||
(match-define (list (pre-tick zs majors) ...) all-ts)
|
||||
(define labels (format z-min z-max all-ts))
|
||||
(map tick zs majors labels))
|
||||
|
||||
(defproc (isosurface-ticks [d-min real?] [d-max real?]
|
||||
[levels (or/c 'auto exact-positive-integer? (listof real?))]
|
||||
) (listof tick?)
|
||||
(define epsilon (expt 10 (- (digits-for-range d-min d-max))))
|
||||
(match-define (ticks layout format) (plot-d-ticks))
|
||||
(define ts
|
||||
(cond [(eq? levels 'auto) (filter pre-tick-major? (layout d-min d-max (plot-d-max-ticks)))]
|
||||
[else (define ds (cond [(list? levels) (filter (λ (d) (<= d-min d d-max)) levels)]
|
||||
[else (linear-seq d-min d-max levels #:start? #f #:end? #f)]))
|
||||
(map (λ (d) (pre-tick d #t)) ds)]))
|
||||
(define all-ts
|
||||
(let* ([ts (cond [((abs (- d-min (pre-tick-value (first ts)))) . >= . epsilon) ts]
|
||||
[else (rest ts)])]
|
||||
[ts (cond [((abs (- d-max (pre-tick-value (last ts)))) . >= . epsilon) ts]
|
||||
[else (take ts (- (length ts) 1))])])
|
||||
ts))
|
||||
(match-define (list (pre-tick ds majors) ...) all-ts)
|
||||
(define labels (format d-min d-max all-ts))
|
||||
(map tick ds majors labels))
|
||||
|
|
|
|||
|
|
@ -8,7 +8,7 @@
|
|||
(activate-contract-out id-function
|
||||
axis-transform/c
|
||||
id-transform
|
||||
apply-transform
|
||||
apply-axis-transform
|
||||
make-axis-transform
|
||||
axis-transform-compose
|
||||
axis-transform-append
|
||||
|
|
|
|||
|
|
@ -29,8 +29,7 @@
|
|||
plot-x-transform plot-x-ticks plot-x-far-ticks
|
||||
plot-y-transform plot-y-ticks plot-y-far-ticks
|
||||
plot-z-transform plot-z-ticks plot-z-far-ticks
|
||||
plot-d-transform plot-d-ticks
|
||||
plot-r-transform plot-r-ticks
|
||||
plot-d-ticks plot-r-ticks
|
||||
;; Renderer parameters
|
||||
line-samples line-color line-width line-style line-alpha
|
||||
interval-color interval-style
|
||||
|
|
|
|||
|
|
@ -3,14 +3,26 @@
|
|||
(require racket/contract unstable/latent-contract)
|
||||
|
||||
(require "../common/sample.rkt")
|
||||
(provide (activate-contract-out build-linear-seq linear-seq linear-seq* nonlinear-seq
|
||||
sample/c sampler/c
|
||||
2d-sample/c 2d-sampler/c
|
||||
3d-sample/c 3d-sampler/c
|
||||
(provide (contract-out (struct sample ([xs (listof real?)]
|
||||
[ys (listof real?)]
|
||||
[y-min (or/c real? #f)]
|
||||
[y-max (or/c real? #f)]))
|
||||
(struct 2d-sample ([xs (listof real?)]
|
||||
[ys (listof real?)]
|
||||
[zss (vectorof (vectorof real?))]
|
||||
[z-min (or/c real? #f)]
|
||||
[z-max (or/c real? #f)]))
|
||||
(struct 3d-sample ([xs (listof real?)]
|
||||
[ys (listof real?)]
|
||||
[zs (listof real?)]
|
||||
[dsss (vectorof (vectorof (vectorof real?)))]
|
||||
[d-min (or/c real? #f)]
|
||||
[d-max (or/c real? #f)])))
|
||||
(activate-contract-out build-linear-seq linear-seq linear-seq* nonlinear-seq
|
||||
sampler/c 2d-sampler/c 3d-sampler/c
|
||||
make-function->sampler
|
||||
make-2d-function->sampler
|
||||
make-3d-function->sampler
|
||||
2d-sample->list 3d-sample->list)
|
||||
make-3d-function->sampler)
|
||||
(contract-out (struct mapped-function ([f (any/c . -> . any/c)]
|
||||
[fmap ((listof any/c) . -> . (listof any/c))])))
|
||||
map*)
|
||||
|
|
|
|||
|
|
@ -3,8 +3,9 @@
|
|||
(require unstable/latent-contract)
|
||||
|
||||
(require "../common/samplers.rkt")
|
||||
(provide (activate-contract-out contour-ticks
|
||||
function->sampler
|
||||
(provide (activate-contract-out function->sampler
|
||||
inverse->sampler
|
||||
2d-function->sampler
|
||||
3d-function->sampler))
|
||||
3d-function->sampler
|
||||
contour-ticks
|
||||
isosurface-ticks))
|
||||
|
|
|
|||
|
|
@ -90,8 +90,8 @@
|
|||
(and (equal? (plot-x-transform) id-transform)
|
||||
(equal? (plot-y-transform) id-transform)))
|
||||
|
||||
(match-define (invertible-function fx _) (apply-transform (plot-x-transform) x-min x-max))
|
||||
(match-define (invertible-function fy _) (apply-transform (plot-y-transform) y-min y-max))
|
||||
(match-define (invertible-function fx _) (apply-axis-transform (plot-x-transform) x-min x-max))
|
||||
(match-define (invertible-function fy _) (apply-axis-transform (plot-y-transform) y-min y-max))
|
||||
|
||||
(define plot->view
|
||||
(cond [identity-transforms? (λ (v) v)]
|
||||
|
|
|
|||
|
|
@ -13,12 +13,10 @@
|
|||
;; ===================================================================================================
|
||||
;; One contour line
|
||||
|
||||
(define ((isoline-render-proc f z samples color width style alpha label) area)
|
||||
(define ((isoline-render-proc g z samples color width style alpha label) area)
|
||||
(define-values (x-min x-max y-min y-max) (send area get-bounds))
|
||||
(match-define (list xs ys zss) (f x-min x-max samples y-min y-max samples))
|
||||
(define zs (2d-sample->list zss))
|
||||
(define z-min (apply min* zs))
|
||||
(define z-max (apply max* zs))
|
||||
(match-define (2d-sample xs ys zss z-min z-max)
|
||||
(g x-min x-max samples y-min y-max samples))
|
||||
|
||||
(when (<= z-min z z-max)
|
||||
(send area set-alpha alpha)
|
||||
|
|
@ -61,12 +59,8 @@
|
|||
(define ((contours-render-proc g levels samples colors widths styles alphas label) area)
|
||||
(let/ec return
|
||||
(define-values (x-min x-max y-min y-max) (send area get-bounds))
|
||||
(match-define (list xs ys zss) (g x-min x-max samples y-min y-max samples))
|
||||
|
||||
(define-values (z-min z-max)
|
||||
(let ([zs (filter regular? (2d-sample->list zss))])
|
||||
(when (empty? zs) (return empty))
|
||||
(values (apply min* zs) (apply max* zs))))
|
||||
(match-define (2d-sample xs ys zss z-min z-max)
|
||||
(g x-min x-max samples y-min y-max samples))
|
||||
|
||||
(match-define (list (tick zs _ labels) ...) (contour-ticks z-min z-max levels #f))
|
||||
|
||||
|
|
@ -120,16 +114,12 @@
|
|||
;; Contour intervals
|
||||
|
||||
(define ((contour-intervals-render-proc
|
||||
f levels samples colors styles contour-colors contour-widths contour-styles alphas label)
|
||||
g levels samples colors styles contour-colors contour-widths contour-styles alphas label)
|
||||
area)
|
||||
(let/ec return
|
||||
(define-values (x-min x-max y-min y-max) (send area get-bounds))
|
||||
(match-define (list xs ys zss) (f x-min x-max samples y-min y-max samples))
|
||||
|
||||
(define-values (z-min z-max)
|
||||
(let ([flat-zs (filter regular? (2d-sample->list zss))])
|
||||
(when (empty? flat-zs) (return empty))
|
||||
(values (apply min* flat-zs) (apply max* flat-zs))))
|
||||
(match-define (2d-sample xs ys zss z-min z-max)
|
||||
(g x-min x-max samples y-min y-max samples))
|
||||
|
||||
(match-define (list (tick zs _ labels) ...) (contour-ticks z-min z-max levels #t))
|
||||
|
||||
|
|
@ -181,7 +171,7 @@
|
|||
(send area set-alpha alpha)
|
||||
(draw-polys)]))
|
||||
|
||||
((contours-render-proc f levels samples contour-colors contour-widths contour-styles alphas #f)
|
||||
((contours-render-proc g levels samples contour-colors contour-widths contour-styles alphas #f)
|
||||
area)
|
||||
|
||||
(cond [label (contour-intervals-legend-entries
|
||||
|
|
|
|||
|
|
@ -23,7 +23,7 @@
|
|||
(define radius (if ticks? (* 1/2 (plot-tick-size)) 0))
|
||||
|
||||
(send area set-alpha alpha)
|
||||
(send area set-minor-pen)
|
||||
(send area set-major-pen)
|
||||
(send area put-line (vector x-min y) (vector x-max y))
|
||||
|
||||
(when ticks?
|
||||
|
|
@ -56,7 +56,7 @@
|
|||
(define radius (if ticks? (* 1/2 (plot-tick-size)) 0))
|
||||
|
||||
(send area set-alpha alpha)
|
||||
(send area set-minor-pen)
|
||||
(send area set-major-pen)
|
||||
(send area put-line (vector x y-min) (vector x y-max))
|
||||
|
||||
(when ticks?
|
||||
|
|
@ -125,7 +125,7 @@
|
|||
;; Draw the tick lines
|
||||
(for ([t (in-list ts)])
|
||||
(match-define (tick r major? label) t)
|
||||
(if major? (send area set-major-pen) (send area set-minor-pen 'long-dash))
|
||||
(if major? (send area set-minor-pen) (send area set-minor-pen 'long-dash))
|
||||
(define pts (for/list ([θ (in-list (linear-seq 0 (* 2 pi) 500))])
|
||||
(vector (* r (cos θ)) (* r (sin θ)))))
|
||||
(send area put-lines pts))
|
||||
|
|
@ -143,22 +143,23 @@
|
|||
(send area put-text label (vector (* r (cos mθ)) (* r (sin mθ)))
|
||||
'center 0 #:outline? #t)))))
|
||||
|
||||
(define ((polar-axes-render-proc num ticks? labels? alpha) area)
|
||||
(define (draw-polar-axis-lines num area)
|
||||
(define-values (x-min x-max y-min y-max) (send area get-bounds))
|
||||
(define-values (θs r-mins r-maxs) (build-polar-axes num x-min x-max y-min y-max))
|
||||
;; Draw the axes
|
||||
(send area set-alpha alpha)
|
||||
|
||||
(send area set-major-pen)
|
||||
(for ([θ (in-list θs)] [r-min (in-list r-mins)] [r-max (in-list r-maxs)])
|
||||
(send area put-line
|
||||
(vector (* r-min (cos θ)) (* r-min (sin θ)))
|
||||
(vector (* r-max (cos θ)) (* r-max (sin θ)))))
|
||||
;; Draw the ticks
|
||||
(when ticks? (draw-polar-axis-ticks num labels? area))
|
||||
;; No legend
|
||||
(vector (* r-max (cos θ)) (* r-max (sin θ))))))
|
||||
|
||||
(define ((polar-axes-render-proc num ticks? labels? alpha) area)
|
||||
(send area set-alpha alpha)
|
||||
(when (num . > . 0) (draw-polar-axis-lines num area))
|
||||
(when ticks? (draw-polar-axis-ticks (if (num . > . 0) num 12) labels? area))
|
||||
empty)
|
||||
|
||||
(defproc (polar-axes [#:number num exact-positive-integer? (polar-axes-number)]
|
||||
(defproc (polar-axes [#:number num exact-nonnegative-integer? (polar-axes-number)]
|
||||
[#:ticks? ticks? boolean? (polar-axes-ticks?)]
|
||||
[#:labels? labels? boolean? (polar-axes-labels?)]
|
||||
[#:alpha alpha (real-in 0 1) (polar-axes-alpha)]) renderer2d?
|
||||
|
|
@ -175,7 +176,7 @@
|
|||
(send area set-alpha 1/2)
|
||||
(for ([t (in-list x-ticks)])
|
||||
(match-define (tick x major? _) t)
|
||||
(if major? (send area set-major-pen) (send area set-minor-pen 'long-dash))
|
||||
(if major? (send area set-minor-pen) (send area set-minor-pen 'long-dash))
|
||||
(send area put-line (vector x y-min) (vector x y-max)))
|
||||
|
||||
empty)
|
||||
|
|
@ -188,7 +189,7 @@
|
|||
(send area set-alpha 1/2)
|
||||
(for ([t (in-list y-ticks)])
|
||||
(match-define (tick y major? _) t)
|
||||
(if major? (send area set-major-pen) (send area set-minor-pen 'long-dash))
|
||||
(if major? (send area set-minor-pen) (send area set-minor-pen 'long-dash))
|
||||
(send area put-line (vector x-min y) (vector x-max y)))
|
||||
|
||||
empty)
|
||||
|
|
|
|||
|
|
@ -78,7 +78,7 @@
|
|||
(define ((function-render-proc f samples color width style alpha label) area)
|
||||
(define x-min (send area get-x-min))
|
||||
(define x-max (send area get-x-max))
|
||||
(match-define (list xs ys) (f x-min x-max samples))
|
||||
(match-define (sample xs ys y-min y-max) (f x-min x-max samples))
|
||||
|
||||
(send area set-alpha alpha)
|
||||
(send area set-pen color width style)
|
||||
|
|
@ -109,7 +109,7 @@
|
|||
(define ((inverse-render-proc f samples color width style alpha label) area)
|
||||
(define y-min (send area get-y-min))
|
||||
(define y-max (send area get-y-max))
|
||||
(match-define (list ys xs) (f y-min y-max samples))
|
||||
(match-define (list ys xs x-min x-max) (f y-min y-max samples))
|
||||
|
||||
(send area set-alpha alpha)
|
||||
(send area set-pen color width style)
|
||||
|
|
|
|||
|
|
@ -103,9 +103,9 @@
|
|||
(equal? (plot-y-transform) id-transform)
|
||||
(equal? (plot-z-transform) id-transform)))
|
||||
|
||||
(match-define (invertible-function fx _) (apply-transform (plot-x-transform) x-min x-max))
|
||||
(match-define (invertible-function fy _) (apply-transform (plot-y-transform) y-min y-max))
|
||||
(match-define (invertible-function fz _) (apply-transform (plot-z-transform) z-min z-max))
|
||||
(match-define (invertible-function fx _) (apply-axis-transform (plot-x-transform) x-min x-max))
|
||||
(match-define (invertible-function fy _) (apply-axis-transform (plot-y-transform) y-min y-max))
|
||||
(match-define (invertible-function fz _) (apply-axis-transform (plot-z-transform) z-min z-max))
|
||||
|
||||
(define axis-transform
|
||||
(cond
|
||||
|
|
|
|||
|
|
@ -14,8 +14,8 @@
|
|||
|
||||
(define ((contour3d-render-proc f z samples color width style alpha label) area)
|
||||
(define-values (x-min x-max y-min y-max z-min z-max) (send area get-bounds))
|
||||
(match-define (list xs ys zss) (f x-min x-max (animated-samples samples)
|
||||
y-min y-max (animated-samples samples)))
|
||||
(match-define (2d-sample xs ys zss _z-min _z-max)
|
||||
(f x-min x-max (animated-samples samples) y-min y-max (animated-samples samples)))
|
||||
|
||||
(when (<= z-min z z-max)
|
||||
(send area put-alpha alpha)
|
||||
|
|
@ -64,8 +64,8 @@
|
|||
|
||||
(define ((contours3d-render-proc f levels samples colors widths styles alphas label) area)
|
||||
(define-values (x-min x-max y-min y-max z-min z-max) (send area get-bounds))
|
||||
(match-define (list xs ys zss) (f x-min x-max (animated-samples samples)
|
||||
y-min y-max (animated-samples samples)))
|
||||
(match-define (2d-sample xs ys zss _z-min _z-max)
|
||||
(f x-min x-max (animated-samples samples) y-min y-max (animated-samples samples)))
|
||||
|
||||
(match-define (list (tick zs _ labels) ...) (contour-ticks z-min z-max levels #f))
|
||||
|
||||
|
|
@ -128,8 +128,8 @@
|
|||
contour-colors contour-widths contour-styles alphas label)
|
||||
area)
|
||||
(define-values (x-min x-max y-min y-max z-min z-max) (send area get-bounds))
|
||||
(match-define (list xs ys zss) (f x-min x-max (animated-samples samples)
|
||||
y-min y-max (animated-samples samples)))
|
||||
(match-define (2d-sample xs ys zss _z-min _z-max)
|
||||
(f x-min x-max (animated-samples samples) y-min y-max (animated-samples samples)))
|
||||
|
||||
(match-define (list (tick zs _ labels) ...) (contour-ticks z-min z-max levels #t))
|
||||
|
||||
|
|
|
|||
|
|
@ -17,7 +17,7 @@
|
|||
(define ((isosurface3d-render-proc f d samples color line-color line-width line-style alpha label)
|
||||
area)
|
||||
(define-values (x-min x-max y-min y-max z-min z-max) (send area get-bounds))
|
||||
(match-define (list xs ys zs dsss)
|
||||
(match-define (3d-sample xs ys zs dsss d-min d-max)
|
||||
(f x-min x-max (animated-samples samples)
|
||||
y-min y-max (animated-samples samples)
|
||||
z-min z-max (animated-samples samples)))
|
||||
|
|
@ -86,23 +86,19 @@
|
|||
f rd-min rd-max levels samples colors line-colors line-widths line-styles alphas label)
|
||||
area)
|
||||
(define-values (x-min x-max y-min y-max z-min z-max) (send area get-bounds))
|
||||
(match-define (list xs ys zs dsss)
|
||||
(match-define (3d-sample xs ys zs dsss fd-min fd-max)
|
||||
(f x-min x-max (animated-samples samples)
|
||||
y-min y-max (animated-samples samples)
|
||||
z-min z-max (animated-samples samples)))
|
||||
|
||||
(define-values (fd-min fd-max)
|
||||
(let ([regular-ds (filter regular? (3d-sample->list dsss))])
|
||||
(values (if (empty? regular-ds) #f (apply min* regular-ds))
|
||||
(if (empty? regular-ds) #f (apply max* regular-ds)))))
|
||||
|
||||
(define d-min (if rd-min rd-min fd-min))
|
||||
(define d-max (if rd-max rd-max fd-max))
|
||||
|
||||
(cond
|
||||
[(not (and d-min d-max)) empty]
|
||||
[else
|
||||
(define ds (linear-seq d-min d-max levels #:start? (and rd-min #t) #:end? (and rd-max #t)))
|
||||
(match-define (list (tick ds _ labels) ...) (isosurface-ticks d-min d-max levels))
|
||||
#;(define ds (linear-seq d-min d-max levels #:start? (and rd-min #t) #:end? (and rd-max #t)))
|
||||
|
||||
(for ([d (in-list ds)]
|
||||
[color (in-cycle (maybe-apply/list colors ds))]
|
||||
|
|
@ -156,7 +152,8 @@
|
|||
[y-min (or/c real? #f) #f] [y-max (or/c real? #f) #f]
|
||||
[z-min (or/c real? #f) #f] [z-max (or/c real? #f) #f]
|
||||
[#:d-min d-min (or/c real? #f) #f] [#:d-max d-max (or/c real? #f) #f]
|
||||
[#:levels levels exact-positive-integer? (isosurface-levels)]
|
||||
[#:levels levels (or/c 'auto exact-positive-integer? (listof real?))
|
||||
(isosurface-levels)]
|
||||
[#:samples samples (and/c exact-integer? (>=/c 2)) (plot3d-samples)]
|
||||
[#:colors colors plot-colors/c (isosurface-colors)]
|
||||
[#:line-colors line-colors plot-colors/c (isosurface-line-colors)]
|
||||
|
|
@ -175,8 +172,8 @@
|
|||
|
||||
(define ((polar3d-render-proc f g samples color line-color line-width line-style alpha label) area)
|
||||
(define-values (x-min x-max y-min y-max z-min z-max) (send area get-bounds))
|
||||
(match-define (list xs ys zs dsss)
|
||||
(g x-min x-max (animated-samples samples)
|
||||
(match-define (3d-sample xs ys zs dsss d-min d-max)
|
||||
(f x-min x-max (animated-samples samples)
|
||||
y-min y-max (animated-samples samples)
|
||||
z-min z-max (animated-samples samples)))
|
||||
|
||||
|
|
|
|||
|
|
@ -1,103 +0,0 @@
|
|||
#lang racket
|
||||
|
||||
(require plot plot/utils plot/common/contract-doc)
|
||||
|
||||
(struct label-params (score z z-ivl str v) #:transparent)
|
||||
|
||||
(define (dnorm x m s^2)
|
||||
(* (/ 1 (sqrt (* 2 pi s^2))) (exp (* -1/2 (/ (sqr (- x m)) s^2)))))
|
||||
|
||||
(define ((contour-labels-render-proc f g levels samples color size family alpha) area)
|
||||
(let/ec return
|
||||
(define-values (x-min x-max y-min y-max) (send area get-bounds))
|
||||
(match-define (list xs ys zss) (g x-min x-max samples y-min y-max samples))
|
||||
|
||||
(define-values (z-min z-max)
|
||||
(let ([zs (filter regular? (2d-sample->list zss))])
|
||||
(when (empty? zs) (return empty))
|
||||
(values (apply min* zs) (apply max* zs))))
|
||||
|
||||
(define z-ticks (contour-ticks z-min z-max levels #f))
|
||||
(define zs (map pre-tick-value z-ticks))
|
||||
|
||||
(send area set-text-foreground color)
|
||||
(send area set-font size family)
|
||||
(send area set-alpha alpha)
|
||||
(define labels
|
||||
(append*
|
||||
(for/list ([z-tick (in-list z-ticks)])
|
||||
(match-define (tick z major? label) z-tick)
|
||||
(for/list ([ya (in-list ys)]
|
||||
[yb (in-list (rest ys))]
|
||||
[zs0 (in-vector zss)]
|
||||
[zs1 (in-vector zss 1)]
|
||||
#:when #t
|
||||
[xa (in-list xs)]
|
||||
[xb (in-list (rest xs))]
|
||||
[z1 (in-vector zs0)]
|
||||
[z2 (in-vector zs0 1)]
|
||||
[z3 (in-vector zs1 1)]
|
||||
[z4 (in-vector zs1)]
|
||||
#:when #t
|
||||
[line (in-list (heights->lines xa xb ya yb z z1 z2 z3 z4))])
|
||||
(match-define (vector x y _) (vcenter line))
|
||||
(label-params 0 z
|
||||
(ivl (min* z1 z2 z3 z4) (max* z1 z2 z3 z4))
|
||||
label (send area plot->dc (vector x y)))))))
|
||||
|
||||
(match-define (vector dc-x-min dc-y-min) (send area plot->dc (vector x-min y-min)))
|
||||
(match-define (vector dc-x-max dc-y-max) (send area plot->dc (vector x-max y-max)))
|
||||
|
||||
(define x-sigma (/ (plot-width) samples))
|
||||
(define y-sigma (/ (plot-height) samples))
|
||||
(define z-sigma (/ (- z-max z-min) (length z-ticks)))
|
||||
|
||||
(define new-labels
|
||||
(for/fold ([labels labels]) ([keep (in-list (list 4))])
|
||||
(define new-labels
|
||||
(for/list ([l1 (in-list labels)])
|
||||
(match-define (label-params s1 z1 (ivl z1-min z1-max) str1 (vector x1 y1)) l1)
|
||||
(define new-score
|
||||
(apply + (for/list ([l2 (in-list labels)])
|
||||
(match-define (label-params s2 z2 _ str2 (vector x2 y2)) l2)
|
||||
(* (exp (* -1/2 (sqr (/ (- s1 s2) 1))))
|
||||
(exp (* -1/2 (sqr (/ (- x1 x2) x-sigma))))
|
||||
(exp (* -1/2 (sqr (/ (- y1 y2) y-sigma))))
|
||||
(exp (* -1/2 (sqr (/ (- z1 z2) z-sigma))))
|
||||
))))
|
||||
(label-params new-score z1 (ivl z1-min z1-max) str1 (vector x1 y1))))
|
||||
(append*
|
||||
(for/list ([z (in-list zs)])
|
||||
(define z-labels (sort (filter (λ (l) (= z (label-params-z l))) new-labels)
|
||||
> #:key label-params-score))
|
||||
#;(define keep (min 4 (length z-labels) (round (* 1/8 (length z-labels)))))
|
||||
(take z-labels (min keep (length z-labels)))))))
|
||||
|
||||
(for ([label (in-list new-labels)])
|
||||
(match-define (label-params score z _ str (vector x y)) label)
|
||||
(send area draw-text #;(real->plot-label score 3) str (vector x y) 'center 0 #:outline? #t))
|
||||
|
||||
empty))
|
||||
|
||||
(defproc (contour-labels
|
||||
[f (real? real? . -> . real?)]
|
||||
[x-min (or/c real? #f) #f] [x-max (or/c real? #f) #f]
|
||||
[y-min (or/c real? #f) #f] [y-max (or/c real? #f) #f]
|
||||
[#:levels levels (or/c 'auto exact-positive-integer? (listof real?)) (contour-levels)]
|
||||
[#:samples samples (and/c exact-integer? (>=/c 2)) (contour-samples)]
|
||||
[#:color color plot-color/c (plot-foreground)]
|
||||
[#:size size (>=/c 0) (plot-font-size)]
|
||||
[#:family family font-family/c (plot-font-family)]
|
||||
[#:alpha alpha (real-in 0 1) (label-alpha)]
|
||||
) renderer2d?
|
||||
(define g (2d-function->sampler f))
|
||||
(renderer2d (vector (ivl x-min x-max) (ivl y-min y-max)) #f #f
|
||||
(contour-labels-render-proc f g levels samples color size family alpha)))
|
||||
|
||||
;(contour-samples 11)
|
||||
;(plot-z-max-ticks 50)
|
||||
#;
|
||||
(parameterize (#;[plot-x-transform log-transform]
|
||||
#;[plot-y-transform log-transform])
|
||||
(plot (list (contours (λ (x y) (sqrt (+ (sqr x) (sqr y)))) -1 4 -1 4)
|
||||
(contour-labels (λ (x y) (sqrt (+ (sqr x) (sqr y))))))))
|
||||
Loading…
Reference in New Issue
Block a user