fullhouse.hs

import Control.Applicative
import Control.Monad
import Data.List
import Data.Function (on)
import Data.Ratio
import Data.Char

newtype P a = P {probabilities :: [(Rational,a)] }

instance Functor P where
  fmap f (P a) = P ((fmap . fmap) f a)

instance Applicative P where
  pure = P . (:[]) . ((,) 1)
  P f <*> P a = P (filter ((/= 0) . fst) (do
    (pf,f') <- f
    (pa,a') <- pf `seq` a
    let pr = pf * pa in pr `seq` return (pr, f' a')
   ))

instance Monad P where
  return = pure
  P a >>= f = P (filter ((/= 0) . fst) (do
    (pa,a') <- a
    (pb,b') <- pa `seq` probabilities (f a')
    let pr = pa * pb in pr `seq` return (pr, b')
   ))

uniform l = let
  s = 1 % genericLength l
  in P $ map ((,) s) l

distributed :: (Real f) => [(f,a)] -> P a
distributed l = let
  s = 1 / sum (map (toRational . fst) l)
  in P (map (\(r,a) -> (toRational r * s,a)) l)

collate :: (Eq a) => P a -> P a
collate = P . go . probabilities where
  go :: Eq a => [(Rational,a)] -> [(Rational,a)]
  go [] = []
  go ((pa,a):r) = let
    (m,n) = partition ((== a) . snd) r
    in (pa + sum (map fst m), a) : go n

collate' :: (Ord a) => P a -> P a
collate' = P .
  map (\((pa,a):r) -> (pa + sum (map fst r), a)) .
  groupBy ((==) `on` snd) .
  sortBy (compare `on` snd) .
  probabilities

select :: [a] -> [(a,[a])]
select = go id where
  go _ [] = []
  go acc (a:r) = (a, acc r) : go (acc . (a :)) r

oneCard :: [(Integer,Integer,Integer)] -> P [(Integer,Integer,Integer)]
oneCard l = collate' $ do
  ((h,s,n),r) <- distributed $
    map (\v@((_,s,n),_) -> (s * n, v)) $
    select l
  return $ sort $ case n of
    1 -> (h + 1, s - 1, 1) : r
    _ -> (h + 1, s - 1, 1) : (h, s, n - 1) : r

oneHand :: [(Integer,Integer)] -> P (Integer,[(Integer,Integer)])
oneHand l' = collate' $ do
  let l = map (\(s,n) -> (0,s,n)) l'
  l2 <- foldl' (\a _ -> collate $ a >>= oneCard) (return l) (replicate 5 ())
  let
    ri = if (sort $ filter (/= 0) $ map (\(a,_,_) -> a) l2) == [2,3]
      then 1
      else 0
    rl = map (\((s,n):r) -> (s,n + sum (map snd r))) $
      groupBy ((==) `on` fst) $
      sortBy (compare `on` fst) $
      filter (/= (0,0)) $
      map (\(_,s,n) -> (s,n)) l2
  return (ri,rl)

hands :: Integer -> [(Integer,Integer)] -> P Integer
hands n = collate' . fmap fst . go . return . ((,) 0) where
  go = flip (foldl' (\s _ -> collate' $ s >>= \(f,d) -> do
    (i,r) <- oneHand d
    return (i + f, r)
   )) [1 .. n]

distribution :: [(Integer,Integer)] -> [P Integer]
distribution d = let
  mp = (sum $ map (uncurry (*)) d) `div` 5
  in genericTake mp $
    tail $
    map (collate' . fmap fst) $
    iterate (\e -> collate' $
      e >>= \(f,d) -> do
        (i,r) <- oneHand d
        return (i + f, r)
     ) $
    return (0,d)

show3sf :: Rational -> String
show3sf r = let
  w = floor r :: Integer
  m = r - toRational w
  sw = show w
  s0 = if w == 0 then 3 else max 1 (3 - length sw)
  go1 0 = "0"
  go1 m' = case floor m' of
    0 -> '0' : go1 (m' * 10)
    d -> intToDigit d :
      go2 (s0 - 2) ((m' - toRational d) * 10)
  go2 _ 0 = "0"
  go2 0 m' = [intToDigit $ round m']
  go2 rd m' = let
    d = floor m'
    in intToDigit d : go2 (rd - 1) ((m' - toRational d) * 10)
  fixRounding = reverse . fr False . reverse where
    fr False [] = []
    fr True [] = "1"
    fr c ('.':r) = '.' : fr c r
    fr _ ('a':r) = '0' : fr True r
    fr False r = r
    fr True ('9':r) = '0' : fr True r
    fr True (n:r) = succ n : r
  in fixRounding $ sw ++ "." ++ case w of
    0 -> go1 (m * 10)
    _ -> go2 (s0 - 1) (m * 10)

main = forM_ (zip [1..] $ distribution [(4,13)]) $ \(p,d) -> do
  putStrLn $ "Probability distribution for full houses: " ++ show p ++ " hands"
  forM_ (probabilities d) $ \(f,c) ->
    putStrLn $ show c ++ ": " ++ show3sf (f * 100) ++ "%"

Calculates the probability that of different numbers of players being dealt full houses when playing 5 card poker.