diff --git a/collects/tests/mzscheme/benchmarks/shootout/chameneos.ss b/collects/tests/mzscheme/benchmarks/shootout/chameneos.ss index 52ef341eb2..72689b677c 100644 --- a/collects/tests/mzscheme/benchmarks/shootout/chameneos.ss +++ b/collects/tests/mzscheme/benchmarks/shootout/chameneos.ss @@ -14,9 +14,9 @@ [(blue) (case c2 [(yellow) 'red] [(red) 'yellow] [else c1])])) -(for* ([a '(blue red yellow)] - [b '(blue red yellow)]) - (printf "~a + ~a -> ~a\n" a b (change a b))) +(let ([colors '(blue red yellow)]) + (for* ([a colors][b colors]) + (printf "~a + ~a -> ~a\n" a b (change a b)))) (define (place meeting-ch n) (thread diff --git a/collects/tests/mzscheme/benchmarks/shootout/fannkuch.ss b/collects/tests/mzscheme/benchmarks/shootout/fannkuch.ss index 987bb48914..f2ec465b88 100644 --- a/collects/tests/mzscheme/benchmarks/shootout/fannkuch.ss +++ b/collects/tests/mzscheme/benchmarks/shootout/fannkuch.ss @@ -1,80 +1,61 @@ -#!/usr/bin/mzscheme -qu ;; fannkuch benchmark for The Computer Language Shootout ;; Written by Dima Dorfman, 2004 ;; Slightly improved by Sven Hartrumpf, 2005-2006 -;; ;; Ever-so-slightly tweaked for MzScheme by Brent Fulgham +;; PLT-ized for v4.0 by Matthew #lang scheme/base (require scheme/cmdline) -(define vector-for-each (lambda (pred v) - (do ((i 0 (add1 i)) - (v-length (vector-length v))) - ((>= i v-length)) - (pred (vector-ref v i))))) +(define (fannkuch n) + (let ([pi (list->vector + (for/list ([i (in-range n)]) i))] + [tmp (make-vector n)] + [count (make-vector n)]) + (let loop ([flips 0] + [perms 0] + [r n]) + (when (< perms 30) + (for ([x (in-vector pi)]) + (display (add1 x))) + (newline)) + (for ([i (in-range r)]) + (vector-set! count i (add1 i))) + (let ((flips2 (max (count-flips pi tmp) flips))) + (let loop2 ([r 1]) + (if (= r n) + flips2 + (let ((perm0 (vector-ref pi 0))) + (for ([i (in-range r)]) + (vector-set! pi i (vector-ref pi (add1 i)))) + (vector-set! pi r perm0) + (vector-set! count r (sub1 (vector-ref count r))) + (cond + [(<= (vector-ref count r) 0) + (loop2 (add1 r))] + [else (loop flips2 (add1 perms) r)])))))))) + +(define (count-flips pi rho) + (vector-copy! rho 0 pi) + (let loop ([i 0]) + (if (= (vector-ref rho 0) 0) + i + (begin + (vector-reverse-slice! rho 0 (add1 (vector-ref rho 0))) + (loop (add1 i)))))) (define (vector-reverse-slice! v i j) - (do ((i i (add1 i)) - (j (sub1 j) (sub1 j))) ; exclude position j - ((<= j i)) - (vector-swap! v i j))) + (let loop ([i i] + [j (sub1 j)]) + (when (> j i) + (vector-swap! v i j) + (loop (add1 i) (sub1 j))))) (define (vector-swap! v i j) (let ((t (vector-ref v i))) (vector-set! v i (vector-ref v j)) (vector-set! v j t))) -(define (count-flips pi) - (do ((rho (vector-copy pi)) - (i 0 (add1 i))) - ((= (vector-ref rho 0) 0) i) - (vector-reverse-slice! rho 0 (add1 (vector-ref rho 0))))) - -(define (vector-copy source) - (let ([vec (make-vector (vector-length source))]) - (vector-copy! vec 0 source) - vec)) - -(define (fannkuch n) - (let ((pi (do ((pi (make-vector n)) - (i 0 (add1 i))) - ((= i n) pi) - (vector-set! pi i i))) - (r n) - (count (make-vector n))) - (let loop ((flips 0) - (perms 0)) - (cond ((< perms 30) - (vector-for-each (lambda (x) - (display (add1 x))) - pi) - (newline))) - (do () - ((= r 1)) - (vector-set! count (sub1 r) r) - (set! r (sub1 r))) - (let ((flips2 (max (count-flips pi) flips))) - (let ((result - (let loop2 () - (if (= r n) - flips2 - (let ((perm0 (vector-ref pi 0))) - (do ((i 0)) - ((>= i r)) - (let ((j (add1 i))) - (vector-set! pi i (vector-ref pi j)) - (set! i j))) - (vector-set! pi r perm0) - (vector-set! count r (sub1 (vector-ref count r))) - (cond ((<= (vector-ref count r) 0) - (set! r (add1 r)) - (loop2)) - (else - #f))))))) - (or result - (loop flips2 (add1 perms)))))))) - (command-line #:args (n) (printf "Pfannkuchen(~a) = ~a\n" n diff --git a/collects/tests/mzscheme/benchmarks/shootout/fasta.ss b/collects/tests/mzscheme/benchmarks/shootout/fasta.ss index 1f60ba32a1..0cab52428b 100644 --- a/collects/tests/mzscheme/benchmarks/shootout/fasta.ss +++ b/collects/tests/mzscheme/benchmarks/shootout/fasta.ss @@ -46,11 +46,9 @@ (define (make-cumulative-table frequency-table) (let ([cumulative 0.0]) - (map - (lambda (x) - (set! cumulative (+ cumulative (cdr x))) - (cons (char->integer (car x)) cumulative)) - frequency-table))) + (for/list ([x frequency-table]) + (set! cumulative (+ cumulative (cdr x))) + (cons (char->integer (car x)) cumulative)))) ;; ------------- @@ -61,12 +59,10 @@ (define (select-random cumulative-table) (let ((rvalue (random-next 1.0))) - (select-over-threshold rvalue cumulative-table))) - -(define (select-over-threshold rvalue table) - (if (<= rvalue (cdar table)) - (caar table) - (select-over-threshold rvalue (cdr table)))) + (let select-over-threshold ([table cumulative-table]) + (if (<= rvalue (cdar table)) + (caar table) + (select-over-threshold (cdr table)))))) ;; ------------- @@ -93,13 +89,10 @@ (display (string-append +segmarker+ id " " desc "\n") out) (let loop-o ((n n_)) (unless (<= n 0) - (let ((m (min n line-length))) - (let loop-i ((i 0)) - (unless (>= i m) - (write-byte (select-random cumulative-table) out) - (loop-i (add1 i)))) - (newline out) - (loop-o (- n line-length))))))) + (for ([i (in-range (min n line-length))]) + (write-byte (select-random cumulative-table) out)) + (newline out) + (loop-o (- n line-length)))))) ;; -------------------------------