probs.hs

import Data.List (permutations,sort)
import Data.Map (Map,lookup,fromListWith,mapWithKey,toList)
import Data.Maybe

wordPairs :: String -> [(String,Char)]
wordPairs x = wordPairs' (" " ++ x ++ " ")
wordPairs' (a:b:c:xs) = ([a,b],c):(wordPairs' (b:c:xs))
wordPairs' _ = []
        
getAssocs :: Fractional a => String -> [((String,Char),a)]
getAssocs w = zip (wordPairs w) $ repeat 1
        
getCounts :: Fractional a => [String] -> Map (String,Char) a
getCounts ws = fromListWith (+) assocs
  where assocs = concatMap getAssocs ws

alphabet :: String
alphabet = ' ':['A'..'Z']

getProbs' :: Fractional a => Map (String,Char) a -> Map (String,Char) a
getProbs' probs = mapWithKey toFraction probs
  where toFraction (x,_) v = v / (toNumerator x)
        toNumerator x = sum $ catMaybes $ map (\y -> Data.Map.lookup (x,y) probs) alphabet
  
getProbs :: Fractional a => [String] -> Map (String,Char) a
getProbs ws = getProbs' $ getCounts ws

minProb :: Ord a => Fractional a => a
minProb = 1 / 1000

pairProb' :: Ord a => Fractional a => Maybe a -> a
pairProb' Nothing = minProb
pairProb' (Just x) = max minProb x

pairProb probs (x,y) = pairProb' $ Data.Map.lookup (x,y) probs

wordProb probs w = product pairProbs
  where pairProbs = map (pairProb probs) $ wordPairs w

main :: IO ()
main = do
  contents <- getContents
  let ws = words contents
  let probs = getProbs ws
--  print $ wordPairs "RETAINS"
--  mapM_ print $ toList probs
  let tens = filter (\x -> 10==length x) ws
--  mapM_ print $ sort $ map (\x -> (1/wordProb probs x,x)) $ permutations "DRIVY"
  mapM_ print $ sort $ map (\x -> (1/wordProb probs x,x)) $ tens