shootout benchmarks
svn: r10839
This commit is contained in:
Matthew Flatt
parent
bba44e46e8
commit
b8672845fc
2
collects/tests/mzscheme/benchmarks/shootout/hello.ss
Normal file
2
collects/tests/mzscheme/benchmarks/shootout/hello.ss
Normal file
|
|
@ -0,0 +1,2 @@
|
|||
#lang scheme/base
|
||||
(display "hello world\n")
|
||||
|
|
@ -1,61 +1,55 @@
|
|||
;; The Computer Language Shootout
|
||||
;; http://shootout.alioth.debian.org/
|
||||
|
||||
(module k-nucleotide mzscheme
|
||||
(require mzlib/list
|
||||
mzlib/string
|
||||
(only srfi/13 string-pad-right))
|
||||
#lang scheme/base
|
||||
|
||||
(define (all-counts len dna)
|
||||
(let ([table (make-hash-table)]
|
||||
[seq (make-string len)])
|
||||
(let loop ([s (- (string-length dna) len)])
|
||||
(string-copy! seq 0 dna s (+ s len))
|
||||
(let ([key (string->symbol seq)])
|
||||
(let ([cnt (hash-table-get table key 0)])
|
||||
(hash-table-put! table key (add1 cnt))))
|
||||
(unless (zero? s)
|
||||
(loop (sub1 s))))
|
||||
table))
|
||||
(define (all-counts len dna)
|
||||
(let ([table (make-hasheq)]
|
||||
[seq (make-string len)])
|
||||
(for ([s (in-range (- (string-length dna) len) -1 -1)])
|
||||
(string-copy! seq 0 dna s (+ s len))
|
||||
(let ([key (string->symbol seq)])
|
||||
(let ([cnt (hash-ref table key 0)])
|
||||
(hash-set! table key (add1 cnt)))))
|
||||
table))
|
||||
|
||||
(define (write-freqs table)
|
||||
(let* ([content (hash-table-map table cons)]
|
||||
[total (exact->inexact (apply + (map cdr content)))])
|
||||
(for-each
|
||||
(lambda (a)
|
||||
(printf "~a ~a\n"
|
||||
(car a)
|
||||
(real->decimal-string (* 100 (/ (cdr a) total)) 3)))
|
||||
(sort content (lambda (a b) (> (cdr a) (cdr b)))))))
|
||||
(define (write-freqs table)
|
||||
(let* ([content (hash-map table cons)]
|
||||
[total (exact->inexact (apply + (map cdr content)))])
|
||||
(for-each
|
||||
(lambda (a)
|
||||
(printf "~a ~a\n"
|
||||
(car a)
|
||||
(real->decimal-string (* 100 (/ (cdr a) total)) 3)))
|
||||
(sort content (lambda (a b) (> (cdr a) (cdr b)))))))
|
||||
|
||||
(define (write-one-freq table key)
|
||||
(let ([cnt (hash-table-get table key 0)])
|
||||
(printf "~a\t~a\n" cnt key)))
|
||||
(define (write-one-freq table key)
|
||||
(let ([cnt (hash-ref table key 0)])
|
||||
(printf "~a\t~a\n" cnt key)))
|
||||
|
||||
(define dna
|
||||
(begin
|
||||
;; Skip to ">THREE ..."
|
||||
(regexp-match #rx#"(?m:^>THREE.*$)" (current-input-port))
|
||||
(let ([s (open-output-string)])
|
||||
;; Copy everything but newlines to s:
|
||||
(let loop ()
|
||||
(when (regexp-match #rx#"\n" (current-input-port) 0 #f s)
|
||||
(loop)))
|
||||
;; Extract the string from s:
|
||||
(string-upcase (get-output-string s)))))
|
||||
(define dna
|
||||
(let ([in (current-input-port)])
|
||||
;; Skip to ">THREE ..."
|
||||
(regexp-match #rx#"(?m:^>THREE.*$)" in)
|
||||
(let ([s (open-output-string)])
|
||||
;; Copy everything but newlines to s:
|
||||
(let loop ()
|
||||
(when (regexp-match #rx#"\n" in 0 #f s)
|
||||
(loop)))
|
||||
;; Extract the string from s:
|
||||
(string-upcase (get-output-string s)))))
|
||||
|
||||
;; 1-nucleotide counts:
|
||||
(write-freqs (all-counts 1 dna))
|
||||
(newline)
|
||||
;; 1-nucleotide counts:
|
||||
(write-freqs (all-counts 1 dna))
|
||||
(newline)
|
||||
|
||||
;; 2-nucleotide counts:
|
||||
(write-freqs (all-counts 2 dna))
|
||||
(newline)
|
||||
;; 2-nucleotide counts:
|
||||
(write-freqs (all-counts 2 dna))
|
||||
(newline)
|
||||
|
||||
;; Specific sequences:
|
||||
(for-each (lambda (seq)
|
||||
(write-one-freq (all-counts (string-length seq) dna)
|
||||
(string->symbol seq)))
|
||||
'("GGT" "GGTA" "GGTATT" "GGTATTTTAATT" "GGTATTTTAATTTATAGT"))
|
||||
;; Specific sequences:
|
||||
(for-each (lambda (seq)
|
||||
(write-one-freq (all-counts (string-length seq) dna)
|
||||
(string->symbol seq)))
|
||||
'("GGT" "GGTA" "GGTATT" "GGTATTTTAATT" "GGTATTTTAATTTATAGT"))
|
||||
|
||||
)
|
||||
|
|
|
|||
|
|
@ -5,11 +5,8 @@
|
|||
;; Derived from the Chicken variant, which was
|
||||
;; Contributed by Anthony Borla
|
||||
|
||||
;; Note: as of version 350, this benchmark spends much of
|
||||
;; its time GCing; it runs 2 times as fast in mzscheme3m.
|
||||
|
||||
;; The version that uses complex number is a little
|
||||
;; more elegant, but slower:
|
||||
;; more elegant, but much slower:
|
||||
;; (define (mandelbrot iterations x y n ci)
|
||||
;; (let ((c (+ (- (/ (* 2.0 x) n) 1.5)
|
||||
;; (* ci 0.0+1.0i))))
|
||||
|
|
@ -19,62 +16,64 @@
|
|||
;; [(> (magnitude z) 2.0) 0]
|
||||
;; [else (loop (add1 i) (+ (* z z) c))]))))
|
||||
|
||||
#lang scheme/base
|
||||
(require scheme/cmdline)
|
||||
|
||||
(module mandelbrot mzscheme
|
||||
(define +limit-sqr+ 4.0)
|
||||
|
||||
;; -------------------------------
|
||||
|
||||
(define +limit-sqr+ 4.0)
|
||||
(define +iterations+ 50)
|
||||
|
||||
(define +iterations+ 50)
|
||||
;; -------------------------------
|
||||
|
||||
;; -------------------------------
|
||||
|
||||
(define (mandelbrot iterations x y n ci)
|
||||
(let ((cr (- (/ (* 2.0 x) n) 1.5)))
|
||||
(let loop ((i 0) (zr 0.0) (zi 0.0))
|
||||
(if (> i iterations)
|
||||
1
|
||||
(let ((zrq (* zr zr))
|
||||
(ziq (* zi zi)))
|
||||
(cond
|
||||
((> (+ zrq ziq) +limit-sqr+) 0)
|
||||
(else (loop (add1 i) (+ (- zrq ziq) cr) (+ (* 2.0 (* zr zi)) ci)))))))))
|
||||
|
||||
;; -------------------------------
|
||||
|
||||
(define (main args)
|
||||
(let ((n (string->number (vector-ref args 0)))
|
||||
(out (current-output-port)))
|
||||
(define (mandelbrot iterations x y n ci)
|
||||
(let ((cr (- (/ (* 2.0 x) n) 1.5)))
|
||||
(let loop ((i 0) (zr 0.0) (zi 0.0))
|
||||
(if (> i iterations)
|
||||
1
|
||||
(let ((zrq (* zr zr))
|
||||
(ziq (* zi zi)))
|
||||
(cond
|
||||
((> (+ zrq ziq) +limit-sqr+) 0)
|
||||
(else (loop (add1 i)
|
||||
(+ (- zrq ziq) cr)
|
||||
(+ (* 2.0 (* zr zi)) ci)))))))))
|
||||
|
||||
(fprintf out "P4\n~a ~a\n" n n)
|
||||
;; -------------------------------
|
||||
|
||||
(let loop-y ((y 0))
|
||||
(define (main n)
|
||||
(let ((out (current-output-port)))
|
||||
|
||||
(when (< y n)
|
||||
|
||||
(let ([ci (- (/ (* 2.0 y) n) 1.0)])
|
||||
|
||||
(let loop-x ((x 0) (bitnum 0) (byteacc 0))
|
||||
(fprintf out "P4\n~a ~a\n" n n)
|
||||
|
||||
(if (< x n)
|
||||
(let ([bitnum (add1 bitnum)]
|
||||
[byteacc (+ (arithmetic-shift byteacc 1)
|
||||
(mandelbrot +iterations+ x y n ci))])
|
||||
(let loop-y ((y 0))
|
||||
|
||||
(cond
|
||||
((= bitnum 8)
|
||||
(write-byte byteacc out)
|
||||
(loop-x (add1 x) 0 0))
|
||||
|
||||
[else (loop-x (add1 x) bitnum byteacc)]))
|
||||
(when (< y n)
|
||||
|
||||
(let ([ci (- (/ (* 2.0 y) n) 1.0)])
|
||||
|
||||
(let loop-x ((x 0) (bitnum 0) (byteacc 0))
|
||||
|
||||
(begin
|
||||
(when (positive? bitnum)
|
||||
(write-byte (arithmetic-shift byteacc (- 8 (bitwise-and n #x7))) out))
|
||||
(if (< x n)
|
||||
(let ([bitnum (add1 bitnum)]
|
||||
[byteacc (+ (arithmetic-shift byteacc 1)
|
||||
(mandelbrot +iterations+ x y n ci))])
|
||||
|
||||
(loop-y (add1 y))))))))))
|
||||
(cond
|
||||
((= bitnum 8)
|
||||
(write-byte byteacc out)
|
||||
(loop-x (add1 x) 0 0))
|
||||
|
||||
[else (loop-x (add1 x) bitnum byteacc)]))
|
||||
|
||||
;; -------------------------------
|
||||
|
||||
(main (current-command-line-arguments)))
|
||||
(begin
|
||||
(when (positive? bitnum)
|
||||
(write-byte (arithmetic-shift byteacc
|
||||
(- 8 (bitwise-and n #x7)))
|
||||
out))
|
||||
|
||||
(loop-y (add1 y))))))))))
|
||||
|
||||
;; -------------------------------
|
||||
|
||||
(command-line #:args (n)
|
||||
(main (string->number n)))
|
||||
|
|
@ -145,9 +145,8 @@ Correct output N = 1000 is
|
|||
(offset-momentum system)
|
||||
|
||||
(printf "~a~%" (real->decimal-string (energy system) 9))
|
||||
|
||||
(do ((i 1 (+ i 1)))
|
||||
((< n i))
|
||||
|
||||
(for ([i (in-range 0 n)])
|
||||
(advance system 0.01))
|
||||
|
||||
(printf "~a~%" (real->decimal-string (energy system) 9)))
|
||||
|
|
|
|||
|
|
@ -7,44 +7,37 @@
|
|||
;; Written by Dima Dorfman, 2004
|
||||
;; Converted to MzScheme by Brent Fulgham
|
||||
|
||||
(module nsieve mzscheme
|
||||
(require (only srfi/13 string-index string-pad))
|
||||
#lang scheme/base
|
||||
(require scheme/cmdline)
|
||||
|
||||
(define (nsieve m)
|
||||
(let ((a (make-vector m #t)))
|
||||
(let loop ((i 2) (n 0))
|
||||
(if (< i m)
|
||||
(begin
|
||||
(if (vector-ref a i)
|
||||
(begin
|
||||
(let clear ((j (+ i i)))
|
||||
(if (< j m)
|
||||
(begin
|
||||
(vector-set! a j #f)
|
||||
(clear (+ j i)))))
|
||||
(loop (+ 1 i) (+ 1 n)))
|
||||
(loop (+ 1 i) n)))
|
||||
n))))
|
||||
(define (nsieve m)
|
||||
(let ((a (make-vector m #t)))
|
||||
(let loop ((i 2) (n 0))
|
||||
(if (< i m)
|
||||
(if (vector-ref a i)
|
||||
(begin
|
||||
(let clear ((j (+ i i)))
|
||||
(when (< j m)
|
||||
(vector-set! a j #f)
|
||||
(clear (+ j i))))
|
||||
(loop (+ 1 i) (+ 1 n)))
|
||||
(loop (+ 1 i) n))
|
||||
n))))
|
||||
|
||||
(define (test n)
|
||||
(let* ((m (* (expt 2 n) 10000))
|
||||
(count (nsieve m)))
|
||||
(printf "Primes up to ~a ~a~%"
|
||||
(string-pad (number->string m) 8)
|
||||
(string-pad (number->string count) 8))))
|
||||
(define (string-pad s len)
|
||||
(string-append (make-string (- len (string-length s)) #\space)
|
||||
s))
|
||||
|
||||
(define (main args)
|
||||
(if (< (vector-length args) 1)
|
||||
(begin
|
||||
(display "An argument is required") (newline) 2)
|
||||
(let ((n (string->number (vector-ref args 0))))
|
||||
(if (not n)
|
||||
(begin
|
||||
(display "An integer is required") (newline) 2)
|
||||
(begin
|
||||
(if (>= n 0) (test n))
|
||||
(if (>= n 1) (test (- n 1)))
|
||||
(if (>= n 2) (test (- n 2)))
|
||||
0)))))
|
||||
(define (test n)
|
||||
(let* ((m (* (expt 2 n) 10000))
|
||||
(count (nsieve m)))
|
||||
(printf "Primes up to ~a ~a\n"
|
||||
(string-pad (number->string m) 8)
|
||||
(string-pad (number->string count) 8))))
|
||||
|
||||
(main (current-command-line-arguments)))
|
||||
(define (main n)
|
||||
(when (>= n 0) (test n))
|
||||
(when (>= n 1) (test (- n 1)))
|
||||
(when (>= n 2) (test (- n 2))))
|
||||
|
||||
(command-line #:args (n) (main (string->number n)))
|
||||
|
|
|
|||
|
|
@ -4,63 +4,63 @@
|
|||
;;
|
||||
;; Adapted from CMUCL code by Dima Dorfman; bit-vector stuff by Alex Shinn;
|
||||
;; cobbled together by felix, converted to MzScheme by Brent Fulgham
|
||||
;; Note: Requires MzScheme 299+
|
||||
|
||||
(module nsievebits mzscheme
|
||||
#lang scheme/base
|
||||
(require scheme/cmdline)
|
||||
|
||||
(define (make-bit-vector size)
|
||||
(let* ((len (quotient (+ size 7) 8))
|
||||
(res (make-bytes len #b11111111)))
|
||||
(let ((off (remainder size 8)))
|
||||
(unless (zero? off)
|
||||
(bytes-set! res (- len 1) (- (arithmetic-shift 1 off) 1))))
|
||||
res))
|
||||
(define (make-bit-vector size)
|
||||
(let* ((len (quotient (+ size 7) 8))
|
||||
(res (make-bytes len #b11111111)))
|
||||
(let ((off (remainder size 8)))
|
||||
(unless (zero? off)
|
||||
(bytes-set! res (- len 1) (- (arithmetic-shift 1 off) 1))))
|
||||
res))
|
||||
|
||||
(define (bit-vector-ref vec i)
|
||||
(let ((byte (arithmetic-shift i -3))
|
||||
(off (bitwise-and i #x7)))
|
||||
(and (< byte (bytes-length vec))
|
||||
(not (zero? (bitwise-and (bytes-ref vec byte)
|
||||
(arithmetic-shift 1 off)))))))
|
||||
(define (bit-vector-ref vec i)
|
||||
(let ((byte (arithmetic-shift i -3))
|
||||
(off (bitwise-and i #x7)))
|
||||
(and (< byte (bytes-length vec))
|
||||
(not (zero? (bitwise-and (bytes-ref vec byte)
|
||||
(arithmetic-shift 1 off)))))))
|
||||
|
||||
(define (bit-vector-set! vec i x)
|
||||
(let ((byte (arithmetic-shift i -3))
|
||||
(off (bitwise-and i #x7)))
|
||||
(let ((val (bytes-ref vec byte))
|
||||
(mask (arithmetic-shift 1 off)))
|
||||
(bytes-set! vec
|
||||
byte
|
||||
(if x
|
||||
(bitwise-ior val mask)
|
||||
(bitwise-and val (bitwise-not mask)))))))
|
||||
(define (bit-vector-set! vec i x)
|
||||
(let ((byte (arithmetic-shift i -3))
|
||||
(off (bitwise-and i #x7)))
|
||||
(let ((val (bytes-ref vec byte))
|
||||
(mask (arithmetic-shift 1 off)))
|
||||
(bytes-set! vec
|
||||
byte
|
||||
(if x
|
||||
(bitwise-ior val mask)
|
||||
(bitwise-and val (bitwise-not mask)))))))
|
||||
|
||||
(define (nsievebits m)
|
||||
(let ((a (make-bit-vector m)))
|
||||
(define (clear i)
|
||||
(do ([j (+ i i) (+ j i)])
|
||||
(define (nsievebits m)
|
||||
(let ((a (make-bit-vector m)))
|
||||
(define (clear i)
|
||||
(do ([j (+ i i) (+ j i)])
|
||||
((>= j m))
|
||||
(bit-vector-set! a j #f) ) )
|
||||
(let ([c 0])
|
||||
(do ([i 2 (add1 i)])
|
||||
((>= i m) c)
|
||||
(when (bit-vector-ref a i)
|
||||
(clear i)
|
||||
(set! c (add1 c)) ) ) ) ) )
|
||||
(bit-vector-set! a j #f)))
|
||||
(let ([c 0])
|
||||
(do ([i 2 (add1 i)])
|
||||
((>= i m) c)
|
||||
(when (bit-vector-ref a i)
|
||||
(clear i)
|
||||
(set! c (add1 c)))))))
|
||||
|
||||
(define (string-pad s n)
|
||||
(string-append (make-string (- n (string-length s)) #\space)
|
||||
s))
|
||||
(define (string-pad s len)
|
||||
(string-append (make-string (- len (string-length s)) #\space)
|
||||
s))
|
||||
|
||||
(define (test n)
|
||||
(let ((m (* 10000 (arithmetic-shift 1 n))))
|
||||
(printf "Primes up to ~a ~a~%"
|
||||
(string-pad (number->string m) 8)
|
||||
(string-pad (number->string (nsievebits m)) 8))))
|
||||
(define (test n)
|
||||
(let* ((m (* (expt 2 n) 10000))
|
||||
(count (nsievebits m)))
|
||||
(printf "Primes up to ~a ~a\n"
|
||||
(string-pad (number->string m) 8)
|
||||
(string-pad (number->string count) 8))))
|
||||
|
||||
(define (main args)
|
||||
(let ([n (string->number (vector-ref args 0))])
|
||||
(when (>= n 0) (test n))
|
||||
(when (>= n 1) (test (- n 1)))
|
||||
(when (>= n 2) (test (- n 2)))))
|
||||
(define (main n)
|
||||
(when (>= n 0) (test n))
|
||||
(when (>= n 1) (test (- n 1)))
|
||||
(when (>= n 2) (test (- n 2))))
|
||||
|
||||
(main (current-command-line-arguments)))
|
||||
(command-line #:args (n) (main (string->number n)))
|
||||
|
|
|
|||
|
|
@ -8,54 +8,48 @@
|
|||
;; Contributed by Anthony Borla
|
||||
;; ---------------------------------------------------------------------
|
||||
|
||||
;; Note: as of version 350, this benchmark spends much of
|
||||
;; its time GCing; it runs 1.5 times as fast in mzscheme3m.
|
||||
#lang scheme/base
|
||||
(require scheme/cmdline)
|
||||
|
||||
(module partialsums mzscheme
|
||||
(require (only mzlib/string real->decimal-string))
|
||||
(let ((n (exact->inexact
|
||||
(string->number
|
||||
(command-line #:args (n) n)))))
|
||||
|
||||
(let loop ([d 0.0]
|
||||
(alt 1) (d2 0) (d3 0) (ds 0) (dc 0)
|
||||
(s0 0) (s1 0) (s2 0) (s3 0) (s4 0) (s5 0) (s6 0) (s7 0) (s8 0))
|
||||
(if (= d n)
|
||||
(let ([format-result
|
||||
(lambda (str n)
|
||||
(printf str (real->decimal-string n 9)))])
|
||||
|
||||
(format-result "~a\t(2/3)^k\n" s0)
|
||||
(format-result "~a\tk^-0.5\n" s1)
|
||||
(format-result "~a\t1/k(k+1)\n" s2)
|
||||
(format-result "~a\tFlint Hills\n" s3)
|
||||
(format-result "~a\tCookson Hills\n" s4)
|
||||
(format-result "~a\tHarmonic\n" s5)
|
||||
(format-result "~a\tRiemann Zeta\n" s6)
|
||||
(format-result "~a\tAlternating Harmonic\n" s7)
|
||||
(format-result "~a\tGregory\n" s8))
|
||||
|
||||
(let* ((d (+ d 1))
|
||||
(d2 (* d d))
|
||||
(d3 (* d2 d))
|
||||
(ds (sin d))
|
||||
(dc (cos d))
|
||||
|
||||
(let ((n (exact->inexact
|
||||
(string->number
|
||||
(vector-ref (current-command-line-arguments) 0))))
|
||||
|
||||
(alt 1) (d2 0) (d3 0) (ds 0) (dc 0)
|
||||
(s0 0) (s1 0) (s2 0) (s3 0) (s4 0) (s5 0) (s6 0) (s7 0) (s8 0))
|
||||
|
||||
(let loop ([d 0.0]
|
||||
(alt 1) (d2 0) (d3 0) (ds 0) (dc 0)
|
||||
(s0 0) (s1 0) (s2 0) (s3 0) (s4 0) (s5 0) (s6 0) (s7 0) (s8 0))
|
||||
(if (= d n #;(+ n 1))
|
||||
(let ([format-result
|
||||
(lambda (str n)
|
||||
(printf str (real->decimal-string n 9)))])
|
||||
|
||||
(format-result "~a\t(2/3)^k\n" s0)
|
||||
(format-result "~a\tk^-0.5\n" s1)
|
||||
(format-result "~a\t1/k(k+1)\n" s2)
|
||||
(format-result "~a\tFlint Hills\n" s3)
|
||||
(format-result "~a\tCookson Hills\n" s4)
|
||||
(format-result "~a\tHarmonic\n" s5)
|
||||
(format-result "~a\tRiemann Zeta\n" s6)
|
||||
(format-result "~a\tAlternating Harmonic\n" s7)
|
||||
(format-result "~a\tGregory\n" s8))
|
||||
|
||||
(let* ((d (+ d 1))
|
||||
(d2 (* d d))
|
||||
(d3 (* d2 d))
|
||||
(ds (sin d))
|
||||
(dc (cos d))
|
||||
|
||||
(s0 (+ s0 (expt (/ 2.0 3) (- d 1))))
|
||||
(s1 (+ s1 (/ 1 (sqrt d))))
|
||||
(s2 (+ s2 (/ 1 (* d (+ d 1)))))
|
||||
(s3 (+ s3 (/ 1 (* d3 (* ds ds)))))
|
||||
(s4 (+ s4 (/ 1 (* d3 (* dc dc)))))
|
||||
(s5 (+ s5 (/ 1 d)))
|
||||
(s6 (+ s6 (/ 1 d2)))
|
||||
(s7 (+ s7 (/ alt d)))
|
||||
(s8 (+ s8 (/ alt (- (* 2 d) 1))))
|
||||
(alt (- alt)))
|
||||
|
||||
(s0 (+ s0 (expt (/ 2.0 3) (- d 1))))
|
||||
(s1 (+ s1 (/ 1 (sqrt d))))
|
||||
(s2 (+ s2 (/ 1 (* d (+ d 1)))))
|
||||
(s3 (+ s3 (/ 1 (* d3 (* ds ds)))))
|
||||
(s4 (+ s4 (/ 1 (* d3 (* dc dc)))))
|
||||
(s5 (+ s5 (/ 1 d)))
|
||||
(s6 (+ s6 (/ 1 d2)))
|
||||
(s7 (+ s7 (/ alt d)))
|
||||
(s8 (+ s8 (/ alt (- (* 2 d) 1))))
|
||||
(alt (- alt)))
|
||||
|
||||
(loop d
|
||||
alt d2 d3 ds dc
|
||||
s0 s1 s2 s3 s4 s5 s6 s7 s8))))))
|
||||
s0 s1 s2 s3 s4 s5 s6 s7 s8)))))
|
||||
|
|
|
|||
|
|
@ -31,7 +31,7 @@
|
|||
(digit k q r s t (sub1 n) row 1))
|
||||
(begin
|
||||
(printf "~a" y)
|
||||
(digit k q r s t(sub1 n) row (add1 col)))))
|
||||
(digit k q r s t (sub1 n) row (add1 col)))))
|
||||
(let-values ([(q r s t) (mk q r s t k)])
|
||||
(digit (add1 k) q r s t n row col))))
|
||||
(printf "~a\t:~a\n"
|
||||
|
|
|
|||
|
|
@ -8,52 +8,51 @@
|
|||
;; Contributed by Anthony Borla
|
||||
;; ---------------------------------------------------------------------
|
||||
|
||||
(module recursive mzscheme
|
||||
(require (only mzlib/string real->decimal-string))
|
||||
#lang scheme/base
|
||||
(require scheme/cmdline)
|
||||
|
||||
;; -------------------------------
|
||||
;; -------------------------------
|
||||
|
||||
(define (ack m n)
|
||||
(cond ((zero? m) (+ n 1))
|
||||
((zero? n) (ack (- m 1) 1))
|
||||
(else (ack (- m 1) (ack m (- n 1))))))
|
||||
(define (ack m n)
|
||||
(cond ((zero? m) (+ n 1))
|
||||
((zero? n) (ack (- m 1) 1))
|
||||
(else (ack (- m 1) (ack m (- n 1))))))
|
||||
|
||||
;; --------------
|
||||
;; --------------
|
||||
|
||||
(define (fib n)
|
||||
(cond ((< n 2) 1)
|
||||
(else (+ (fib (- n 2)) (fib (- n 1))))))
|
||||
(define (fib n)
|
||||
(cond ((< n 2) 1)
|
||||
(else (+ (fib (- n 2)) (fib (- n 1))))))
|
||||
|
||||
(define (fibflt n)
|
||||
(cond ((< n 2.0) 1.0)
|
||||
(else (+ (fibflt (- n 2.0)) (fibflt (- n 1.0))))))
|
||||
(define (fibflt n)
|
||||
(cond ((< n 2.0) 1.0)
|
||||
(else (+ (fibflt (- n 2.0)) (fibflt (- n 1.0))))))
|
||||
|
||||
;; --------------
|
||||
;; --------------
|
||||
|
||||
(define (tak x y z)
|
||||
(cond ((not (< y x)) z)
|
||||
(else (tak (tak (- x 1) y z) (tak (- y 1) z x) (tak (- z 1) x y)))))
|
||||
(define (tak x y z)
|
||||
(cond ((not (< y x)) z)
|
||||
(else (tak (tak (- x 1) y z) (tak (- y 1) z x) (tak (- z 1) x y)))))
|
||||
|
||||
(define (takflt x y z)
|
||||
(cond ((not (< y x)) z)
|
||||
(else (takflt (takflt (- x 1.0) y z) (takflt (- y 1.0) z x) (takflt (- z 1.0) x y)))))
|
||||
(define (takflt x y z)
|
||||
(cond ((not (< y x)) z)
|
||||
(else (takflt (takflt (- x 1.0) y z) (takflt (- y 1.0) z x) (takflt (- z 1.0) x y)))))
|
||||
|
||||
;; -------------------------------
|
||||
;; -------------------------------
|
||||
|
||||
(define (main args)
|
||||
(let ((n (string->number (vector-ref args 0))))
|
||||
(define (main n)
|
||||
|
||||
(printf "Ack(3,~A): ~A~%" n (ack 3 n))
|
||||
(printf "Fib(~a): ~a~%"
|
||||
(real->decimal-string (+ 27.0 n) 1)
|
||||
(real->decimal-string (fibflt (+ 27.0 n)) 1))
|
||||
(printf "Ack(3,~A): ~A~%" n (ack 3 n))
|
||||
(printf "Fib(~a): ~a~%"
|
||||
(real->decimal-string (+ 27.0 n) 1)
|
||||
(real->decimal-string (fibflt (+ 27.0 n)) 1))
|
||||
|
||||
(set! n (- n 1))
|
||||
(printf "Tak(~A,~A,~A): ~A~%" (* n 3) (* n 2) n (tak (* n 3) (* n 2) n))
|
||||
|
||||
(printf "Fib(3): ~A~%" (fib 3))
|
||||
(printf "Tak(3.0,2.0,1.0): ~a~%" (real->decimal-string (takflt 3.0 2.0 1.0) 1)))
|
||||
|
||||
(set! n (- n 1))
|
||||
(printf "Tak(~A,~A,~A): ~A~%" (* n 3) (* n 2) n (tak (* n 3) (* n 2) n))
|
||||
;; -------------------------------
|
||||
|
||||
(printf "Fib(3): ~A~%" (fib 3))
|
||||
(printf "Tak(3.0,2.0,1.0): ~a~%" (real->decimal-string (takflt 3.0 2.0 1.0) 1))))
|
||||
|
||||
;; -------------------------------
|
||||
|
||||
(main (current-command-line-arguments)))
|
||||
(main (command-line #:args (n) (string->number n)))
|
||||
|
|
|
|||
|
|
@ -10,80 +10,79 @@
|
|||
;; Contributed by Anthony Borla
|
||||
;; ---------------------------------------------------------------------
|
||||
|
||||
(module regexpdna mzscheme
|
||||
#lang scheme/base
|
||||
(require scheme/port)
|
||||
|
||||
(require mzlib/port)
|
||||
|
||||
;; -------------------------------
|
||||
|
||||
(define VARIANTS
|
||||
'(#"agggtaaa|tttaccct" #"[cgt]gggtaaa|tttaccc[acg]" #"a[act]ggtaaa|tttacc[agt]t"
|
||||
#"ag[act]gtaaa|tttac[agt]ct" #"agg[act]taaa|ttta[agt]cct" #"aggg[acg]aaa|ttt[cgt]ccct"
|
||||
#"agggt[cgt]aa|tt[acg]accct" #"agggta[cgt]a|t[acg]taccct" #"agggtaa[cgt]|[acg]ttaccct"))
|
||||
;; -------------------------------
|
||||
|
||||
(define VARIANTS
|
||||
'(#"agggtaaa|tttaccct" #"[cgt]gggtaaa|tttaccc[acg]" #"a[act]ggtaaa|tttacc[agt]t"
|
||||
#"ag[act]gtaaa|tttac[agt]ct" #"agg[act]taaa|ttta[agt]cct" #"aggg[acg]aaa|ttt[cgt]ccct"
|
||||
#"agggt[cgt]aa|tt[acg]accct" #"agggta[cgt]a|t[acg]taccct" #"agggtaa[cgt]|[acg]ttaccct"))
|
||||
|
||||
|
||||
(define IUBS
|
||||
'((#"B" #"(c|g|t)") (#"D" #"(a|g|t)") (#"H" #"(a|c|t)")
|
||||
(#"K" #"(g|t)") (#"M" #"(a|c)") (#"N" #"(a|c|g|t)")
|
||||
(#"R" #"(a|g)") (#"S" #"(c|g)") (#"V" #"(a|c|g)")
|
||||
(#"W" #"(a|t)") (#"Y" #"(c|t)")))
|
||||
(define IUBS
|
||||
'((#"B" #"(c|g|t)") (#"D" #"(a|g|t)") (#"H" #"(a|c|t)")
|
||||
(#"K" #"(g|t)") (#"M" #"(a|c)") (#"N" #"(a|c|g|t)")
|
||||
(#"R" #"(a|g)") (#"S" #"(c|g)") (#"V" #"(a|c|g)")
|
||||
(#"W" #"(a|t)") (#"Y" #"(c|t)")))
|
||||
|
||||
;; -------------------------------
|
||||
;; -------------------------------
|
||||
|
||||
(define (ci-byte-regexp s)
|
||||
(byte-regexp (bytes-append #"(?i:" s #")")))
|
||||
(define (ci-byte-regexp s)
|
||||
(byte-regexp (bytes-append #"(?i:" s #")")))
|
||||
|
||||
;; -------------------------------
|
||||
|
||||
(define (match-count str rx offset cnt)
|
||||
(let ([m (regexp-match-positions rx str offset)])
|
||||
(if m
|
||||
(match-count str rx (cdar m) (add1 cnt))
|
||||
cnt)))
|
||||
;; -------------------------------
|
||||
|
||||
;; --------------
|
||||
|
||||
(define (replace-all rx str new)
|
||||
(let ([out (open-output-bytes)])
|
||||
(let loop ([pos 0])
|
||||
(let ([m (regexp-match-positions rx str pos)])
|
||||
(if m
|
||||
(begin
|
||||
(write-bytes str out pos (caar m))
|
||||
(write-bytes new out)
|
||||
(loop (cdar m)))
|
||||
(write-bytes str out pos))))
|
||||
(get-output-bytes out)))
|
||||
(define (match-count str rx offset cnt)
|
||||
(let ([m (regexp-match-positions rx str offset)])
|
||||
(if m
|
||||
(match-count str rx (cdar m) (add1 cnt))
|
||||
cnt)))
|
||||
|
||||
;; -------------------------------
|
||||
;; --------------
|
||||
|
||||
(define (input->bytes)
|
||||
(let ([b (open-output-bytes)])
|
||||
(copy-port (current-input-port) b)
|
||||
(get-output-bytes b)))
|
||||
(define (replace-all rx str new)
|
||||
(let ([out (open-output-bytes)])
|
||||
(let loop ([pos 0])
|
||||
(let ([m (regexp-match-positions rx str pos)])
|
||||
(if m
|
||||
(begin
|
||||
(write-bytes str out pos (caar m))
|
||||
(write-bytes new out)
|
||||
(loop (cdar m)))
|
||||
(write-bytes str out pos))))
|
||||
(get-output-bytes out)))
|
||||
|
||||
;; -------------------------------
|
||||
|
||||
;; Load sequence and record its length
|
||||
(let* ([orig (input->bytes)]
|
||||
[filtered (replace-all #rx#"(>.*?\n)|\n" orig #"")])
|
||||
;; -------------------------------
|
||||
|
||||
;; Perform regexp counts
|
||||
(for-each
|
||||
(lambda (i)
|
||||
(printf "~a ~a\n" i (match-count filtered (ci-byte-regexp i) 0 0)))
|
||||
VARIANTS)
|
||||
(define (input->bytes)
|
||||
(let ([b (open-output-bytes)])
|
||||
(copy-port (current-input-port) b)
|
||||
(get-output-bytes b)))
|
||||
|
||||
;; Perform regexp replacements, and record sequence length
|
||||
(let ([replaced
|
||||
(let loop ([sequence filtered]
|
||||
[IUBS IUBS])
|
||||
(if (null? IUBS)
|
||||
sequence
|
||||
(loop (replace-all (byte-regexp (caar IUBS)) sequence (cadar IUBS))
|
||||
(cdr IUBS))))])
|
||||
;; Print statistics
|
||||
(printf "~%~A~%~A~%~A~%"
|
||||
(bytes-length orig)
|
||||
(bytes-length filtered)
|
||||
(bytes-length replaced)))))
|
||||
;; -------------------------------
|
||||
|
||||
;; Load sequence and record its length
|
||||
(let* ([orig (input->bytes)]
|
||||
[filtered (replace-all #rx#"(>.*?\n)|\n" orig #"")])
|
||||
|
||||
;; Perform regexp counts
|
||||
(for-each
|
||||
(lambda (i)
|
||||
(printf "~a ~a\n" i (match-count filtered (ci-byte-regexp i) 0 0)))
|
||||
VARIANTS)
|
||||
|
||||
;; Perform regexp replacements, and record sequence length
|
||||
(let ([replaced
|
||||
(let loop ([sequence filtered]
|
||||
[IUBS IUBS])
|
||||
(if (null? IUBS)
|
||||
sequence
|
||||
(loop (replace-all (byte-regexp (caar IUBS)) sequence (cadar IUBS))
|
||||
(cdr IUBS))))])
|
||||
;; Print statistics
|
||||
(printf "~%~A~%~A~%~A~%"
|
||||
(bytes-length orig)
|
||||
(bytes-length filtered)
|
||||
(bytes-length replaced))))
|
||||
|
|
|
|||
|
|
@ -27,7 +27,7 @@
|
|||
|
||||
;; return element i,j of infinite matrix A
|
||||
(define (A i j)
|
||||
(/ 1.0 (+ (* (+ i j) (/ (+ i j 1) 2)) i 1)))
|
||||
(/ 1.0 (+ (* (+ i j) (/ (+ i (+ j 1)) 2)) (+ i 1))))
|
||||
|
||||
;; multiply vector v by matrix A
|
||||
(define (MultiplyAv n v Av)
|
||||
|
|
|
|||
|
|
@ -1,10 +1,5 @@
|
|||
;;; http://shootout.alioth.debian.org/
|
||||
;;;
|
||||
;;; Contributed by Eli Barzilay
|
||||
#lang scheme/base
|
||||
|
||||
(module sumcol mzscheme
|
||||
(let loop ([acc 0])
|
||||
(let ([n (read)])
|
||||
(if (eof-object? n)
|
||||
(printf "~a\n" acc)
|
||||
(loop (+ acc n))))))
|
||||
(for/fold ([acc 0])
|
||||
([n (in-lines)])
|
||||
(+ acc (string->number n)))
|
||||
|
|
|
|||
23
collects/tests/mzscheme/benchmarks/shootout/thread-ring.ss
Normal file
23
collects/tests/mzscheme/benchmarks/shootout/thread-ring.ss
Normal file
|
|
@ -0,0 +1,23 @@
|
|||
#lang scheme/base
|
||||
(require scheme/cmdline)
|
||||
|
||||
;; Each thread runs this loop:
|
||||
(define (run id next)
|
||||
(let ([v (thread-receive)])
|
||||
(cond
|
||||
[(zero? v) ;; Done
|
||||
(printf "~a\n" id)
|
||||
(exit)]
|
||||
[else ;; Keep going
|
||||
(thread-send next (sub1 v))
|
||||
(run id next)])))
|
||||
|
||||
|
||||
(let ([n (command-line #:args (n) (string->number n))])
|
||||
;; The original thread is #503. Create the rest:
|
||||
(let ([t1 (for/fold ([next (current-thread)])
|
||||
([id (in-range 502 0 -1)])
|
||||
(thread (lambda () (run id next))))])
|
||||
;; Start:
|
||||
(thread-send t1 n)
|
||||
(run 503 t1)))
|
||||
Loading…
Reference in New Issue
Block a user