diff --git a/collects/meta/props b/collects/meta/props index 78dd4c0a39..7a6981fbaf 100755 --- a/collects/meta/props +++ b/collects/meta/props @@ -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) diff --git a/collects/plot/common/marching-cubes.rkt b/collects/plot/common/marching-cubes.rkt index e9d8c4536e..9aefe43e6d 100644 --- a/collects/plot/common/marching-cubes.rkt +++ b/collects/plot/common/marching-cubes.rkt @@ -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)]) diff --git a/collects/plot/common/marching-squares.rkt b/collects/plot/common/marching-squares.rkt index 810c36e46f..31ab72d188 100644 --- a/collects/plot/common/marching-squares.rkt +++ b/collects/plot/common/marching-squares.rkt @@ -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 diff --git a/collects/plot/common/parameters.rkt b/collects/plot/common/parameters.rkt index a5830baeb1..6559c10553 100644 --- a/collects/plot/common/parameters.rkt +++ b/collects/plot/common/parameters.rkt @@ -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)) diff --git a/collects/plot/common/samplers.rkt b/collects/plot/common/samplers.rkt index e4c05b1c1f..0f8421beb7 100644 --- a/collects/plot/common/samplers.rkt +++ b/collects/plot/common/samplers.rkt @@ -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)) diff --git a/collects/plot/common/ticks.rkt b/collects/plot/common/ticks.rkt index d8429df907..d10ef402af 100644 --- a/collects/plot/common/ticks.rkt +++ b/collects/plot/common/ticks.rkt @@ -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))) diff --git a/collects/plot/contracted/samplers.rkt b/collects/plot/contracted/samplers.rkt index 9cd7a91028..8ac38bc3f4 100644 --- a/collects/plot/contracted/samplers.rkt +++ b/collects/plot/contracted/samplers.rkt @@ -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)) diff --git a/collects/plot/contracted/ticks.rkt b/collects/plot/contracted/ticks.rkt index f1ac65092b..cf26c32686 100644 --- a/collects/plot/contracted/ticks.rkt +++ b/collects/plot/contracted/ticks.rkt @@ -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)) diff --git a/collects/plot/plot2d/contour.rkt b/collects/plot/plot2d/contour.rkt index 59a2d71e47..c26e6a2062 100644 --- a/collects/plot/plot2d/contour.rkt +++ b/collects/plot/plot2d/contour.rkt @@ -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)] diff --git a/collects/plot/plot2d/decoration.rkt b/collects/plot/plot2d/decoration.rkt index 102075e69c..570c400904 100644 --- a/collects/plot/plot2d/decoration.rkt +++ b/collects/plot/plot2d/decoration.rkt @@ -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 diff --git a/collects/plot/plot2d/plot.rkt b/collects/plot/plot2d/plot.rkt index 8cd5f838c7..132428328e 100644 --- a/collects/plot/plot2d/plot.rkt +++ b/collects/plot/plot2d/plot.rkt @@ -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)) diff --git a/collects/plot/plot2d/snip.rkt b/collects/plot/plot2d/snip.rkt index 795ae08c2a..6a04d5a362 100644 --- a/collects/plot/plot2d/snip.rkt +++ b/collects/plot/plot2d/snip.rkt @@ -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) diff --git a/collects/plot/plot3d/contour.rkt b/collects/plot/plot3d/contour.rkt index cefd98ba1c..6c35c424ce 100644 --- a/collects/plot/plot3d/contour.rkt +++ b/collects/plot/plot3d/contour.rkt @@ -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)] diff --git a/collects/plot/plot3d/isosurface.rkt b/collects/plot/plot3d/isosurface.rkt index 0882a1760f..ac9369a0a5 100644 --- a/collects/plot/plot3d/isosurface.rkt +++ b/collects/plot/plot3d/isosurface.rkt @@ -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?)] diff --git a/collects/plot/tests/tick-tests.rkt b/collects/plot/tests/tick-tests.rkt index 7af955b663..6f62ec9e7e 100644 --- a/collects/plot/tests/tick-tests.rkt +++ b/collects/plot/tests/tick-tests.rkt @@ -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)")))