Created

Embed URL

HTTPS clone URL

SSH clone URL

You can clone with HTTPS or SSH.

Download Gist

Poker hands kata

View Poker.hs
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE OverloadedStrings #-}
 
module Main where
 
import GHC.Exts (sortWith)
 
import Data.Function (on)
import Data.List (maximumBy, sortBy, nub, foldl')
import qualified Data.Map.Strict as M
import Data.Maybe (isJust, fromJust)
import Data.Text (Text, unpack)
 
import Test.Hspec
import Test.Hspec.Runner
 
import Control.Applicative ((<$>))
import Control.Monad (void, forM_)
import System.Random.Shuffle (shuffleM)
import Text.Printf (printf)
 
data Suit = Spades
| Hearts
| Diamonds
| Clubs
deriving (Eq, Ord)
 
instance Show Suit where
show Spades = ""
show Hearts = ""
show Diamonds = ""
show Clubs = ""
 
data Rank = Digit Int
| Jack
| Queen
| King
| Ace
deriving (Eq, Ord)
 
instance Show Rank where
show Ace = "A"
show King = "K"
show Queen = "Q"
show Jack = "J"
show (Digit 10) = "T"
show (Digit d) = show d
 
instance Enum Rank where
toEnum = (!!) $ map Digit [2..10] ++ [Jack, Queen, King, Ace]
fromEnum (Digit 10) = 8
fromEnum (Digit n) = n-2
fromEnum Jack = 9
fromEnum Queen = 10
fromEnum King = 11
fromEnum Ace = 12
 
data Card = Card { suit :: Suit, rank :: Rank }
deriving (Eq, Ord)
 
instance Show Card where
show (Card s r) = show r ++ show s
 
defaultDeck :: [Card]
defaultDeck = [ Card s r | s <- [Spades, Hearts, Diamonds, Clubs], r <- [Digit 2 .. Ace] ]
newtype Hand = Hand { unHand :: [Card] }
deriving Eq
 
instance Show Hand where
show (Hand h) = show h
 
createHand :: [(Suit, Rank)] -> Hand
createHand hand
| length hand == 5 = Hand $ map (uncurry Card) hand
| otherwise = error "a hand should consist of exactly 5 cards"
 
cardRanks :: Hand -> [Rank]
cardRanks = sortBy (flip compare) . map rank . unHand
 
-- | the ranks given to this should be sorted (for example using cardRanks)
straight :: [Rank] -> Maybe Rank
straight [] = Nothing
straight ranks
| min' == Digit 2 =
if ranks' == [Digit 2 .. Digit 5] ++ [Ace]
then Just (Digit 5)
else matches
| otherwise = matches
where min' = minimum ranks
ranks' = reverse ranks
matches = if ranks' == take 5 [min'..Ace]
then Just (maximum ranks)
else Nothing
 
 
flush :: Hand -> Bool
flush = (== 1) . length . nub . map suit . unHand
 
-- | the ranks given to this should be sorted 8for example using cardRanks)
twoPair :: [Rank] -> Maybe (Rank, Rank)
twoPair ranks = case (first, second) of
(Just f, Just s) | f /= s -> Just (f,s)
(_,_) -> Nothing
where first = kindOf 2 ranks
second = kindOf 2 (reverse ranks)
 
type Signature = [(Int, Rank)]
 
-- | the ranks given to this should be sorted 8for example using cardRanks)
kindOf :: Int -> [Rank] -> Maybe Rank
kindOf n rs = kind (signature rs) n
 
kind :: Signature -> Int -> Maybe Rank
kind s n = lookup n s
 
