From 052e2c38960609f7297901504daa6c22364e94ce Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Mon, 29 Jan 2007 12:57:08 +0000
Subject: [PATCH] implement missing bm

svn: r5496
---
 .../tests/mzscheme/benchmarks/shootout/run.ss | 20 ++++--
 .../benchmarks/shootout/spectralnorm.ss       | 72 +++++++++++++++++++
 2 files changed, 85 insertions(+), 7 deletions(-)
 create mode 100644 collects/tests/mzscheme/benchmarks/shootout/spectralnorm.ss

diff --git a/collects/tests/mzscheme/benchmarks/shootout/run.ss b/collects/tests/mzscheme/benchmarks/shootout/run.ss
index a316390849..5fe0cab467 100644
--- a/collects/tests/mzscheme/benchmarks/shootout/run.ss
+++ b/collects/tests/mzscheme/benchmarks/shootout/run.ss
@@ -5,7 +5,7 @@
       ("ary.ss" "9000")
       ("binarytrees.ss" "16")
       ("chameneos.ss")
-      ("cheapconcurrency.ss")
+      ("cheapconcurrency.ss" "15000")
       ("echo.ss" "150000")
       ("except.ss" "2500000")
       ("fannkuch.ss" "10")
@@ -15,10 +15,10 @@
       ("hash2.ss" "200")
       ("heapsort.ss" "100000")
       ("lists.ss" "18")
-      ("mandelbrot.ss")
+      ("mandelbrot.ss" "3000")
       ("matrix.ss" "600")
       ("moments.ss") ; 200 somethings...
-      ("nbody.ss")
+      ("nbody.ss" "20000000")
       ("nestedloop.ss" "18")
       ("nsieve.ss")
       ("nsievebits.ss")
@@ -42,16 +42,22 @@
   (define (dynreq f)
     (dynamic-require `(lib ,f "tests" "mzscheme" "benchmarks" "shootout") #f))
 
-  (define (mk-revcomp-input)
-    (let ([f (build-path (find-system-path 'temp-dir) "fasta-2m5")])
+  (define (mk-fasta n suffix)
+    (let ([f (build-path (find-system-path 'temp-dir) (string-append "fasta-" suffix))])
       (unless (file-exists? f)
-        (printf "Building FASTA 2,500,000 output for input: ~a\n" f)
+        (printf "Building FASTA ~a output for input: ~a\n" n f)
         (with-output-to-file f
           (lambda ()
-            (parameterize ([current-command-line-arguments (vector "2500000")])
+            (parameterize ([current-command-line-arguments (vector n)])
               (dynreq "fasta.ss")))))
       f))
 
+  (define (mk-revcomp-input)
+    (mk-fasta "2500000" "2m5"))
+
+  (define (mk-knuc-input)
+    (mk-fasta "1000000" "1m"))
+
   (define (mk-sumcol-input)
     (let ([f (build-path (find-system-path 'temp-dir) "sumcol-21k")])
       (unless (file-exists? f)
diff --git a/collects/tests/mzscheme/benchmarks/shootout/spectralnorm.ss b/collects/tests/mzscheme/benchmarks/shootout/spectralnorm.ss
new file mode 100644
index 0000000000..f144188949
--- /dev/null
+++ b/collects/tests/mzscheme/benchmarks/shootout/spectralnorm.ss
@@ -0,0 +1,72 @@
+;;   The Computer Language Shootout
+;;   http://shootout.alioth.debian.org/
+;;
+;; Based on the Ruby version:
+#|
+# http://shootout.alioth.debian.org
+#
+# contributed by jose fco. gonzalez
+# modified by Sokolov Yura
+|#
+
+(module spectralnorm mzscheme
+  (require (lib "list.ss")
+           (lib "string.ss")
+           (only (lib "13.ss" "srfi") string-pad-right))
+
+  (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 (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-one-freq table key)
+    (let ([cnt (hash-table-get 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)))))
+
+  ;; 1-nucleotide counts:
+  (write-freqs (all-counts 1 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"))
+  
+  )
+
+  
+  
\ No newline at end of file