factor: trim using lists

[factor.git] / extra / benchmark / fasta / fasta.factor

diff --git a/extra/benchmark/fasta/fasta.factor b/extra/benchmark/fasta/fasta.factor
old mode 100755 (executable)
new mode 100644 (file)
index 61d9e9f..c36d67c
--- a/extra/benchmark/fasta/fasta.factor
+++ b/extra/benchmark/fasta/fasta.factor
@@ -1,7 +1,9 @@
 ! Based on http://shootout.alioth.debian.org/gp4/benchmark.php?test=fasta&lang=java&id=2
-USING: math kernel io io.files locals multiline assocs sequences
-sequences.private benchmark.reverse-complement hints io.encodings.ascii
-byte-arrays specialized-arrays.double ;
+USING: alien.data assocs benchmark.reverse-complement
+byte-arrays io io.encodings.ascii io.files kernel math sequences
+sequences.private specialized-arrays strings typed ;
+QUALIFIED-WITH: alien.c-types c
+SPECIALIZED-ARRAY: c:double
 IN: benchmark.fasta
 
 CONSTANT: IM 139968
@@ -10,16 +12,12 @@ CONSTANT: IC 29573
 CONSTANT: initial-seed 42
 CONSTANT: line-length 60
 
-USE: math.private
-
-: random ( seed -- n seed )
-    >float IA * IC + IM mod [ IM /f ] keep ; inline
-
-HINTS: random fixnum ;
+: next-fasta-random ( seed -- seed n )
+    IA * IC + IM mod dup IM /f ; inline
 
 CONSTANT: ALU "GGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAA"
 
-: IUB
+CONSTANT: IUB
     {
         { CHAR: a 0.27 }
         { CHAR: c 0.12 }
@@ -37,74 +35,73 @@ CONSTANT: ALU "GGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACC
         { CHAR: V 0.02 }
         { CHAR: W 0.02 }
         { CHAR: Y 0.02 }
-    } ; inline
+    }
 
-: homo-sapiens
+CONSTANT: homo-sapiens
     {
         { CHAR: a 0.3029549426680 }
         { CHAR: c 0.1979883004921 }
         { CHAR: g 0.1975473066391 }
         { CHAR: t 0.3015094502008 }
-    } ; inline
+    }
 
-: make-cumulative ( freq -- chars floats )
-    dup keys >byte-array
-    swap values >double-array unclip [ + ] accumulate swap suffix ;
+TYPED: make-cumulative ( freq -- chars: byte-array floats: double-array )
+    [ keys >byte-array ]
+    [ values c:double >c-array 0.0 [ + ] accumulate* ] bi ;
 
 :: select-random ( seed chars floats -- seed elt )
-    floats seed random -rot
-    [ >= ] curry find drop
-    chars nth-unsafe ; inline
+    seed next-fasta-random floats [ <= ] with find drop chars nth-unsafe ; inline
 
-: make-random-fasta ( seed len chars floats -- seed )
-    [ rot drop select-random ] 2curry B{ } map-as print ; inline
+TYPED: make-random-fasta ( seed: float len: fixnum chars: byte-array floats: double-array -- seed: float )
+    '[ _ _ select-random ] "" replicate-as print ;
 
 : write-description ( desc id -- )
-    ">" write write bl print ; inline
+    ">" write write bl print ;
 
-:: split-lines ( n quot -- )
+:: n-split-lines ( n quot -- )
     n line-length /mod
     [ [ line-length quot call ] times ] dip
-    dup zero? [ drop ] quot if ; inline
+    quot unless-zero ; inline
 
-: write-random-fasta ( seed n chars floats desc id -- seed )
+TYPED: write-random-fasta ( seed: float n: fixnum chars: byte-array floats: double-array desc id -- seed: float )
     write-description
-    [ make-random-fasta ] 2curry split-lines ; inline
+    '[ _ _ make-random-fasta ] n-split-lines ;
 
-:: make-repeat-fasta ( k len alu -- k' )
-    [let | kn [ alu length ] |
-        len [ k + kn mod alu nth-unsafe ] B{ } map-as print
-        k len +
-    ] ; inline
+TYPED:: make-repeat-fasta ( k: fixnum len: fixnum alu: string -- k': fixnum )
+    alu length :> kn
+    len <iota> [ k + kn mod alu nth-unsafe ] "" map-as print
+    k len + ;
 
 : write-repeat-fasta ( n alu desc id -- )
     write-description
-    [let | k! [ 0 ] alu [ ] |
-        [| len | k len alu make-repeat-fasta k! ] split-lines
-    ] ; inline
+    [let
+        :> alu
+        0 :> k!
+        [| len | k len alu make-repeat-fasta k! ] n-split-lines
+    ] ;
 
 : fasta ( n out -- )
     homo-sapiens make-cumulative
     IUB make-cumulative
-    [let | homo-sapiens-floats [ ]
-           homo-sapiens-chars [ ]
-           IUB-floats [ ]
-           IUB-chars [ ]
-           out [ ]
-           n [ ]
-           seed [ initial-seed ] |
+    [let
+        :> ( n out IUB-chars IUB-floats homo-sapiens-chars homo-sapiens-floats )
+        initial-seed :> seed
 
         out ascii [
             n 2 * ALU "Homo sapiens alu" "ONE" write-repeat-fasta
 
             initial-seed
-            n 3 * homo-sapiens-chars homo-sapiens-floats "IUB ambiguity codes" "TWO" write-random-fasta
-            n 5 * IUB-chars IUB-floats "Homo sapiens frequency" "THREE" write-random-fasta
+
+            n 3 * homo-sapiens-chars homo-sapiens-floats
+            "IUB ambiguity codes" "TWO" write-random-fasta
+
+            n 5 * IUB-chars IUB-floats
+            "Homo sapiens frequency" "THREE" write-random-fasta
+
             drop
         ] with-file-writer
-
     ] ;
 
-: run-fasta ( -- ) 2500000 reverse-complement-in fasta ;
+: fasta-benchmark ( -- ) 2500000 reverse-complement-in fasta ;
 
-MAIN: run-fasta
+MAIN: fasta-benchmark