@@ -0,0 +1,84 @@
1+module Main
2+
3+import System
4+import Data.Floats
5+
6+alu : String
7+alu = "GGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGG\
8+ \TCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGG\
9+ \CGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGC\
10+ \GGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAA"
11+
12+iub : List (Char, Float)
13+iub = [('a',0.27),('c',0.12),('g',0.12),('t',0.27),('B',0.02)
14+ ,('D',0.02),('H',0.02),('K',0.02),('M',0.02),('N',0.02)
15+ ,('R',0.02),('S',0.02),('V',0.02),('W',0.02),('Y',0.02)]
16+
17+homosapiens : List (Char, Float)
18+homosapiens = [('a',0.3029549426680),('c',0.1979883004921)
19+ ,('g',0.1975473066391),('t',0.3015094502008)]
20+
21+
22+takeRepeat : Int -> String -> String
23+takeRepeat n s = if n > m
24+ then s ++ takeRepeat (n-m) s
25+ else pack $ take (cast n) $ unpack s
26+ where
27+ m = cast $ length s
28+
29+splitAt' : Nat -> String -> (String, String)
30+splitAt' n s = let s' = unpack s in (pack $ take n s', pack $ drop n s')
31+
32+writeAlu : String -> String -> IO ()
33+writeAlu name s0 = putStrLn name $> go s0
34+ where
35+ go "" = return ()
36+ go s = let (h,t) = splitAt' 60 s in putStrLn h $> go t
37+
38+replicate : Int -> Char -> String
39+replicate 0 c = ""
40+replicate n c = singleton c <+> replicate (n-1) c
41+
42+scanl : (f : acc -> a -> acc) -> acc -> List a -> List acc
43+scanl f q ls = q :: (case ls of
44+ [] => []
45+ x::xs => scanl f (f q x) xs)
46+
47+accum : (Char,Float) -> (Char,Float) -> (Char,Float)
48+accum (_,p) (c,q) = (c,p+q)
49+
50+make : String -> Int -> List (Char, Float) -> Int -> IO Int
51+make name n0 tbl seed0 = do
52+ putStrLn name
53+ make' n0 0 seed0 ""
54+ where
55+ modulus : Int
56+ modulus = 139968
57+
58+ fill : List (Char,Float) -> Int -> List String
59+ fill ((c,p) :: cps) j =
60+ let k = min modulus (cast (cast modulus * p + 1))
61+ in replicate (k - j) c :: fill cps k
62+ fill _ _ = []
63+
64+ lookupTable : String
65+ lookupTable = Foldable.concat (fill (scanl accum ('a',0) tbl) 0)
66+
67+ make' : Int -> Int -> Int -> String -> IO Int
68+ make' 0 col seed buf = when (col > 0) (putStrLn buf) $> return seed
69+ make' n col seed buf = do
70+ let newseed = modInt (seed * 3877 + 29573) modulus
71+ let nextchar = strIndex lookupTable newseed
72+ let newbuf = buf <+> singleton nextchar
73+ if col+1 >= 60
74+ then putStrLn newbuf $> make' (n-1) 0 newseed ""
75+ else make' (n-1) (col+1) newseed newbuf
76+
77+
78+main : IO ()
79+main = do
80+ (_ :: n :: _) <- getArgs
81+ writeAlu ">ONE Homo sapiens alu" (takeRepeat (fromInteger (cast n)*2) alu)
82+ nseed <- make ">TWO IUB ambiguity codes" (fromInteger (cast n)*3) iub 42
83+ make ">THREE Homo sapiens frequency" (fromInteger (cast n)*5) homosapiens nseed
84+ return ()