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
(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

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

@ -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))])

46
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))
;; 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

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

@ -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

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

@ -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

45
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
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

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

@ -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

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

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

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