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

Added the fannkuch-redux benchmark, which replaced fannkuch on the

Browse Source 
shootout roster.
This commit is contained in:
Vincent St-Amour 2010-06-17 14:48:15 -04:00
parent ecb614849c
commit ffad1edd7a
6 changed files with 129 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
collects/tests/racket/benchmarks/shootout/auto.rkt
View File

@ -117,6 +117,7 @@ exec racket -qu "$0" ${1+"$@"}
echo
except
fannkuch
fannkuch-redux
fasta
fibo
hash

59
collects/tests/racket/benchmarks/shootout/fannkuch-redux.rkt Normal file
View File

@ -0,0 +1,59 @@
#lang racket/base
;; 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
(require racket/cmdline)
(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])
(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)
(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)))
(command-line #:args (n)
(printf "Pfannkuchen(~a) = ~a\n"
n
(fannkuch (string->number n))))

1
collects/tests/racket/benchmarks/shootout/run.rkt
View File

@ -11,6 +11,7 @@
("echo" "200000")
("except" "2000000")
("fannkuch" "10")
("fannkuch-redux" "10")
("fasta" "1000000")
("fibo" "40")
("hash" "2000000")

2
collects/tests/racket/benchmarks/shootout/typed/fannkuch-redux-non-optimizing.rkt Normal file
View File

@ -0,0 +1,2 @@
(module fannkuch-redux-non-optimizing "wrap-typed-non-optimizing.ss")

2
collects/tests/racket/benchmarks/shootout/typed/fannkuch-redux-optimizing.rkt Normal file
View File

@ -0,0 +1,2 @@
(module fannkuch-redux-optimizing "wrap-typed-optimizing.ss")

64
collects/tests/racket/benchmarks/shootout/typed/fannkuch-redux.rktl Normal file
View File

@ -0,0 +1,64 @@
;; 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
;; Ported to Typed Scheme by Vincent
(require racket/cmdline)
(: fannkuch (Integer -> Integer))
(define (fannkuch n)
(let ([pi (list->vector
(for/list: : (Listof Integer) ([i : Integer (in-range n)]) i))]
[tmp (make-vector n)]
[count (make-vector n)])
(let: loop : Integer
([flips : Integer 0]
[perms : Integer 0]
[r : Integer n])
(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)]))))))))
(: count-flips ((Vectorof Integer) (Vectorof Integer) -> Integer))
(define (count-flips pi rho)
(vector-copy! rho 0 pi)
(let: loop : Integer ([i : Integer 0])
(if (= (vector-ref rho 0) 0)
i
(begin
(vector-reverse-slice! rho 0 (add1 (vector-ref rho 0)))
(loop (add1 i))))))
(: vector-reverse-slice! (All (X) ((Vectorof X) Integer Integer -> Void)))
(define (vector-reverse-slice! v i j)
(let: loop : Void
([i : Integer i]
[j : Integer (sub1 j)])
(when (> j i)
(vector-swap! v i j)
(loop (add1 i) (sub1 j)))))
(: vector-swap! (All (X) ((Vectorof X) Integer Integer -> Void)))
(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)))
(command-line #:args (n)
(printf "Pfannkuchen(~a) = ~a\n"
n
(fannkuch (assert (string->number (assert n string?)) exact-nonnegative-integer?))))