markov.hs

import System.IO
import Data.List
import qualified Data.Map as M
import System.Random
import Data.Maybe
import Control.Applicative

main = do
    contents <- readFile "messages.txt"
    gen <- getStdGen
    let m = phraseMap $ concatPhrasesWith 3 (map words . lines) contents
        (seed, newGen) = sample (M.keys m) gen
        chain = seed ++ getNexts seed m newGen
    putStrLn $ unwords $ take 100 chain

phrases :: Int -> [a] -> [[a]]
phrases n xs
    | length xs <= n = xs:[]
    | otherwise = take n xs:(phrases n $ tail xs)

concatPhrases :: Int -> [[a]] -> [[a]]
concatPhrases n xs = concat $ map (phrases n) xs

phrasesWith :: Int -> (a -> [b]) -> a -> [[b]]
phrasesWith n f x = phrases n xs where xs = f x

concatPhrasesWith :: Int -> (a -> [[b]]) -> a -> [[b]]
concatPhrasesWith n f x = concatPhrases n xs where xs = f x

phraseMap :: Ord a => [[a]] -> M.Map [a] [a]
phraseMap xs = M.fromListWith (++) $ map (\x -> splitAt (length x - 1) x) xs

getNext :: (RandomGen g, Ord k) => k -> M.Map k [a] -> g -> Maybe (a, g)
getNext s m g = (flip sample $ g) <$> M.lookup s m

getNexts :: (RandomGen g, Ord a) => [a] -> M.Map [a] [a] -> g -> [a]
getNexts s m g = case getNext s m g
                   of Just (v, h) -> v:getNexts ((drop 1 s) ++ [v]) m h
                      Nothing -> []

sample :: RandomGen g => [a] -> g -> (a, g)
sample xs g = (xs !! i, h) where (i, h) = randomR (0, length xs - 1) g

samples :: RandomGen g => [a] -> g -> [a]
samples xs g = x:samples xs h where (x, h) = sample xs g