Created
August 1, 2017 01:56
-
-
Save erantapaa/58ceb6032c5a30ac9de9d939cf88c394 to your computer and use it in GitHub Desktop.
Hard Poker Odds problem solution
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
{-# 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 ) ++ "%" | |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment