@@ -19,12 +19,12 @@ homosapiens = [('a',0.3029549426680),('c',0.1979883004921)
19 ,('g',0.1975473066391),('t',0.3015094502008)]
19 ,('g',0.1975473066391),('t',0.3015094502008)]
22−takeRepeat : Nat -> String -> String
22+takeRepeat : Int -> String -> String
23takeRepeat n s = if n > m
23takeRepeat n s = if n > m
24 then s ++ takeRepeat (n-m) s
24 then s ++ takeRepeat (n-m) s
25− else pack $ take n $ unpack s
25+ else pack $ take (cast n) $ unpack s
27− m = length s
27+ m = cast $ length s
29splitAt' : Nat -> String -> (String, String)
29splitAt' : Nat -> String -> (String, String)
30splitAt' n s = let s' = unpack s in (pack $ take n s', pack $ drop n s')
30splitAt' n s = let s' = unpack s in (pack $ take n s', pack $ drop n s')
@@ -35,9 +35,9 @@ writeAlu name s0 = putStrLn name $> go s0
35 go "" = return ()
35 go "" = return ()
36 go s = let (h,t) = splitAt' 60 s in putStrLn h $> go t
36 go s = let (h,t) = splitAt' 60 s in putStrLn h $> go t
38−replicate : Nat -> Char -> String
38+replicate : Int -> Char -> String
39−replicate Z c = ""
39+replicate 0 c = ""
40−replicate (S n) c = singleton c <+> replicate n c
40+replicate n c = singleton c <+> replicate (n-1) c
42inits : List a -> List a -> List (List a)
42inits : List a -> List a -> List (List a)
43inits xs [] = [xs]
43inits xs [] = [xs]
@@ -49,22 +49,15 @@ scanl f acc l = map (foldl f acc) $ inits [] l
49accum : (Char,Float) -> (Char,Float) -> (Char,Float)
49accum : (Char,Float) -> (Char,Float) -> (Char,Float)
50accum (_,p) (c,q) = (c,p+q)
50accum (_,p) (c,q) = (c,p+q)
52−instance Cast Nat Float where
53− cast = cast . cast . cast
55−instance Cast Float Nat where
56− cast = fromInteger . cast . cast . floor
59−make : String -> Nat -> List (Char, Float) -> Nat -> IO Nat
52+make : String -> Int -> List (Char, Float) -> Int -> IO Int
60make name n0 tbl seed0 = do
53make name n0 tbl seed0 = do
61 putStrLn name
54 putStrLn name
62− make' n0 Z seed0 ""
55+ make' n0 0 seed0 ""
64− modulus : Nat
57+ modulus : Int
65 modulus = 139968
58 modulus = 139968
67− fill : List (Char,Float) -> Nat -> List String
60+ fill : List (Char,Float) -> Int -> List String
68 fill ((c,p) :: cps) j =
61 fill ((c,p) :: cps) j =
69 let k = min modulus (cast (cast modulus * p + 1))
62 let k = min modulus (cast (cast modulus * p + 1))
70 in replicate (k - j) c :: fill cps k
63 in replicate (k - j) c :: fill cps k
@@ -73,17 +66,14 @@ make name n0 tbl seed0 = do
73 lookupTable : String
66 lookupTable : String
74 lookupTable = Foldable.concat (fill (drop 1 $ scanl accum ('a',0) tbl) 0)
67 lookupTable = Foldable.concat (fill (drop 1 $ scanl accum ('a',0) tbl) 0)
76− make' : Nat -> Nat -> Nat -> String -> IO Nat
69+ make' : Int -> Int -> Int -> String -> IO Int
77− make' Z col seed buf = when (col > 0) (putStrLn buf) $> return seed
70+ make' 0 col seed buf = when (col > 0) (putStrLn buf) $> return seed
78− make' (S n) col seed buf = do
71+ make' n col seed buf = do
80− let newseed = modNat (seed * 3877 + 39573) modulus
72+ let newseed = modInt (seed * 3877 + 39573) modulus
82− let nextchar = strIndex lookupTable (cast newseed)
73+ let nextchar = strIndex lookupTable newseed
84 if col+1 >= 60
74 if col+1 >= 60
85− then putStrLn buf $> make' n Z newseed (singleton nextchar)
75+ then putStrLn buf $> make' (n-1) 0 newseed (singleton nextchar)
86− else make' n (S col) newseed (strCons nextchar buf)
76+ else make' (n-1) (col+1) newseed (strCons nextchar buf)
89main : IO ()
79main : IO ()