Reworked how major and minor ticks are chosen; now isosurfaces3d always shows 3-5 surfaces, and all *-ticks parameters have the same default
Contour and isosurface 'auto levels reorg 2D contours: z-min = z-max now makes empty plot instead of infinite loop 3D isosurfaces: d-min = d-max now makes empty plot instead of infinite loop Fixed contracts and corner case on marching squares and cubes functions Better selection box and point-label formatting Increased timeout on extreme-bounds-tests.rkt
This commit is contained in:
Neil Toronto
parent
bf77e525cc
commit
989fcc4c22
|
|
@ -1152,6 +1152,7 @@ path/s is either such a string or a list of them.
|
|||
"collects/plai/private/gc-gui.rkt" drdr:command-line (gracket "-t" *)
|
||||
"collects/planet" responsible (robby)
|
||||
"collects/plot" responsible (ntoronto)
|
||||
"collects/plot/tests/extreme-bounds-tests.rkt" drdr:timeout 150
|
||||
"collects/plot/tests/slideshow-test.rkt" drdr:command-line #f
|
||||
"collects/preprocessor" responsible (eli)
|
||||
"collects/profile" responsible (eli)
|
||||
|
|
|
|||
|
|
@ -535,7 +535,7 @@ Cube vertex numbers:
|
|||
[d real?]
|
||||
[d1 real?] [d2 real?] [d3 real?] [d4 real?]
|
||||
[d5 real?] [d6 real?] [d7 real?] [d8 real?]
|
||||
) (listof (vector/c real? real? real?))
|
||||
) (listof (listof (vector/c real? real? real?)))
|
||||
(cond [(all inexact-real? xa xb ya yb za zb d d1 d2 d3 d4 d5 d6 d7 d8)
|
||||
(define polys (unsafe-heights->cube-polys d d1 d2 d3 d4 d5 d6 d7 d8))
|
||||
(for/list ([poly (in-list polys)])
|
||||
|
|
|
|||
|
|
@ -157,7 +157,7 @@ above.
|
|||
|
||||
(defproc (heights->lines [xa real?] [xb real?] [ya real?] [yb real?]
|
||||
[z real?] [z1 real?] [z2 real?] [z3 real?] [z4 real?]
|
||||
) (list/c (vector/c real? real? real?) (vector/c real? real? real?))
|
||||
) (listof (list/c (vector/c real? real? real?) (vector/c real? real? real?)))
|
||||
(cond [(all inexact-real? xa xb ya yb z z1 z2 z3 z4)
|
||||
(define lines (unsafe-heights->lines z z1 z2 z3 z4))
|
||||
(for/list ([line (in-list lines)])
|
||||
|
|
@ -599,7 +599,7 @@ above.
|
|||
(defproc (heights->polys [xa real?] [xb real?] [ya real?] [yb real?]
|
||||
[za real?] [zb real?]
|
||||
[z1 real?] [z2 real?] [z3 real?] [z4 real?]
|
||||
) (listof (vector/c real? real? real?))
|
||||
) (listof (listof (vector/c real? real? real?)))
|
||||
(cond [(all inexact-real? xa xb ya yb za zb z1 z2 z3 z4)
|
||||
(define polys (unsafe-heights->polys za zb z1 z2 z3 z4))
|
||||
(for/list ([poly (in-list polys)])
|
||||
|
|
@ -610,8 +610,8 @@ above.
|
|||
(vector (unsafe-unsolve-t xa xb u) (unsafe-unsolve-t ya yb v) z))]))]
|
||||
[(find-failure-index real? xa xb ya yb za zb z1 z2 z3 z4)
|
||||
=> (λ (i) (raise-type-error 'heights->polys "real number" i xa xb ya yb za zb z1 z2 z3 z4))]
|
||||
[(= za zb z1 z2 z3 z4) (list (vector xa ya z1) (vector xb ya z2)
|
||||
(vector xb yb z3) (vector xa yb z4))]
|
||||
[(= za zb z1 z2 z3 z4) (list (list (vector xa ya z1) (vector xb ya z2)
|
||||
(vector xb yb z3) (vector xa yb z4)))]
|
||||
[else
|
||||
(let-map
|
||||
(za zb z1 z2 z3 z4) inexact->exact
|
||||
|
|
|
|||
|
|
@ -117,9 +117,9 @@
|
|||
|
||||
(defparam plot-x-ticks ticks? (linear-ticks))
|
||||
(defparam plot-y-ticks ticks? (linear-ticks))
|
||||
(defparam plot-z-ticks ticks? (linear-ticks #:number 8))
|
||||
(defparam plot-d-ticks ticks? (linear-ticks #:number 6 #:divisors '(1 2 4 5)))
|
||||
(defparam plot-r-ticks ticks? (linear-ticks #:number 8))
|
||||
(defparam plot-z-ticks ticks? (linear-ticks))
|
||||
(defparam plot-d-ticks ticks? (linear-ticks))
|
||||
(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))
|
||||
|
|
|
|||
|
|
@ -22,50 +22,3 @@
|
|||
|
||||
(defthing 3d-function->sampler ((real? real? real? . -> . real?) . -> . 3d-sampler/c)
|
||||
(make-3d-function->sampler plot-x-transform plot-y-transform plot-z-transform))
|
||||
|
||||
(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))]
|
||||
[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 (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))]
|
||||
[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))
|
||||
|
|
|
|||
|
|
@ -29,14 +29,14 @@
|
|||
(defcontract ticks-layout/c (real? real? . -> . (listof pre-tick?)))
|
||||
(defcontract ticks-format/c (real? real? (listof pre-tick?) . -> . (listof string?)))
|
||||
|
||||
(defparam ticks-default-number exact-positive-integer? 5)
|
||||
(defparam ticks-default-number exact-positive-integer? 4)
|
||||
|
||||
;; ===================================================================================================
|
||||
;; 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)]
|
||||
(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 ...)]))
|
||||
|
|
@ -70,46 +70,63 @@
|
|||
;; ===================================================================================================
|
||||
;; Linear ticks (default tick function, evenly spaced)
|
||||
|
||||
(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?)
|
||||
(defproc (linear-tick-step [x-min real?] [x-max real?]
|
||||
[num-ticks exact-positive-integer?]
|
||||
[base (and/c exact-integer? (>=/c 2))]
|
||||
[divisors (listof exact-positive-integer?)]) real?
|
||||
(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)))
|
||||
(define epsilon (expt 10 (- (digits-for-range x-min x-max))))
|
||||
(define e-start (floor-log/base base num-ticks))
|
||||
(define-values (step diff)
|
||||
(for*/fold ([step #f] [diff +inf.0]) ([e (in-range e-start -2 -1)]
|
||||
[d (in-list (sort divisors <))])
|
||||
;; when num-ticks > base, we sometimes must divide by (expt base e) instead of just base
|
||||
(define new-step (/ mag d (expt base e)))
|
||||
;; find the start, end and number of ticks with this step size
|
||||
(define-values (new-start new-end new-num) (linear-seq-args x-min x-max new-step))
|
||||
;; endpoints don't count in the number of ticks (a concession for contour-ticks, which
|
||||
;; seems to work well outside of contour plots anyway)
|
||||
(let* ([new-num (if ((abs (- new-start x-min)) . < . epsilon) (- new-num 1) new-num)]
|
||||
[new-num (if ((abs (- new-end x-max)) . < . epsilon) (- new-num 1) new-num)])
|
||||
;; keep the step size that generates the number of ticks closest to num-ticks
|
||||
(define new-diff (abs (- new-num num-ticks)))
|
||||
(cond [(new-diff . <= . diff) (values new-step new-diff)]
|
||||
[else (values step diff)]))))
|
||||
(if step step (/ range num-ticks)))
|
||||
|
||||
(defproc (linear-tick-values [x-min real?] [x-max real?]
|
||||
[max-ticks exact-positive-integer?]
|
||||
[num-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))))
|
||||
(cond
|
||||
[(= x-min x-max) (values empty empty)]
|
||||
[else
|
||||
(define major-step (linear-tick-step x-min x-max num-ticks base divisors))
|
||||
(define major-xs (linear-major-values/step x-min x-max major-step))
|
||||
(define num-major-ticks (length major-xs))
|
||||
|
||||
(define minor-xs
|
||||
(let loop ([mult 2])
|
||||
(cond [(mult . > . 4) empty]
|
||||
[else
|
||||
(define minor-step (linear-tick-step x-min x-max (* mult num-ticks) base divisors))
|
||||
(define minor-xs (linear-major-values/step x-min x-max minor-step))
|
||||
(cond [(empty? (remove* minor-xs major-xs))
|
||||
;; this covers the major ticks as well; check for additional minor ticks
|
||||
(define real-minor-xs (remove* major-xs minor-xs))
|
||||
(cond [(empty? real-minor-xs) (loop (+ 1 mult))]
|
||||
[else real-minor-xs])]
|
||||
[else (loop (+ 1 mult))])])))
|
||||
|
||||
(values major-xs minor-xs)])))
|
||||
|
||||
(defproc (linear-ticks-layout [#:number number exact-positive-integer? (ticks-default-number)]
|
||||
[#:base base (and/c exact-integer? (>=/c 2)) 10]
|
||||
[#:divisors divisors (listof exact-positive-integer?) '(1 2 5)]
|
||||
[#:divisors divisors (listof exact-positive-integer?) '(1 2 4 5)]
|
||||
) ticks-layout/c
|
||||
(λ (x-min x-max)
|
||||
(define-values (major-xs minor-xs) (linear-tick-values x-min x-max number base divisors))
|
||||
|
|
@ -125,7 +142,7 @@
|
|||
|
||||
(defproc (linear-ticks [#:number number exact-positive-integer? (ticks-default-number)]
|
||||
[#:base base (and/c exact-integer? (>=/c 2)) 10]
|
||||
[#:divisors divisors (listof exact-positive-integer?) '(1 2 5)]
|
||||
[#:divisors divisors (listof exact-positive-integer?) '(1 2 4 5)]
|
||||
) ticks? #:document-body
|
||||
(ticks (linear-ticks-layout #:number number #:base base
|
||||
#:divisors divisors)
|
||||
|
|
@ -195,16 +212,22 @@
|
|||
;; ===================================================================================================
|
||||
;; Date/time helpers
|
||||
|
||||
(defproc (find-linear-tick-step [x-min real?] [x-max real?] [max-ticks exact-positive-integer?]
|
||||
(defproc (find-linear-tick-step [x-min real?] [x-max real?]
|
||||
[num-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 epsilon (expt 10 (- (digits-for-range x-min x-max))))
|
||||
(define-values (step diff)
|
||||
(for/fold ([step #f] [diff +inf.0]) ([new-step (in-list (sort steps <))])
|
||||
(define-values (new-start new-end new-num) (linear-seq-args x-min x-max new-step))
|
||||
;; endpoints don't count in number of ticks (see linear-tick-step)
|
||||
(let* ([new-num (if ((abs (- new-start x-min)) . < . epsilon) (- new-num 1) new-num)]
|
||||
[new-num (if ((abs (- new-end x-max)) . < . epsilon) (- new-num 1) new-num)])
|
||||
(define new-diff (abs (- new-num num-ticks)))
|
||||
(cond [(new-diff . <= . diff) (values new-step new-diff)]
|
||||
[else (values step diff)]))))
|
||||
step))
|
||||
|
||||
(define (count-changing-fields formatter fmt-list xs)
|
||||
(let ([fmt-list (filter symbol? fmt-list)])
|
||||
|
|
@ -264,14 +287,16 @@
|
|||
|
||||
;; Tick steps to try, in seconds
|
||||
(define date-steps
|
||||
(list 1 2 5 10 15 20 30 40 45
|
||||
(list 1 2 4 5 10 15 20 30 40 45
|
||||
seconds-per-minute
|
||||
(* 2 seconds-per-minute)
|
||||
(* 4 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)
|
||||
|
|
@ -279,8 +304,10 @@
|
|||
(* 6 seconds-per-hour)
|
||||
(* 8 seconds-per-hour)
|
||||
(* 12 seconds-per-hour)
|
||||
(* 18 seconds-per-hour)
|
||||
seconds-per-day
|
||||
(* 2 seconds-per-day)
|
||||
(* 4 seconds-per-day)
|
||||
(* 5 seconds-per-day)
|
||||
(* 10 seconds-per-day)
|
||||
seconds-per-week
|
||||
|
|
@ -294,30 +321,29 @@
|
|||
(* 9 avg-seconds-per-month)
|
||||
avg-seconds-per-year
|
||||
(* 2 avg-seconds-per-year)
|
||||
(* 4 avg-seconds-per-year)
|
||||
(* 5 avg-seconds-per-year)))
|
||||
|
||||
(define (date-tick-values x-min x-max max-ticks)
|
||||
(define (date-tick-values x-min x-max num-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)))
|
||||
(cond [(= x-min x-max) (values empty empty)]
|
||||
[else
|
||||
(define range (- x-max x-min))
|
||||
(define step
|
||||
(cond [(range . < . (* num-ticks (first date-steps)))
|
||||
(linear-tick-step x-min x-max num-ticks 10 '(1 2 4 5))]
|
||||
[(range . > . (* num-ticks (last date-steps)))
|
||||
(* avg-seconds-per-year
|
||||
(linear-tick-step (/ x-min avg-seconds-per-year) (/ x-max avg-seconds-per-year)
|
||||
num-ticks 10 '(1 2 4 5)))]
|
||||
[else (find-linear-tick-step x-min x-max num-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 [#:number number exact-positive-integer? (ticks-default-number)]
|
||||
) ticks-layout/c
|
||||
|
|
@ -377,9 +403,10 @@
|
|||
|
||||
;; Tick steps to try, in seconds
|
||||
(define time-steps
|
||||
(list 1 2 5 10 15 20 30 40 45
|
||||
(list 1 2 4 5 10 15 20 30 40 45
|
||||
seconds-per-minute
|
||||
(* 2 seconds-per-minute)
|
||||
(* 4 seconds-per-minute)
|
||||
(* 5 seconds-per-minute)
|
||||
(* 10 seconds-per-minute)
|
||||
(* 15 seconds-per-minute)
|
||||
|
|
@ -396,6 +423,7 @@
|
|||
(* 18 seconds-per-hour)
|
||||
seconds-per-day
|
||||
(* 2 seconds-per-day)
|
||||
(* 4 seconds-per-day)
|
||||
(* 5 seconds-per-day)
|
||||
(* 10 seconds-per-day)
|
||||
(* 15 seconds-per-day)
|
||||
|
|
@ -403,25 +431,23 @@
|
|||
(* 60 seconds-per-day)
|
||||
(* 90 seconds-per-day)))
|
||||
|
||||
(define (time-tick-values x-min x-max max-ticks)
|
||||
(define (time-tick-values x-min x-max num-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)))
|
||||
(cond [(= x-min x-max) (values empty empty)]
|
||||
[else
|
||||
(define range (- x-max x-min))
|
||||
(define step
|
||||
(cond [(range . < . (* num-ticks (first time-steps)))
|
||||
(linear-tick-step x-min x-max num-ticks 10 '(1 2 4 5))]
|
||||
[(range . > . (* num-ticks (last time-steps)))
|
||||
(* seconds-per-day
|
||||
(linear-tick-step (/ x-min seconds-per-day) (/ x-max seconds-per-day)
|
||||
num-ticks 10 '(1 2 4 5)))]
|
||||
[else
|
||||
(find-linear-tick-step x-min x-max num-ticks time-steps)]))
|
||||
(define major-xs (linear-major-values/step x-min x-max step))
|
||||
(values major-xs empty)])))
|
||||
|
||||
(defproc (time-ticks-layout [#:number number exact-positive-integer? (ticks-default-number)]
|
||||
) ticks-layout/c
|
||||
|
|
@ -486,7 +512,7 @@
|
|||
) ticks? #:document-body
|
||||
(define si? (eq? kind 'SI))
|
||||
(ticks (linear-ticks-layout #:number number #:base (if si? 10 2)
|
||||
#:divisors (if si? '(1 2 5) '(1 2)))
|
||||
#:divisors (if si? '(1 2 4 5) '(1 2)))
|
||||
(bit/byte-ticks-format #:size size #:kind kind)))
|
||||
|
||||
;; ===================================================================================================
|
||||
|
|
@ -572,8 +598,7 @@
|
|||
[#:scales scales (listof string?) (currency-ticks-scales)]
|
||||
[#:formats formats (list/c string? string? string?) (currency-ticks-formats)]
|
||||
) ticks? #:document-body
|
||||
(ticks (linear-ticks-layout #:number number #:base 10
|
||||
#:divisors '(1 2 4 5))
|
||||
(ticks (linear-ticks-layout #:number number)
|
||||
(currency-ticks-format #:kind kind #:scales scales
|
||||
#:formats formats)))
|
||||
|
||||
|
|
@ -643,10 +668,8 @@
|
|||
format))
|
||||
|
||||
(defproc (linear-scale [m rational?] [b rational? 0]) invertible-function? #:document-body
|
||||
(let ([m (inexact->exact m)]
|
||||
[b (inexact->exact b)])
|
||||
(invertible-function (λ (x) (+ (* m x) b))
|
||||
(λ (y) (/ (- y b) m)))))
|
||||
(invertible-function (λ (x) (+ (* m x) b))
|
||||
(λ (y) (/ (- y b) m))))
|
||||
|
||||
;; ===================================================================================================
|
||||
;; Tick utils
|
||||
|
|
@ -684,3 +707,45 @@
|
|||
(defproc (tick-inexact->exact [t tick?]) tick?
|
||||
(match-define (tick x major? label) t)
|
||||
(tick (inexact->exact x) major? label))
|
||||
|
||||
(defproc (contour-ticks [z-ticks 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) z-ticks)
|
||||
;; initial tick layout
|
||||
(define ts
|
||||
(cond [(eq? levels 'auto) (filter pre-tick-major? (layout z-min z-max))]
|
||||
[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)]))
|
||||
(let* (;; remove z-min tick (or the one close to it) if present
|
||||
[ts (if (and (not (empty? ts))
|
||||
((abs (- z-min (pre-tick-value (first ts)))) . < . epsilon))
|
||||
(rest ts)
|
||||
ts)]
|
||||
;; remove z-max tick (or the one close to it) if present
|
||||
[ts (if (and (not (empty? ts))
|
||||
((abs (- z-max (pre-tick-value (last ts)))) . < . epsilon))
|
||||
(drop-right ts 1)
|
||||
ts)]
|
||||
;; add z-min and z-max if doing intervals
|
||||
[ts (cond [(not intervals?) ts]
|
||||
[else (append (list (pre-tick z-min #t)) ts (list (pre-tick z-max #t)))])])
|
||||
;; format the ticks
|
||||
(match-define (list (pre-tick zs majors) ...) ts)
|
||||
(define labels (format z-min z-max ts))
|
||||
(map tick zs majors labels)))
|
||||
|
||||
(defproc (format-tick-labels [x-ticks ticks?] [x-min real?] [x-max real?] [xs (listof real?)]
|
||||
) (listof string?)
|
||||
(match-define (ticks layout format) x-ticks)
|
||||
(let* ([tick-xs (map pre-tick-value (filter pre-tick-major? (layout x-min x-max)))]
|
||||
[tick-xs (remove* xs tick-xs)]
|
||||
[tick-xs (if (empty? tick-xs) empty (list (apply min tick-xs) (apply max tick-xs)))]
|
||||
[tick-xs (sort (append xs tick-xs) <)])
|
||||
(define ts (map (λ (x) (pre-tick x #t)) tick-xs))
|
||||
(for/list ([x (in-list tick-xs)]
|
||||
[l (in-list (format x-min x-max ts))]
|
||||
#:when (member x xs))
|
||||
l)))
|
||||
|
|
|
|||
|
|
@ -6,6 +6,4 @@
|
|||
(provide (activate-contract-out function->sampler
|
||||
inverse->sampler
|
||||
2d-function->sampler
|
||||
3d-function->sampler
|
||||
contour-ticks
|
||||
isosurface-ticks))
|
||||
3d-function->sampler))
|
||||
|
|
|
|||
|
|
@ -23,4 +23,5 @@
|
|||
currency-ticks-scales currency-ticks-formats
|
||||
currency-ticks-format currency-ticks
|
||||
fraction-ticks-format fraction-ticks
|
||||
collapse-ticks))
|
||||
collapse-ticks
|
||||
contour-ticks format-tick-labels))
|
||||
|
|
|
|||
|
|
@ -56,30 +56,32 @@
|
|||
(define sample (g 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) sample)
|
||||
(match-define (list (tick zs _ labels) ...) (contour-ticks z-min z-max levels #f))
|
||||
(match-define (list (tick zs _ labels) ...) (contour-ticks (plot-z-ticks) z-min z-max levels #f))
|
||||
|
||||
(let* ([colors (maybe-apply colors zs)]
|
||||
[widths (maybe-apply widths zs)]
|
||||
[styles (maybe-apply styles zs)]
|
||||
[alphas (maybe-apply alphas zs)]
|
||||
[flonum-ok? (flonum-ok-for-3d? x-min x-max y-min y-max z-min z-max)]
|
||||
[sample (if flonum-ok? (2d-sample-exact->inexact sample) sample)]
|
||||
[zs (if flonum-ok? (map exact->inexact zs) zs)])
|
||||
(for ([z (in-list zs)]
|
||||
[color (in-cycle colors)]
|
||||
[width (in-cycle widths)]
|
||||
[style (in-cycle styles)]
|
||||
[alpha (in-cycle alphas)])
|
||||
(send area put-alpha alpha)
|
||||
(send area put-pen color width style)
|
||||
(for-2d-sample
|
||||
(xa xb ya yb z1 z2 z3 z4) sample
|
||||
(for/list ([line (in-list (heights->lines xa xb ya yb z z1 z2 z3 z4))])
|
||||
(match-define (list v1 v2) (map (λ (v) (vector-take v 2)) line))
|
||||
(send area put-line v1 v2))))
|
||||
|
||||
(cond [label (line-legend-entries label zs labels colors widths styles)]
|
||||
[else empty]))))
|
||||
;; need to check this or in-cycle below does an infinite loop (I think it's an in-cycle bug)
|
||||
(unless (empty? zs)
|
||||
(let* ([colors (maybe-apply colors zs)]
|
||||
[widths (maybe-apply widths zs)]
|
||||
[styles (maybe-apply styles zs)]
|
||||
[alphas (maybe-apply alphas zs)]
|
||||
[flonum-ok? (flonum-ok-for-3d? x-min x-max y-min y-max z-min z-max)]
|
||||
[sample (if flonum-ok? (2d-sample-exact->inexact sample) sample)]
|
||||
[zs (if flonum-ok? (map exact->inexact zs) zs)])
|
||||
(for ([z (in-list zs)]
|
||||
[color (in-cycle colors)]
|
||||
[width (in-cycle widths)]
|
||||
[style (in-cycle styles)]
|
||||
[alpha (in-cycle alphas)])
|
||||
(send area put-alpha alpha)
|
||||
(send area put-pen color width style)
|
||||
(for-2d-sample
|
||||
(xa xb ya yb z1 z2 z3 z4) sample
|
||||
(for/list ([line (in-list (heights->lines xa xb ya yb z z1 z2 z3 z4))])
|
||||
(match-define (list v1 v2) (map (λ (v) (vector-take v 2)) line))
|
||||
(send area put-line v1 v2))))))
|
||||
|
||||
(cond [(and label (not (empty? zs))) (line-legend-entries label zs labels colors widths styles)]
|
||||
[else empty])))
|
||||
|
||||
(defproc (contours
|
||||
[f (real? real? . -> . real?)]
|
||||
|
|
@ -108,7 +110,7 @@
|
|||
(define sample (g 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) sample)
|
||||
(match-define (list (tick zs _ labels) ...) (contour-ticks z-min z-max levels #t))
|
||||
(match-define (list (tick zs _ labels) ...) (contour-ticks (plot-z-ticks) z-min z-max levels #t))
|
||||
|
||||
(define-values (z-ivls ivl-labels)
|
||||
(for/lists (z-ivls ivl-labels) ([za (in-list zs)]
|
||||
|
|
|
|||
|
|
@ -200,8 +200,8 @@
|
|||
(define (format-coordinate v area)
|
||||
(match-define (vector x y) v)
|
||||
(match-define (vector (ivl x-min x-max) (ivl y-min y-max)) (send area get-bounds-rect))
|
||||
(match-define (list x-str) ((ticks-format (plot-x-ticks)) x-min x-max (list (pre-tick x #t))))
|
||||
(match-define (list y-str) ((ticks-format (plot-y-ticks)) y-min y-max (list (pre-tick y #t))))
|
||||
(match-define (list x-str) (format-tick-labels (plot-x-ticks) x-min x-max (list x)))
|
||||
(match-define (list y-str) (format-tick-labels (plot-y-ticks) y-min y-max (list y)))
|
||||
(format "(~a,~a)" x-str y-str))
|
||||
|
||||
(define ((label-render-proc label v color size family anchor angle
|
||||
|
|
|
|||
|
|
@ -15,12 +15,12 @@
|
|||
"../common/deprecation-warning.rkt"
|
||||
"../common/contract-doc.rkt"
|
||||
"../common/format.rkt"
|
||||
"snip.rkt"
|
||||
"plot-area.rkt")
|
||||
|
||||
;; Require lazily: without this, Racket complains while generating documentation:
|
||||
;; cannot instantiate `racket/gui/base' a second time in the same process
|
||||
(lazy-require ["../common/gui.rkt" (make-snip-frame)])
|
||||
(lazy-require ["snip.rkt" (make-2d-plot-snip)]
|
||||
["../common/gui.rkt" (make-snip-frame)])
|
||||
|
||||
(provide (except-out (all-defined-out) get-renderer-list get-bounds-rect get-ticks plot-dc))
|
||||
|
||||
|
|
|
|||
|
|
@ -147,12 +147,10 @@
|
|||
(area-bounds->plot-bounds rect))
|
||||
|
||||
(match-define (list new-x-min-str new-x-max-str)
|
||||
((ticks-format (plot-x-ticks))
|
||||
x-min x-max (list (pre-tick new-x-min #t) (pre-tick new-x-max #t))))
|
||||
(format-tick-labels (plot-x-ticks) x-min x-max (list new-x-min new-x-max)))
|
||||
|
||||
(match-define (list new-y-min-str new-y-max-str)
|
||||
((ticks-format (plot-y-ticks))
|
||||
y-min y-max (list (pre-tick new-y-min #t) (pre-tick new-y-max #t))))
|
||||
(format-tick-labels (plot-y-ticks) y-min y-max (list new-y-min new-y-max)))
|
||||
|
||||
;; draw side labels
|
||||
(match-define (vector (ivl new-area-x-min new-area-x-max)
|
||||
|
|
|
|||
|
|
@ -60,7 +60,8 @@
|
|||
(send area get-bounds-rect))
|
||||
(define sample (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))
|
||||
;; can't use the actual z ticks because some or all could be collapsed
|
||||
(match-define (list (tick zs _ labels) ...) (contour-ticks (plot-z-ticks) z-min z-max levels #f))
|
||||
|
||||
(let* ([colors (maybe-apply colors zs)]
|
||||
[widths (maybe-apply widths zs)]
|
||||
|
|
@ -117,7 +118,8 @@
|
|||
(send area get-bounds-rect))
|
||||
(define sample (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))
|
||||
;; can't use the actual z ticks because some or all could be collapsed
|
||||
(match-define (list (tick zs _ labels) ...) (contour-ticks (plot-z-ticks) z-min z-max levels #t))
|
||||
|
||||
(define-values (z-ivls ivl-labels)
|
||||
(for/lists (z-ivls ivl-labels) ([za (in-list zs)]
|
||||
|
|
|
|||
|
|
@ -70,42 +70,43 @@
|
|||
(define d-min (if rd-min rd-min fd-min))
|
||||
(define d-max (if rd-max rd-max fd-max))
|
||||
|
||||
(match-define (list (tick ds _ labels) ...)
|
||||
(cond [(and d-min d-max) (contour-ticks (plot-d-ticks) d-min d-max levels #f)]
|
||||
[else empty]))
|
||||
|
||||
;; need to check this or in-cycle below does an infinite loop (I think it's an in-cycle bug)
|
||||
(unless (empty? ds)
|
||||
(let* ([colors (maybe-apply colors ds)]
|
||||
[styles (maybe-apply styles ds)]
|
||||
[alphas (maybe-apply alphas ds)]
|
||||
[line-colors (maybe-apply line-colors ds)]
|
||||
[line-widths (maybe-apply line-widths ds)]
|
||||
[line-styles (maybe-apply line-styles ds)]
|
||||
[flonum-ok? (flonum-ok-for-4d? x-min x-max y-min y-max z-min z-max d-min d-max)]
|
||||
[sample (if flonum-ok? (3d-sample-exact->inexact sample) sample)]
|
||||
[ds (if flonum-ok? (map exact->inexact ds) ds)])
|
||||
(for ([d (in-list ds)]
|
||||
[color (in-cycle colors)]
|
||||
[style (in-cycle styles)]
|
||||
[alpha (in-cycle alphas)]
|
||||
[line-color (in-cycle line-colors)]
|
||||
[line-width (in-cycle line-widths)]
|
||||
[line-style (in-cycle line-styles)])
|
||||
(send area put-alpha alpha)
|
||||
(send area put-brush color style)
|
||||
(send area put-pen line-color line-width line-style)
|
||||
(for-3d-sample
|
||||
(xa xb ya yb za zb d1 d2 d3 d4 d5 d6 d7 d8) sample
|
||||
(define polys (heights->cube-polys xa xb ya yb za zb d d1 d2 d3 d4 d5 d6 d7 d8))
|
||||
(when (not (empty? polys))
|
||||
(send area put-polygons polys
|
||||
(vector (* 1/2 (+ xa xb)) (* 1/2 (+ ya yb)) (* 1/2 (+ za zb)))))))))
|
||||
|
||||
|
||||
(cond
|
||||
[(not (and d-min d-max)) empty]
|
||||
[else
|
||||
(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)))
|
||||
|
||||
(let* ([colors (maybe-apply colors ds)]
|
||||
[styles (maybe-apply styles ds)]
|
||||
[alphas (maybe-apply alphas ds)]
|
||||
[line-colors (maybe-apply line-colors ds)]
|
||||
[line-widths (maybe-apply line-widths ds)]
|
||||
[line-styles (maybe-apply line-styles ds)]
|
||||
[flonum-ok? (flonum-ok-for-4d? x-min x-max y-min y-max z-min z-max d-min d-max)]
|
||||
[sample (if flonum-ok? (3d-sample-exact->inexact sample) sample)]
|
||||
[ds (if flonum-ok? (map exact->inexact ds) ds)])
|
||||
(for ([d (in-list ds)]
|
||||
[color (in-cycle colors)]
|
||||
[style (in-cycle styles)]
|
||||
[alpha (in-cycle alphas)]
|
||||
[line-color (in-cycle line-colors)]
|
||||
[line-width (in-cycle line-widths)]
|
||||
[line-style (in-cycle line-styles)])
|
||||
(send area put-alpha alpha)
|
||||
(send area put-brush color style)
|
||||
(send area put-pen line-color line-width line-style)
|
||||
(for-3d-sample
|
||||
(xa xb ya yb za zb d1 d2 d3 d4 d5 d6 d7 d8) sample
|
||||
(define polys (heights->cube-polys xa xb ya yb za zb d d1 d2 d3 d4 d5 d6 d7 d8))
|
||||
(when (not (empty? polys))
|
||||
(send area put-polygons polys
|
||||
(vector (* 1/2 (+ xa xb)) (* 1/2 (+ ya yb)) (* 1/2 (+ za zb)))))))
|
||||
|
||||
(cond
|
||||
[label (rectangle-legend-entries
|
||||
label ds colors styles line-colors line-widths line-styles)]
|
||||
[else empty]))]))
|
||||
[(and label (not (empty? ds))) (rectangle-legend-entries
|
||||
label ds colors styles line-colors line-widths line-styles)]
|
||||
[else empty]))
|
||||
|
||||
(defproc (isosurfaces3d
|
||||
[f (real? real? real? . -> . real?)]
|
||||
|
|
|
|||
|
|
@ -4,11 +4,43 @@
|
|||
|
||||
(plot-font-family 'swiss)
|
||||
|
||||
(plot (function (λ (x) (count pre-tick-major? ((linear-ticks #:number 8) 0 x)))
|
||||
0.1 10))
|
||||
(define (get-isosurface-ticks z-min z-max)
|
||||
(cond [(z-min . >= . z-max) empty]
|
||||
[else
|
||||
(map pre-tick-value
|
||||
(filter pre-tick-major?
|
||||
(contour-ticks (plot-d-ticks) z-min z-max 'auto #f)))]))
|
||||
|
||||
(plot (function (λ (x) (count pre-tick-major? ((linear-ticks #:number 40) 0 x)))
|
||||
1 100))
|
||||
;; try to verify that we always get 3-5 isosurfaces from the isosurfaces3d renderer
|
||||
(time
|
||||
(plot (function (λ (x)
|
||||
(let ([ts (get-isosurface-ticks 1/10 (+ 1/10 x))])
|
||||
(if (empty? ts) +nan.0 (length ts))))
|
||||
#:samples 10000)
|
||||
#:x-min 0 #:x-max 10
|
||||
#:x-label "bounds size (min = 1/10)"
|
||||
#:y-label "number of ticks"))
|
||||
|
||||
;; try to verify that we always get 3-5 isosurfaces from the isosurfaces3d renderer
|
||||
(time
|
||||
(plot3d (contour-intervals3d (λ (x y)
|
||||
(let ([ts (get-isosurface-ticks x (+ x y))])
|
||||
(if (empty? ts) +nan.0 (length ts))))
|
||||
#:samples 101 #:line-styles '(transparent))
|
||||
#:x-min 0 #:x-max 10 #:y-min 0 #:y-max 10
|
||||
#:x-label "bounds min" #:y-label "bounds size"
|
||||
#:z-label "number of ticks"))
|
||||
|
||||
(time
|
||||
(plot (contour-intervals (λ (x y)
|
||||
(let ([ts (get-isosurface-ticks x (+ x y))])
|
||||
(if (empty? ts) +nan.0 (length ts))))
|
||||
#:samples 101)
|
||||
#:x-min 0 #:x-max 10 #:y-min 0 #:y-max 10
|
||||
#:x-label "bounds min" #:y-label "bounds size"))
|
||||
|
||||
(plot (function (λ (x) (count pre-tick-major? ((linear-ticks) 0 x))) #e0.1 10))
|
||||
(plot (function (λ (x) (count pre-tick-major? ((linear-ticks #:number 40) 0 x))) 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))])
|
||||
|
|
@ -187,7 +219,7 @@
|
|||
(lines data #:color 2 #:width 2)
|
||||
(points data #:color 2 #:line-width 2 #:fill-color 0 #:sym 'fullcircle
|
||||
#:label "Measurement")
|
||||
(map (λ (d) (point-label d #:anchor 'bottom-right #:point-color 2 #:point-size 7))
|
||||
(map (λ (d) (point-label d #:anchor 'bottom #:point-color 2 #:point-size 7))
|
||||
above-data))
|
||||
#:y-min -25 #:x-label "Time" #:y-label "Temp."
|
||||
#:title "Temp./Time With Applied Heat (Measurement and Trend)")))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user