suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Replace `in-cycle' with a version that checks for emptiness and doesn't loop forever

Browse Source 
Closes PR13620
This commit is contained in:
Neil Toronto 2014-04-04 20:54:59 -06:00
parent d687865556
commit 191ed1cedd
9 changed files with 113 additions and 93 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

38
pkgs/plot-pkgs/plot-lib/plot/private/common/legend.rkt
View File

@ -34,9 +34,9 @@
(define hash (define hash
(for/fold ([hash empty]) ([z (in-list zs)] (for/fold ([hash empty]) ([z (in-list zs)]
[z-label (in-list z-labels)] [z-label (in-list z-labels)]
[color (in-cycle (maybe-apply colors zs))] [color (in-cycle* (maybe-apply colors zs))]
[width (in-cycle (maybe-apply widths zs))] [width (in-cycle* (maybe-apply widths zs))]
[style (in-cycle (maybe-apply styles zs))]) [style (in-cycle* (maybe-apply styles zs))])
(assoc-cons hash (list color width style) z-label))) (assoc-cons hash (list color width style) z-label)))
(reverse (reverse
@ -72,11 +72,11 @@
(define digits (digits-for-range z-min z-max)) (define digits (digits-for-range z-min z-max))
(define hash (define hash
(for/fold ([hash empty]) ([z (in-list zs)] (for/fold ([hash empty]) ([z (in-list zs)]
[color (in-cycle (maybe-apply colors zs))] [color (in-cycle* (maybe-apply colors zs))]
[style (in-cycle (maybe-apply styles zs))] [style (in-cycle* (maybe-apply styles zs))]
[line-color (in-cycle (maybe-apply line-colors zs))] [line-color (in-cycle* (maybe-apply line-colors zs))]
[line-width (in-cycle (maybe-apply line-widths zs))] [line-width (in-cycle* (maybe-apply line-widths zs))]
[line-style (in-cycle (maybe-apply line-styles zs))]) [line-style (in-cycle* (maybe-apply line-styles zs))])
(define entry-label (real->plot-label z digits)) (define entry-label (real->plot-label z digits))
(assoc-cons hash (list color style line-color line-width line-style) entry-label))) (assoc-cons hash (list color style line-color line-width line-style) entry-label)))
@ -126,17 +126,17 @@
) (listof legend-entry?) ) (listof legend-entry?)
(define hash (define hash
(for/fold ([hash empty]) ([ivl-label (in-list ivl-labels)] (for/fold ([hash empty]) ([ivl-label (in-list ivl-labels)]
[color (in-cycle (maybe-apply colors ivls))] [color (in-cycle* (maybe-apply colors ivls))]
[style (in-cycle (maybe-apply styles ivls))] [style (in-cycle* (maybe-apply styles ivls))]
[line-color (in-cycle (maybe-apply line-colors ivls))] [line-color (in-cycle* (maybe-apply line-colors ivls))]
[line-width (in-cycle (maybe-apply line-widths ivls))] [line-width (in-cycle* (maybe-apply line-widths ivls))]
[line-style (in-cycle (maybe-apply line-styles ivls))] [line-style (in-cycle* (maybe-apply line-styles ivls))]
[line1-color (in-cycle (maybe-apply line1-colors ivls))] [line1-color (in-cycle* (maybe-apply line1-colors ivls))]
[line1-width (in-cycle (maybe-apply line1-widths ivls))] [line1-width (in-cycle* (maybe-apply line1-widths ivls))]
[line1-style (in-cycle (maybe-apply line1-styles ivls))] [line1-style (in-cycle* (maybe-apply line1-styles ivls))]
[line2-color (in-cycle (maybe-apply line2-colors ivls))] [line2-color (in-cycle* (maybe-apply line2-colors ivls))]
[line2-width (in-cycle (maybe-apply line2-widths ivls))] [line2-width (in-cycle* (maybe-apply line2-widths ivls))]
[line2-style (in-cycle (maybe-apply line2-styles ivls))]) [line2-style (in-cycle* (maybe-apply line2-styles ivls))])
(assoc-cons hash (assoc-cons hash
(list color style line-color line-width line-style (list color style line-color line-width line-style
line1-color line1-width line1-style line1-color line1-width line1-style

4
pkgs/plot-pkgs/plot-lib/plot/private/common/utils.rkt
View File

@ -6,6 +6,10 @@
(provide (all-defined-out)) (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) (define (sequence-take seq start end)
(for/list ([e (sequence-tail seq start)] (for/list ([e (sequence-tail seq start)]
[_ (in-range (- end start))]) [_ (in-range (- end start))])

24
pkgs/plot-pkgs/plot-lib/plot/private/plot2d/contour.rkt
View File

@ -64,24 +64,22 @@
(match-define (list (tick zs _ labels) ...) (contour-ticks (plot-z-ticks) z-min z-max levels #f)) (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)] (let* ([colors (maybe-apply colors zs)]
[widths (maybe-apply widths zs)] [widths (maybe-apply widths zs)]
[styles (maybe-apply styles zs)] [styles (maybe-apply styles zs)]
[alphas (maybe-apply alphas zs)]) [alphas (maybe-apply alphas zs)])
(for ([z (in-list zs)] (for ([z (in-list zs)]
[color (in-cycle colors)] [color (in-cycle* colors)]
[width (in-cycle widths)] [width (in-cycle* widths)]
[style (in-cycle styles)] [style (in-cycle* styles)]
[alpha (in-cycle alphas)]) [alpha (in-cycle* alphas)])
(send area put-alpha alpha) (send area put-alpha alpha)
(send area put-pen color width style) (send area put-pen color width style)
(for-2d-sample (for-2d-sample
(xa xb ya yb z1 z2 z3 z4) 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))]) (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)) (match-define (list v1 v2) (map (λ (v) (vector-take v 2)) line))
(send area put-line v1 v2)))))) (send area put-line v1 v2)))))
(cond [(and label (not (empty? zs))) (line-legend-entries label zs labels colors widths styles)] (cond [(and label (not (empty? zs))) (line-legend-entries label zs labels colors widths styles)]
[else empty]))) [else empty])))
@ -135,9 +133,9 @@
[alphas (maybe-apply alphas z-ivls)]) [alphas (maybe-apply alphas z-ivls)])
(for ([za (in-list zs)] (for ([za (in-list zs)]
[zb (in-list (rest zs))] [zb (in-list (rest zs))]
[color (in-cycle colors)] [color (in-cycle* colors)]
[style (in-cycle styles)] [style (in-cycle* styles)]
[alpha (in-cycle alphas)]) [alpha (in-cycle* alphas)])
(send area put-brush color style) (send area put-brush color style)
(send area put-alpha alpha) (send area put-alpha alpha)
(for-2d-sample (for-2d-sample
@ -150,11 +148,11 @@
(define n (- (length zs) 2)) (define n (- (length zs) 2))
(define contour-colors* (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* (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* (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))) '(transparent)))
(cond [label (interval-legend-entries (cond [label (interval-legend-entries

14
pkgs/plot-pkgs/plot-lib/plot/private/plot2d/rectangle.rkt
View File

@ -180,13 +180,13 @@
(ivl y1 y2)))) (ivl y1 y2))))
(define max-num (apply max (map length yss))) (define max-num (apply max (map length yss)))
(for/list ([y-ivls (in-list (transpose y-ivlss))] (for/list ([y-ivls (in-list (transpose y-ivlss))]
[color (in-cycle (maybe-apply colors max-num))] [color (in-cycle* (maybe-apply colors max-num))]
[style (in-cycle (maybe-apply styles max-num))] [style (in-cycle* (maybe-apply styles max-num))]
[line-color (in-cycle (maybe-apply line-colors max-num))] [line-color (in-cycle* (maybe-apply line-colors max-num))]
[line-width (in-cycle (maybe-apply line-widths max-num))] [line-width (in-cycle* (maybe-apply line-widths max-num))]
[line-style (in-cycle (maybe-apply line-styles max-num))] [line-style (in-cycle* (maybe-apply line-styles max-num))]
[alpha (in-cycle (maybe-apply alphas max-num))] [alpha (in-cycle* (maybe-apply alphas max-num))]
[label (in-cycle (maybe-apply labels max-num))]) [label (in-cycle* (maybe-apply labels max-num))])
(discrete-histogram (discrete-histogram
(map vector cats y-ivls) (map vector cats y-ivls)
#:x-min x-min #:x-max x-max #:y-min y-min #:y-max y-max #:x-min x-min #:x-max x-max #:y-min y-min #:y-max y-max

26
pkgs/plot-pkgs/plot-lib/plot/private/plot3d/contour.rkt
View File

@ -70,10 +70,10 @@
[styles (maybe-apply styles zs)] [styles (maybe-apply styles zs)]
[alphas (maybe-apply alphas zs)]) [alphas (maybe-apply alphas zs)])
(for ([z (in-list zs)] (for ([z (in-list zs)]
[color (in-cycle colors)] [color (in-cycle* colors)]
[width (in-cycle widths)] [width (in-cycle* widths)]
[style (in-cycle styles)] [style (in-cycle* styles)]
[alpha (in-cycle alphas)]) [alpha (in-cycle* alphas)])
(send area put-alpha alpha) (send area put-alpha alpha)
(send area put-pen color width style) (send area put-pen color width style)
(for-2d-sample (for-2d-sample
@ -138,12 +138,12 @@
[line-styles (maybe-apply line-styles z-ivls)]) [line-styles (maybe-apply line-styles z-ivls)])
(for ([za (in-list zs)] (for ([za (in-list zs)]
[zb (in-list (rest zs))] [zb (in-list (rest zs))]
[color (in-cycle colors)] [color (in-cycle* colors)]
[style (in-cycle styles)] [style (in-cycle* styles)]
[alpha (in-cycle alphas)] [alpha (in-cycle* alphas)]
[line-color (in-cycle line-colors)] [line-color (in-cycle* line-colors)]
[line-width (in-cycle line-widths)] [line-width (in-cycle* line-widths)]
[line-style (in-cycle line-styles)]) [line-style (in-cycle* line-styles)])
(send area put-alpha alpha) (send area put-alpha alpha)
(send area put-pen line-color line-width line-style) (send area put-pen line-color line-width line-style)
(send area put-brush color style) (send area put-brush color style)
@ -164,11 +164,11 @@
(define n (- (length zs) 2)) (define n (- (length zs) 2))
(define contour-colors* (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* (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* (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))) '(transparent)))
(cond [label (interval-legend-entries (cond [label (interval-legend-entries

19
pkgs/plot-pkgs/plot-lib/plot/private/plot3d/isosurface.rkt
View File

@ -2,7 +2,8 @@
(require racket/class racket/match racket/list racket/flonum racket/contract racket/math (require racket/class racket/match racket/list racket/flonum racket/contract racket/math
unstable/latent-contract/defthing unstable/latent-contract/defthing
plot/utils) plot/utils
"../common/utils.rkt")
(provide (all-defined-out)) (provide (all-defined-out))
@ -74,8 +75,6 @@
(cond [(and d-min d-max) (contour-ticks (plot-d-ticks) d-min d-max levels #f)] (cond [(and d-min d-max) (contour-ticks (plot-d-ticks) d-min d-max levels #f)]
[else empty])) [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)] (let* ([colors (maybe-apply colors ds)]
[styles (maybe-apply styles ds)] [styles (maybe-apply styles ds)]
[alphas (maybe-apply alphas ds)] [alphas (maybe-apply alphas ds)]
@ -83,19 +82,19 @@
[line-widths (maybe-apply line-widths ds)] [line-widths (maybe-apply line-widths ds)]
[line-styles (maybe-apply line-styles ds)]) [line-styles (maybe-apply line-styles ds)])
(for ([d (in-list ds)] (for ([d (in-list ds)]
[color (in-cycle colors)] [color (in-cycle* colors)]
[style (in-cycle styles)] [style (in-cycle* styles)]
[alpha (in-cycle alphas)] [alpha (in-cycle* alphas)]
[line-color (in-cycle line-colors)] [line-color (in-cycle* line-colors)]
[line-width (in-cycle line-widths)] [line-width (in-cycle* line-widths)]
[line-style (in-cycle line-styles)]) [line-style (in-cycle* line-styles)])
(send area put-alpha alpha) (send area put-alpha alpha)
(send area put-brush color style) (send area put-brush color style)
(send area put-pen line-color line-width line-style) (send area put-pen line-color line-width line-style)
(for-3d-sample (for-3d-sample
(xa xb ya yb za zb d1 d2 d3 d4 d5 d6 d7 d8) 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))]) (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)))))) (send area put-polygon vs)))))
(cond (cond
[(and label (not (empty? ds))) (rectangle-legend-entries [(and label (not (empty? ds))) (rectangle-legend-entries

14
pkgs/plot-pkgs/plot-lib/plot/private/plot3d/rectangle.rkt
View File

@ -174,13 +174,13 @@
(ivl z1 z2)))) (ivl z1 z2))))
(define max-num (apply max (map length zss))) (define max-num (apply max (map length zss)))
(for/list ([z-ivls (in-list (transpose z-ivlss))] (for/list ([z-ivls (in-list (transpose z-ivlss))]
[color (in-cycle (maybe-apply colors max-num))] [color (in-cycle* (maybe-apply colors max-num))]
[style (in-cycle (maybe-apply styles max-num))] [style (in-cycle* (maybe-apply styles max-num))]
[line-color (in-cycle (maybe-apply line-colors max-num))] [line-color (in-cycle* (maybe-apply line-colors max-num))]
[line-width (in-cycle (maybe-apply line-widths max-num))] [line-width (in-cycle* (maybe-apply line-widths max-num))]
[line-style (in-cycle (maybe-apply line-styles max-num))] [line-style (in-cycle* (maybe-apply line-styles max-num))]
[alpha (in-cycle (maybe-apply alphas max-num))] [alpha (in-cycle* (maybe-apply alphas max-num))]
[label (in-cycle (maybe-apply labels max-num))]) [label (in-cycle* (maybe-apply labels max-num))])
(discrete-histogram3d (discrete-histogram3d
(map vector cat1s cat2s z-ivls) (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 #: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

1
pkgs/plot-pkgs/plot-test/plot/tests/plot3d-tests.rkt
View File

@ -4,6 +4,7 @@
;(plot-new-window? #t) ;(plot-new-window? #t)
(printf "The following two plots should be empty:~n")
(time (time
(plot3d empty #:x-min -1 #:x-max 1 #:y-min -1 #:y-max 1 #:z-min -1 #:z-max 1)) (plot3d empty #:x-min -1 #:x-max 1 #:y-min -1 #:y-max 1 #:z-min -1 #:z-max 1))

18
pkgs/plot-pkgs/plot-test/plot/tests/termination-tests.rkt Normal file
View File

@ -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 '())))