-- | the ranks given to this should be sorted 8for example using cardRanks)
signature :: [Rank] -> Signature
signature [] = []
signature (r:rs) = collect (1,r) rs []
where collect (n,l) [] acc = reverse $ (n,l):acc
collect (n,l) (l':ls') acc
| l==l' = collect (n+1,l) ls' acc
| otherwise = collect (1,l') ls' $ (n,l):acc
 
type Hands = [Hand]
 
randomHands :: [Card] -> Int -> IO Hands
randomHands deck n = do
deck' <- shuffleM deck
return $ fst $ foldl takeHand ([], deck') [1..n]
where takeHand (acc, d) _ = ((Hand $ take 5 d):acc, drop 5 d)
 
poker :: Hands -> Hand
poker = maximumBy (compare `on` handRank)
 
data HandRank = HighCard Rank [Rank]
| Pair Rank [Rank]
| TwoPairs Rank Rank Rank
| ThreeOfAKind Rank [Rank]
| Straight Rank
| Flush [Rank]
| FullHouse Rank Rank
| FourOfAKind Rank Rank
| StraightFlush Rank
deriving (Eq, Ord, Show)
 
handRank :: Hand -> HandRank
handRank hand
| isJust str && flush hand = StraightFlush (fromJust str)
| isJust fourOfAKind = FourOfAKind (fromJust fourOfAKind) (fromJust single)
| isJust threeOfAKind && isJust twoOfAKind = FullHouse (fromJust threeOfAKind) (fromJust twoOfAKind)
| flush hand = Flush ranks
| isJust str = Straight (fromJust str)
| isJust threeOfAKind = ThreeOfAKind (fromJust threeOfAKind) ranks
| isJust pair2 = (\ (Just (h, l)) -> TwoPairs h l (fromJust single)) pair2
| isJust twoOfAKind = Pair (fromJust twoOfAKind) ranks
| otherwise = HighCard (maximum ranks) ranks
where ranks = cardRanks hand
sig = signature ranks
fourOfAKind = kind sig 4
threeOfAKind = kind sig 3
twoOfAKind = kind sig 2
single = kind sig 1
pair2 = twoPair ranks
str = straight ranks
 
classifyRank :: Hand -> Text
classifyRank hand =
case handRank hand of
(HighCard _ _) -> "High-Card "
(Pair _ _) -> "Pair "
(TwoPairs _ _ _) -> "Two-Pairs "
(ThreeOfAKind _ _) -> "3-of-a-Kind "
(Straight _) -> "Straight "
(Flush _) -> "Flush "
(FullHouse _ _) -> "Full-House "
(FourOfAKind _ _) -> "4-of-a-Kind "
(StraightFlush _) -> "Straight-Flush"
rankStats :: Hands -> [(Text, Int)]
rankStats = sortWith (negate . snd) . M.toList . foldl' count M.empty . map classifyRank
where count acc r = M.insertWith (+) r 1 acc
 
randomStats :: Int -> IO [(Text, Float)]
randomStats n = percentOf . sortWith (negate . snd) . M.toList <$> drawHands n M.empty
where drawHands n' m =
if n' == 0
then return m
else do
!r <- classifyRank . head <$> randomHands defaultDeck 1
let m' = M.insertWith (+) r 1 m
drawHands (n'-1) m'
percentOf :: [(Text, Int)] -> [(Text, Float)]
percentOf = map (\ (x,c) -> (x, 100 * fromIntegral c / fromIntegral n))
 
main :: IO ()
main = do
tests
putStrLn "Stats for poker-hands"
stats <- randomStats 1000000
forM_ stats (\ (r,p) -> putStrLn $ unpack r ++ "=\t" ++ printf "%.4f" p ++ "%")
 
 
tests :: IO ()
tests = void . hspecWith (defaultConfig { configColorMode = ColorAlways }) $ do
let sf = createHand [ (Clubs, Digit 6), (Clubs, Digit 7), (Clubs, Digit 8), (Clubs, Digit 9), (Clubs, Digit 10) ]
let fk = createHand [ (Diamonds, Digit 9), (Hearts, Digit 9), (Spades, Digit 9), (Clubs, Digit 9), (Diamonds, Digit 7) ]
let fh = createHand [ (Diamonds, Digit 10), (Clubs, Digit 10), (Hearts, Digit 10), (Clubs, Digit 7), (Diamonds, Digit 7) ]
let tP = createHand [ (Hearts, King), (Spades, Digit 10), (Diamonds, Digit 10), (Clubs, King), (Clubs, Ace) ]
let s1 = createHand [ (Spades, Ace), (Spades, Digit 2), (Spades, Digit 3), (Spades, Digit 4), (Clubs, Digit 5) ]
let s2 = createHand [ (Clubs, Digit 2), (Clubs, Digit 3), (Clubs, Digit 4), (Clubs, Digit 5), (Spades, Digit 6) ]
let p1 = createHand [ (Clubs, Digit 9), (Spades, Digit 9), (Clubs, Digit 4), (Clubs, Digit 5), (Spades, Digit 6) ]
let p2 = createHand [ (Clubs, Digit 9), (Spades, Digit 9), (Clubs, Digit 4), (Clubs, Digit 5), (Spades, Digit 7) ]
let p3 = createHand [ (Clubs, Digit 9), (Spades, Digit 9), (Clubs, Digit 4), (Clubs, Digit 5), (Spades, Ace) ]
 
describe "Testing poker with a couple of hands" $ do
context "finding the best hand with poker" $ do
it "returns the pair with the better kicker" $ do
poker [p1,p2] `shouldBe` p2
it "returns the pair with the better kicker - even if it's higher than the pair" $ do
poker [p1,p2,p3] `shouldBe` p3
it "returns the straight flush out of minor hands" $ do
poker [sf, fk, fh] `shouldBe` sf
it "returns four-of-a-kind over full-house" $ do
poker [fk, fh] `shouldBe` fk
it "returns full-house of two full-houses" $ do
poker [fh, fh] `shouldBe` fh
it "returns the only hand if only one is given" $ do
poker [fh] `shouldBe` fh
it "returns one of the hand if 100 equal hands are given" $ do
poker (sf : [fh | _ <- [1..100 :: Int]]) `shouldBe` sf
it "returns a low straight over a two pair" $ do
poker [tP, s1] `shouldBe` s1
it "picks a straight beginning at 2 over one beginning at Ace" $ do
poker [s2, s1] `shouldBe` s2
context "ranking hands with handRank" $ do
it "should rank the straight-flush correctly" $ do
handRank sf `shouldBe` StraightFlush (Digit 10)
it "should rank then four-of-a-kind correctly" $ do
handRank fk `shouldBe` FourOfAKind (Digit 9) (Digit 7)
it "should rank the full-house correctly" $ do
handRank fh `shouldBe` FullHouse (Digit 10) (Digit 7)
context "using kind/kindOf to extract information" $ do
it "should get 4 nines out of fk" $ do
kindOf 4 (cardRanks fk) `shouldBe` Just (Digit 9)
it "should not get 3 nines out of fk" $ do
kindOf 3 (cardRanks fk) `shouldBe` Nothing
it "should get 3 tens out of fh" $ do
kindOf 3 (cardRanks fh) `shouldBe` Just (Digit 10)
it "should get 2 sevens out of fh" $ do
kindOf 2 (cardRanks fh) `shouldBe` Just (Digit 7)
context "using twoPair to extract information" $ do
it "should get 2 Kings and 2 tens from `kH, 10S, 10D, kC, aC`" $ do
twoPair (cardRanks tP) `shouldBe` Just (King, Digit 10)
context "cardRanks returns the ranks of the cards in descending order" $ do
it "should get 2 Kings and 2 tens from `kH, 10S, 10D, kC, aC`" $ do
cardRanks tP `shouldBe` [Ace, King, King, Digit 10, Digit 10]
context "straight checks for a unbrocken line of numbers" $ do
it "should be true for [9,8,7,6,5]" $ do
straight [Digit 9, Digit 8, Digit 7, Digit 6, Digit 5] `shouldBe` Just (Digit 9)
it "should be true for [A,5,4,3,2]" $ do
straight [Ace, Digit 5, Digit 4, Digit 3, Digit 2] `shouldBe` Just (Digit 5)
it "should be true for [A,K,D,J,10]" $ do
straight [Ace, King, Queen, Jack, Digit 10] `shouldBe` Just Ace
it "should be false for [9,8,8,6,5]" $ do
straight [Digit 9, Digit 8, Digit 8, Digit 6, Digit 5] `shouldBe` Nothing
context "flush checks if all cards are in the same suit" $ do
it "should be true sf" $ do
flush sf `shouldBe` True
it "should be false for fk" $ do
flush fk `shouldBe` False
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
Something went wrong with that request. Please try again.