module Main where
import qualified Data.Map as Map
import Data.Map(Map)
import System.Random(Random, RandomGen, randomR, randomRs, getStdGen, split, )
import Control.Monad.State(State, state, runState, evalState, )
main :: IO ()
main = do
dictfirst <- readFile "vornamen.txt"
dictsecond <- readFile "nachnamen.txt"
{-
putStrLn ("sizes of dictionaries: " ++
show (map (\n -> (n, Map.size (createMap n dictfirst))) [1,2,3,4]))
-}
g <- getStdGen
putStrLn ("
\n"++(createEmailAddrs g 10 2 dictfirst dictsecond)++"
\n")
-- putStrLn (show (take 20 (walk 3 dictfirst g)))
createEmailAddrs :: RandomGen g =>
g -> Int -> Int -> [Char] -> [Char] -> [Char]
createEmailAddrs g num mem dictfirst dictsecond =
let (g1,gt) = split g
(g2,g3) = split gt
in concat (take num (
zipWith3
(\n1 n2 dom ->
""++
n1++" "++n2++"\n")
(lines (walk mem dictfirst g1))
(lines (walk mem dictsecond g2))
(randomDomainList g3)))
randomDomainList :: RandomGen g => g -> [String]
randomDomainList g =
let (g0,g1) = split g
in randomChop g0 (randomRs ('a','z') g1)
{- Chop a list into pieces of random length -}
randomChop :: RandomGen g => g -> [a] -> [[a]]
randomChop g =
evalState (mapM (state . splitAt) (randomRs (5,10) g))
{- creates a chain of characters according
to the probabilities of possible successor -}
walk :: RandomGen g => Int -> [Char] -> g -> String
walk n -- size of look-ahead buffer
dict -- text to walk through randomly
g -- random generator state
= let fm = createMap n dict
(start,ng) = runState (randomStart dict) g
{- This is the main function of this program.
It is quite involved.
If you want to understand it,
imagine the list 'y' completely exists
before computation. -}
y = take n start ++
-- run them on the initial random generator state
(flip evalState ng $
-- this turns the list of possible successors
-- into an action that generate a list
-- of randomly chosen items
mapM randomItem $
-- lookup all possible successors of each infix
map (flip (Map.findWithDefault (error "each infix found in the text must also be in the dictionary")) fm) $
-- wrap the suffixes in the BoundList data structure
-- this is similar to (take n)
map (BoundList n) $
-- list all suffixes of y
iterate tail y)
in y
randomStart :: (RandomGen g) => [Char] -> State g String
randomStart dict = randomItem (startingPoints '\n' dict)
-- chose a random item from a list
randomItem :: (RandomGen g) => [a] -> State g a
randomItem x = fmap (x!!) (state (randomR (0, length x - 1)))
startingPoints :: (Eq a) => a -> [a] -> [[a]]
startingPoints sep dict =
map tail (filter ((sep==).head) (takeWhile (not.null) (iterate tail dict)))
-- create a map that lists for each string all possible successors
createMap :: (Ord a) => Int -> [a] -> Map (BoundList a) [a]
-- (flip (++)) should be a bit faster than (++)
-- since it prepends new entries
createMap n x =
let -- list of the map keys
sufxs = map (BoundList n) (iterate tail (cycle x))
-- list of the map images, i.e. single element lists
imgxs = map (:[]) (drop n (cycle x))
maplist = take (length x) (zip sufxs imgxs)
in Map.fromListWith (flip (++)) maplist
-- BoundList is a virtually finite list
{- The contained list must be infinite and
the integer specifies the length of the prefix
of the list to be considered.
This treatment is much more efficient
than actually splitting the list (with 'take')
since no part of the splitted list must be copied. -}
data BoundList a = BoundList !Int ![a]
-- deriving Show
instance Show a => Show (BoundList a) where
show (BoundList n x) = show (take n x) ++ "..."
instance Eq a => Eq (BoundList a) where
(BoundList n x) == (BoundList m y) =
if n==m
then and (take n (zipWith (==) x y))
else error "(==): Length of BoundLists must be equal!"
instance Ord a => Ord (BoundList a) where
compare (BoundList 0 _) (BoundList 0 _) = EQ
compare (BoundList 0 _) (BoundList _ _) = error "compare: Length of BoundLists must be equal!"
compare (BoundList _ _) (BoundList 0 _) = error "compare: Length of BoundLists must be equal!"
compare (BoundList n (x:xs)) (BoundList m (y:ys)) =
let rel = compare x y
in if rel == EQ
then compare (BoundList (n-1) xs) (BoundList (m-1) ys)
else rel