Hard Poker Odds problem solution

holdem.hs

{-# LANGUAGE MultiWayIf #-}

-- Solution to: https://www.reddit.com/r/dailyprogrammer/comments/6eublu/20170602_challenge_317_hard_poker_odds/

import Data.Function
import Data.List
import Data.Ord
import Data.Char
import Data.Maybe
import Control.Monad
import System.Environment
import qualified Data.Array.IO as A
import Text.Printf

data Suit = Hearts | Clubs | Diamonds | Spades
  deriving (Read, Show, Enum, Bounded, Eq, Ord)

data Rank = Two | Three | Four | Five | Six | Seven | Eight | Nine | Ten | Jack | Queen | King | Ace
  deriving (Read, Show, Enum, Bounded, Eq, Ord)

data Card = Card Rank Suit
  deriving (Read, Show, Bounded, Eq, Ord)

rank :: Card -> Rank
rank (Card r _) = r

suit :: Card -> Suit
suit (Card _ s) = s

type Hand = [Card]

data HandRank = HighCard Rank Rank Rank Rank Rank 
              | Pair Rank Rank Rank Rank
              | TwoPair Rank Rank Rank            -- high pair, low pair, kicker
              | ThreeKind Rank Rank Rank          -- two lowest kickers
              | Straight Rank                     -- low card
              | Flush Rank Rank Rank Rank Rank
              | FullHouse Rank Rank
              | FourKind Rank Rank
              | StraightFlush Rank
  deriving (Read, Eq, Ord)

evalHand :: [Card] -> HandRank
evalHand cards
  | a == d      = FourKind a e
  | b == e      = FourKind b a
  | a == c      = if d == e then FullHouse a d
                            else ThreeKind a d e
  | b == d      = ThreeKind b a e
  | c == e      = if a == b then FullHouse c a
                            else ThreeKind c a b
  | a == b      = if | c == d -> TwoPair a c e
                     | c == e -> TwoPair a c d
                     | d == e -> TwoPair a d c
                     | otherwise -> Pair a c d e
  | b == c      = if | d == e    -> TwoPair b d a
                     | otherwise -> Pair b a d e
  | c == d      = Pair c a b e
  | d == e      = Pair d a b c
  | isFlush     = if isStraight then StraightFlush a
                                else Flush a b c d e
  | isStraight  = Straight a
  | otherwise   = HighCard a b c d e
  where
    [a,b,c,d,e] = sortBy (flip compare) (map rank cards)
    isStraight = isNormalStraight || isAceStraight
    isNormalStraight = fromEnum a - fromEnum e == 4
    isAceStraight = (a == Ace) && (b == Five) && (e == Two)
    isFlush = all (== (suit (head cards))) [ suit c | c <- cards ]

subsequencesOfSize :: Int -> [a] -> [[a]]
subsequencesOfSize n xs = let l = length xs
                          in if n>l then [] else subsequencesBySize xs !! (l-n)
 where
   subsequencesBySize [] = [[[]]]
   subsequencesBySize (x:xs) = let next = subsequencesBySize xs
                             in zipWith (++) ([]:next) (map (map (x:)) next ++ [[]])

bestHand :: [Card] -> HandRank
bestHand avail = maximum [ evalHand h | h <- subsequencesOfSize 5 avail ]

whoWins :: [Card] -> [ [Card] ] -> (HandRank, [Int])
whoWins avail hands = 
  let (best, winners) = foldl' combine start  [ (bestHand (avail ++ h), i) | (i,h) <- zip [0..] hands ]
  in (best, winners)
  where combine (best, winners) (e, i) =
          case compare best e of
            LT -> (e, [i])
            EQ -> (best, (i:winners))
            GT -> (best, winners)
        start = (HighCard z z z z z, [])
          where z = minBound

allCards = [ Card r s | r <- [minBound..maxBound], s <- [ minBound..maxBound ] ]

main = do
  let h1 = [ Card Three Clubs, Card Seven Hearts ]
      h2 = [ Card Ace Spades,  Card Ten Spades ]
      h3 = [ Card Nine Spades, Card Two Diamonds ]
      h4 = [ Card King Clubs, Card Jack Clubs ]
      flop = [ Card Three Diamonds, Card Five Clubs, Card Nine Clubs ]
      avail = allCards \\ (h1 ++ h2 ++ h3 ++ h4 ++ flop)
      pairs = subsequencesOfSize 2 avail
      inc arr i w = do v <- A.readArray arr i; A.writeArray arr i (v+w)
  stats <- A.newArray (0,6) 0 :: IO (A.IOUArray Int Double)
  forM_ pairs $ \p -> do
    let (r, winners) = whoWins (p ++ flop) [h1,h2,h3,h4]
    inc stats 4 1
    let w = 1 / (fromIntegral (length winners))
    forM_ winners $ \i -> inc stats i w
    when (length winners > 1) $ inc stats 5 1 >> putStrLn "tie"
  n <- A.readArray stats 4
  ties <- A.readArray stats 5
  putStrLn $ "total games: " ++ show n
  putStrLn $ "tied games : " ++ show ties 
  forM_ [0..3] $ \i -> do
    a <- A.readArray stats i
    putStrLn $ show i ++ ": " ++ printf "%.1f" ( a/n*100 ) ++ "%"