@@ -0,0 +1,95 @@
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 : Nat -> String -> String
23+takeRepeat n s = if n > m
24+ then s ++ takeRepeat (n-m) s
25+ else pack $ take n $ unpack s
26+ where
27+ m = 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 : Nat -> Char -> String
39+replicate Z c = ""
40+replicate (S n) c = singleton c <+> replicate n c
41+
42+inits : List a -> List a -> List (List a)
43+inits xs [] = [xs]
44+inits xs (h::t) = let xs' = xs ++ [h] in xs :: inits xs' t
45+
46+scanl : (f : acc -> a -> acc) -> acc -> (l : List a) -> List acc
47+scanl f acc l = map (foldl f acc) $ inits [] l
48+
49+accum : (Char,Float) -> (Char,Float) -> (Char,Float)
50+accum (_,p) (c,q) = (c,p+q)
51+
52+instance Cast Nat Float where
53+ cast = cast . cast . cast
54+
55+instance Cast Float Nat where
56+ cast = fromInteger . cast . cast . floor
57+
58+
59+make : String -> Nat -> List (Char, Float) -> Nat -> IO Nat
60+make name n0 tbl seed0 = do
61+ putStrLn name
62+ make' n0 Z seed0 ""
63+ where
64+ modulus : Nat
65+ modulus = 139968
66+
67+ fill : List (Char,Float) -> Nat -> List String
68+ fill ((c,p) :: cps) j =
69+ let k = min modulus (cast (cast modulus * p + 1))
70+ in replicate (k - j) c :: fill cps k
71+ fill _ _ = []
72+
73+ lookupTable : String
74+ lookupTable = Foldable.concat (fill (drop 1 $ scanl accum ('a',0) tbl) 0)
75+
76+ make' : Nat -> Nat -> Nat -> String -> IO Nat
77+ make' Z col seed buf = when (col > 0) (putStrLn buf) $> return seed
78+ make' (S n) col seed buf = do
79+ print (S n)
80+ let newseed = modNat (seed * 3877 + 39573) modulus
81+ print newseed
82+ let nextchar = strIndex lookupTable (cast newseed)
83+ print nextchar
84+ if col+1 >= 60
85+ then putStrLn buf $> make' n Z newseed (singleton nextchar)
86+ else make' n (S col) newseed (strCons nextchar buf)
87+
88+
89+main : IO ()
90+main = do
91+ (_ :: n :: _) <- getArgs
92+ writeAlu ">ONE Homo sapiens alu" (takeRepeat (fromInteger (cast n)*2) alu)
93+ nseed <- make ">TWO IUB ambiguity codes" (fromInteger (cast n)*3) iub 42
94+ make ">THREE Homo sapiens frequency" (fromInteger (cast n)*5) homosapiens nseed
95+ return ()