diff --git a/pkgs/plot-pkgs/plot-lib/plot/private/common/legend.rkt b/pkgs/plot-pkgs/plot-lib/plot/private/common/legend.rkt index 03ea13832c..ea8f37baf2 100644 --- a/pkgs/plot-pkgs/plot-lib/plot/private/common/legend.rkt +++ b/pkgs/plot-pkgs/plot-lib/plot/private/common/legend.rkt @@ -34,9 +34,9 @@ (define hash (for/fold ([hash empty]) ([z (in-list zs)] [z-label (in-list z-labels)] - [color (in-cycle (maybe-apply colors zs))] - [width (in-cycle (maybe-apply widths zs))] - [style (in-cycle (maybe-apply styles zs))]) + [color (in-cycle* (maybe-apply colors zs))] + [width (in-cycle* (maybe-apply widths zs))] + [style (in-cycle* (maybe-apply styles zs))]) (assoc-cons hash (list color width style) z-label))) (reverse @@ -72,11 +72,11 @@ (define digits (digits-for-range z-min z-max)) (define hash (for/fold ([hash empty]) ([z (in-list zs)] - [color (in-cycle (maybe-apply colors zs))] - [style (in-cycle (maybe-apply styles zs))] - [line-color (in-cycle (maybe-apply line-colors zs))] - [line-width (in-cycle (maybe-apply line-widths zs))] - [line-style (in-cycle (maybe-apply line-styles zs))]) + [color (in-cycle* (maybe-apply colors zs))] + [style (in-cycle* (maybe-apply styles zs))] + [line-color (in-cycle* (maybe-apply line-colors zs))] + [line-width (in-cycle* (maybe-apply line-widths zs))] + [line-style (in-cycle* (maybe-apply line-styles zs))]) (define entry-label (real->plot-label z digits)) (assoc-cons hash (list color style line-color line-width line-style) entry-label))) @@ -126,17 +126,17 @@ ) (listof legend-entry?) (define hash (for/fold ([hash empty]) ([ivl-label (in-list ivl-labels)] - [color (in-cycle (maybe-apply colors ivls))] - [style (in-cycle (maybe-apply styles ivls))] - [line-color (in-cycle (maybe-apply line-colors ivls))] - [line-width (in-cycle (maybe-apply line-widths ivls))] - [line-style (in-cycle (maybe-apply line-styles ivls))] - [line1-color (in-cycle (maybe-apply line1-colors ivls))] - [line1-width (in-cycle (maybe-apply line1-widths ivls))] - [line1-style (in-cycle (maybe-apply line1-styles ivls))] - [line2-color (in-cycle (maybe-apply line2-colors ivls))] - [line2-width (in-cycle (maybe-apply line2-widths ivls))] - [line2-style (in-cycle (maybe-apply line2-styles ivls))]) + [color (in-cycle* (maybe-apply colors ivls))] + [style (in-cycle* (maybe-apply styles ivls))] + [line-color (in-cycle* (maybe-apply line-colors ivls))] + [line-width (in-cycle* (maybe-apply line-widths ivls))] + [line-style (in-cycle* (maybe-apply line-styles ivls))] + [line1-color (in-cycle* (maybe-apply line1-colors ivls))] + [line1-width (in-cycle* (maybe-apply line1-widths ivls))] + [line1-style (in-cycle* (maybe-apply line1-styles ivls))] + [line2-color (in-cycle* (maybe-apply line2-colors ivls))] + [line2-width (in-cycle* (maybe-apply line2-widths ivls))] + [line2-style (in-cycle* (maybe-apply line2-styles ivls))]) (assoc-cons hash (list color style line-color line-width line-style line1-color line1-width line1-style diff --git a/pkgs/plot-pkgs/plot-lib/plot/private/common/utils.rkt b/pkgs/plot-pkgs/plot-lib/plot/private/common/utils.rkt index 8dc20db8e0..046ded3d92 100644 --- a/pkgs/plot-pkgs/plot-lib/plot/private/common/utils.rkt +++ b/pkgs/plot-pkgs/plot-lib/plot/private/common/utils.rkt @@ -6,6 +6,10 @@ (provide (all-defined-out)) +(define (in-cycle* s) + (define n (sequence-length s)) + (if (zero? n) empty-sequence (in-cycle s))) + (define (sequence-take seq start end) (for/list ([e (sequence-tail seq start)] [_ (in-range (- end start))]) diff --git a/pkgs/plot-pkgs/plot-lib/plot/private/plot2d/contour.rkt b/pkgs/plot-pkgs/plot-lib/plot/private/plot2d/contour.rkt index d35e04673e..f9ebce8162 100644 --- a/pkgs/plot-pkgs/plot-lib/plot/private/plot2d/contour.rkt +++ b/pkgs/plot-pkgs/plot-lib/plot/private/plot2d/contour.rkt @@ -64,24 +64,22 @@ (match-define (list (tick zs _ labels) ...) (contour-ticks (plot-z-ticks) z-min z-max levels #f)) - ;; 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)]) - (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)))))) + (let* ([colors (maybe-apply colors zs)] + [widths (maybe-apply widths zs)] + [styles (maybe-apply styles zs)] + [alphas (maybe-apply alphas 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]))) @@ -135,9 +133,9 @@ [alphas (maybe-apply alphas z-ivls)]) (for ([za (in-list zs)] [zb (in-list (rest zs))] - [color (in-cycle colors)] - [style (in-cycle styles)] - [alpha (in-cycle alphas)]) + [color (in-cycle* colors)] + [style (in-cycle* styles)] + [alpha (in-cycle* alphas)]) (send area put-brush color style) (send area put-alpha alpha) (for-2d-sample @@ -150,11 +148,11 @@ (define n (- (length zs) 2)) (define contour-colors* - (append (list 0) (sequence-take (in-cycle (maybe-apply contour-colors zs)) 0 n) (list 0))) + (append (list 0) (sequence-take (in-cycle* (maybe-apply contour-colors zs)) 0 n) (list 0))) (define contour-widths* - (append (list 0) (sequence-take (in-cycle (maybe-apply contour-widths zs)) 0 n) (list 0))) + (append (list 0) (sequence-take (in-cycle* (maybe-apply contour-widths zs)) 0 n) (list 0))) (define contour-styles* - (append '(transparent) (sequence-take (in-cycle (maybe-apply contour-styles zs)) 0 n) + (append '(transparent) (sequence-take (in-cycle* (maybe-apply contour-styles zs)) 0 n) '(transparent))) (cond [label (interval-legend-entries diff --git a/pkgs/plot-pkgs/plot-lib/plot/private/plot2d/rectangle.rkt b/pkgs/plot-pkgs/plot-lib/plot/private/plot2d/rectangle.rkt index 35f7d5399f..0db9d9ed56 100644 --- a/pkgs/plot-pkgs/plot-lib/plot/private/plot2d/rectangle.rkt +++ b/pkgs/plot-pkgs/plot-lib/plot/private/plot2d/rectangle.rkt @@ -180,13 +180,13 @@ (ivl y1 y2)))) (define max-num (apply max (map length yss))) (for/list ([y-ivls (in-list (transpose y-ivlss))] - [color (in-cycle (maybe-apply colors max-num))] - [style (in-cycle (maybe-apply styles max-num))] - [line-color (in-cycle (maybe-apply line-colors max-num))] - [line-width (in-cycle (maybe-apply line-widths max-num))] - [line-style (in-cycle (maybe-apply line-styles max-num))] - [alpha (in-cycle (maybe-apply alphas max-num))] - [label (in-cycle (maybe-apply labels max-num))]) + [color (in-cycle* (maybe-apply colors max-num))] + [style (in-cycle* (maybe-apply styles max-num))] + [line-color (in-cycle* (maybe-apply line-colors max-num))] + [line-width (in-cycle* (maybe-apply line-widths max-num))] + [line-style (in-cycle* (maybe-apply line-styles max-num))] + [alpha (in-cycle* (maybe-apply alphas max-num))] + [label (in-cycle* (maybe-apply labels max-num))]) (discrete-histogram (map vector cats y-ivls) #:x-min x-min #:x-max x-max #:y-min y-min #:y-max y-max diff --git a/pkgs/plot-pkgs/plot-lib/plot/private/plot3d/contour.rkt b/pkgs/plot-pkgs/plot-lib/plot/private/plot3d/contour.rkt index 66944701ec..c8b4910657 100644 --- a/pkgs/plot-pkgs/plot-lib/plot/private/plot3d/contour.rkt +++ b/pkgs/plot-pkgs/plot-lib/plot/private/plot3d/contour.rkt @@ -70,10 +70,10 @@ [styles (maybe-apply styles zs)] [alphas (maybe-apply alphas zs)]) (for ([z (in-list zs)] - [color (in-cycle colors)] - [width (in-cycle widths)] - [style (in-cycle styles)] - [alpha (in-cycle alphas)]) + [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 @@ -138,12 +138,12 @@ [line-styles (maybe-apply line-styles z-ivls)]) (for ([za (in-list zs)] [zb (in-list (rest zs))] - [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)]) + [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-pen line-color line-width line-style) (send area put-brush color style) @@ -164,11 +164,11 @@ (define n (- (length zs) 2)) (define contour-colors* - (append (list 0) (sequence-take (in-cycle (maybe-apply contour-colors zs)) 0 n) (list 0))) + (append (list 0) (sequence-take (in-cycle* (maybe-apply contour-colors zs)) 0 n) (list 0))) (define contour-widths* - (append (list 0) (sequence-take (in-cycle (maybe-apply contour-widths zs)) 0 n) (list 0))) + (append (list 0) (sequence-take (in-cycle* (maybe-apply contour-widths zs)) 0 n) (list 0))) (define contour-styles* - (append '(transparent) (sequence-take (in-cycle (maybe-apply contour-styles zs)) 0 n) + (append '(transparent) (sequence-take (in-cycle* (maybe-apply contour-styles zs)) 0 n) '(transparent))) (cond [label (interval-legend-entries diff --git a/pkgs/plot-pkgs/plot-lib/plot/private/plot3d/isosurface.rkt b/pkgs/plot-pkgs/plot-lib/plot/private/plot3d/isosurface.rkt index 7739d32c1a..81a5570bc0 100644 --- a/pkgs/plot-pkgs/plot-lib/plot/private/plot3d/isosurface.rkt +++ b/pkgs/plot-pkgs/plot-lib/plot/private/plot3d/isosurface.rkt @@ -2,7 +2,8 @@ (require racket/class racket/match racket/list racket/flonum racket/contract racket/math unstable/latent-contract/defthing - plot/utils) + plot/utils + "../common/utils.rkt") (provide (all-defined-out)) @@ -74,28 +75,26 @@ (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)]) - (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 - (for ([vs (in-list (heights->cube-polys xa xb ya yb za zb d d1 d2 d3 d4 d5 d6 d7 d8))]) - (send area put-polygon vs)))))) + (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)]) + (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 + (for ([vs (in-list (heights->cube-polys xa xb ya yb za zb d d1 d2 d3 d4 d5 d6 d7 d8))]) + (send area put-polygon vs))))) (cond [(and label (not (empty? ds))) (rectangle-legend-entries diff --git a/pkgs/plot-pkgs/plot-lib/plot/private/plot3d/rectangle.rkt b/pkgs/plot-pkgs/plot-lib/plot/private/plot3d/rectangle.rkt index 76949f640e..e6dec83e6b 100644 --- a/pkgs/plot-pkgs/plot-lib/plot/private/plot3d/rectangle.rkt +++ b/pkgs/plot-pkgs/plot-lib/plot/private/plot3d/rectangle.rkt @@ -174,13 +174,13 @@ (ivl z1 z2)))) (define max-num (apply max (map length zss))) (for/list ([z-ivls (in-list (transpose z-ivlss))] - [color (in-cycle (maybe-apply colors max-num))] - [style (in-cycle (maybe-apply styles max-num))] - [line-color (in-cycle (maybe-apply line-colors max-num))] - [line-width (in-cycle (maybe-apply line-widths max-num))] - [line-style (in-cycle (maybe-apply line-styles max-num))] - [alpha (in-cycle (maybe-apply alphas max-num))] - [label (in-cycle (maybe-apply labels max-num))]) + [color (in-cycle* (maybe-apply colors max-num))] + [style (in-cycle* (maybe-apply styles max-num))] + [line-color (in-cycle* (maybe-apply line-colors max-num))] + [line-width (in-cycle* (maybe-apply line-widths max-num))] + [line-style (in-cycle* (maybe-apply line-styles max-num))] + [alpha (in-cycle* (maybe-apply alphas max-num))] + [label (in-cycle* (maybe-apply labels max-num))]) (discrete-histogram3d (map vector cat1s cat2s z-ivls) #:x-min x-min #:x-max x-max #:y-min y-min #:y-max y-max #:z-min z-min #:z-max z-max #:gap gap diff --git a/pkgs/plot-pkgs/plot-test/plot/tests/plot3d-tests.rkt b/pkgs/plot-pkgs/plot-test/plot/tests/plot3d-tests.rkt index 4b4f398c0c..7b86246746 100644 --- a/pkgs/plot-pkgs/plot-test/plot/tests/plot3d-tests.rkt +++ b/pkgs/plot-pkgs/plot-test/plot/tests/plot3d-tests.rkt @@ -4,6 +4,7 @@ ;(plot-new-window? #t) +(printf "The following two plots should be empty:~n") (time (plot3d empty #:x-min -1 #:x-max 1 #:y-min -1 #:y-max 1 #:z-min -1 #:z-max 1)) diff --git a/pkgs/plot-pkgs/plot-test/plot/tests/termination-tests.rkt b/pkgs/plot-pkgs/plot-test/plot/tests/termination-tests.rkt new file mode 100644 index 0000000000..51c5ee4cb2 --- /dev/null +++ b/pkgs/plot-pkgs/plot-test/plot/tests/termination-tests.rkt @@ -0,0 +1,18 @@ +#lang racket + +;; These tests pass when they terminate + +(require plot) + +(printf "The following three plots should be blank:~n") +(plot (contour-intervals * -1 1 -1 1 #:alphas '())) +(plot3d (contour-intervals3d * -1 1 -1 1 #:alphas '())) +(plot3d (isosurfaces3d * -1 1 -1 1 -1 1 #:alphas '())) + +(with-handlers ([exn? (λ (_) (void))]) + (plot (stacked-histogram (list (vector 'a 1)) + #:alphas '()))) + +(with-handlers ([exn? (λ (_) (void))]) + (plot3d (stacked-histogram3d (list (vector 'a 'a 1)) + #:alphas '())))