Poker Kata haskell

poker.hs

module Poker where
import Data.List

data Suit = Clubs | Diamonds | Hearts | Spades deriving (Show, Eq)

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

data Card = Card Rank Suit deriving Show
instance Eq Card where
    Card r s == Card r2 s2 = r == r2
instance Ord Card where
    Card r _ `compare` Card r2 _ = r `compare` r2

data Score = HighCard | Pair | TwoPair | ThreeOfAKind | Straight | Flush | FullHouse | FourOfAKind | StraightFlush | RoyalFlush deriving (Show, Ord, Eq)

rules = [
    -- (RoyalFlush, ),
    (StraightFlush, (\hand -> isStraight hand && isFlush hand)),
    (FourOfAKind, (\hand -> [4] == (filter (== 4) $ map length $ group hand) )),
    (FullHouse, (\hand -> [3, 2] == (filter (>= 2) $ map length $ group hand) )),
    (Flush, isFlush),
    (Straight, isStraight),
    (ThreeOfAKind, (\hand -> [3] == (filter (== 3) $ map length $ group hand) )),
    (TwoPair, (\hand -> [2, 2] == (filter (== 2) $ map length $ group hand) )),
    (Pair, (\hand -> (nub hand) /= hand)),
    (HighCard, (\ _ -> True ))
    ]

isStraight :: [Card] -> Bool
isStraight hand = let
        ranks = sort $ map (\(Card r s) -> r) hand
    in all (\(x,y)-> succ x == y) $ zip ranks (tail ranks)

isFlush :: [Card] -> Bool
isFlush hand = 1 == (length $ nub $ map (\(Card r s)-> s) hand)

tiebreaker :: [Card] -> [Card]
tiebreaker = ( map head ) . reverse . (sortOn length ) . group . sort

score :: [Card] -> ScoreWithTieBreaker
score hand = let
        handscore = (fst $ head $ filter (\ (sc, matcher) -> matcher hand) rules)
    in CP handscore ( tiebreaker hand )

data ScoreWithTieBreaker = CP Score [Card] deriving (Eq, Show)
instance Ord ScoreWithTieBreaker where
    CP sc1 tb1 `compare` CP sc2 tb2 = case sc1 `compare` sc2 of
        LT -> LT
        GT -> GT
        EQ -> tb1 `compare` tb2

Test.hs

-- cabal install hspec
-- runhaskell Test.hs

import Test.Hspec
import Test.QuickCheck
import Control.Exception (evaluate)

import Poker
import Data.List.Split

fromString :: String -> [Card]
fromString str = let
        parseSuit 'C' = Hearts
        parseSuit 'D' = Diamonds
        parseSuit 'H' = Hearts
        parseSuit 'S' = Spades
        parseRank x | x == "A" = Ace
                    | x == "J" = Jack
                    | x == "Q" = Queen
                    | x == "K" = King
                    | (read x) > 0 && (read x) < 11 = toEnum (read x) :: Rank
                    | otherwise = error "rank needs to be one of A2345678910JQK"
        parseCard (s:rs) = Card (parseRank rs ) (parseSuit s)
    in map parseCard $ splitOn " " str

getScore (CP s _) = s

main :: IO ()
main = hspec $ do
    describe "Basic Hand Score" $ do
        describe "Basic Hand Score" $ do
            it "pair" $ do
                getScore ( score (fromString "H2 S2 D4 S5 S6")) `shouldBe` Pair
            it "two pair" $ do
                getScore ( score (fromString "H2 S2 D5 S5 S6")) `shouldBe` TwoPair
            it "three of a kind" $ do
                getScore ( score (fromString "H2 S2 D2 S5 S6")) `shouldBe` ThreeOfAKind
            it "straight" $ do
                getScore ( score (fromString "H2 S3 D4 S5 S6")) `shouldBe` Straight
            it "flush" $ do
                getScore ( score (fromString "H2 H3 HJ H5 H6")) `shouldBe` Flush
            it "fullhouse" $ do
                getScore ( score (fromString "H2 S2 D2 C6 S6")) `shouldBe` FullHouse
            it "four of akind" $ do
                getScore ( score (fromString "H2 S2 D2 S2 S6")) `shouldBe` FourOfAKind
            it "straight flush" $ do
                getScore ( score (fromString "H2 H3 H4 H5 H6")) `shouldBe` StraightFlush

        describe "Suggested Test Cases" $ do
            it "white wins with highcard" $ do
                let black = score (fromString "H2 D3 S5 C9 DK")
                let white = score (fromString "C2 H3 S4 C8 HA")
                black < white `shouldBe` True
                getScore white `shouldBe` HighCard
            it "white wins with flush" $ do
                let black = score (fromString "H2 S4 C4 D2 H4")
                let white = score (fromString "S2 S8 SA SQ S3")
                black < white `shouldBe` True
                getScore white `shouldBe` Flush
            it "black wins with high card" $ do
                let black = score (fromString "H2 D3 S5 C9 DK")
                let white = score (fromString "C2 H3 S4 C8 HK")
                black > white `shouldBe` True
                getScore black `shouldBe` HighCard
            it "tie" $ do
                let black = score (fromString "H2 D3 S5 C9 DK")
                let white = score (fromString "D2 H3 C5 S9 HK")
                black == white `shouldBe` True

        describe "Highcard tiebreakers" $ do

            it "highcard tiebreaker" $ do
                let hand1 = score (fromString "H2 S3 D4 S5 S7")
                let hand2 = score (fromString "H2 S3 D4 S5 S8")
                hand1 < hand2 `shouldBe` True

            it "highcard tiebreaker eq" $ do
                let hand1 = score (fromString "H2 S3 D4 S5 S7")
                let hand2 = score (fromString "H2 S3 D4 S5 S7")
                hand1 == hand2 `shouldBe` True

        describe "One pair tiebreakers" $ do

            it "1pair tiebreaker" $ do
                let hand1 = score (fromString "H2 S3 D5 S5 S7")
                let hand2 = score (fromString "H8 S3 D5 S5 S9")
                hand1 < hand2 `shouldBe` True

            it "1pair tiebreaker group" $ do
                let hand1 = score (fromString "H2 S3 D5 S5 S7")
                let hand2 = score (fromString "H8 S3 D6 S6 S9")
                hand1 < hand2 `shouldBe` True

            it "1pair tiebreaker tie" $ do
                let hand1 = score (fromString "H9 S3 D5 S5 S7")
                let hand2 = score (fromString "H7 S3 D5 S5 S9")
                hand1 == hand2 `shouldBe` True

        describe "Two pair tiebreakers" $ do

            it "2pair tiebreaker lt kicker" $ do
                let hand1 = score (fromString "H3 S3 D5 S5 S7")
                let hand2 = score (fromString "H3 S3 D5 S5 S9")
                hand1 < hand2 `shouldBe` True

            it "2pair tiebreaker eq kicker" $ do
                let hand1 = score (fromString "H3 S3 D5 S5 S7")
                let hand2 = score (fromString "H3 S3 D5 S5 S7")
                hand1 == hand2 `shouldBe` True

            it "2pair tiebreaker lt smaller pair" $ do
                let hand1 = score (fromString "H3 S3 D5 S5 S7")
                let hand2 = score (fromString "H4 S4 D5 S5 S7")
                hand1 < hand2 `shouldBe` True

            it "2pair tiebreaker lt larger pair" $ do
                let hand1 = score (fromString "H3 S3 D5 S5 S7")
                let hand2 = score (fromString "H3 S3 D6 S6 S7")
                hand1 < hand2 `shouldBe` True

        describe "Three of a kind tiebreakers" $ do

            it "3oak tiebreaker lt kicker" $ do
                let hand1 = score (fromString "H3 S3 D3 S8 S7")
                let hand2 = score (fromString "H3 S3 D3 S5 S9")
                hand1 < hand2 `shouldBe` True

            it "3oak tiebreaker lt group" $ do
                let hand1 = score (fromString "H3 S3 D5 S3 S9")
                let hand2 = score (fromString "H5 S5 D5 S6 S7")
                hand1 < hand2 `shouldBe` True

            it "3oak tiebreaker eq kicker" $ do
                let hand1 = score (fromString "H3 S3 D3 S5 S7")
                let hand2 = score (fromString "H3 S3 D3 S5 S7")
                hand1 == hand2 `shouldBe` True

        describe "Straight tiebreakers" $ do

            it "Straight tiebreaker lt highcard" $ do
                let hand1 = score (fromString "H3 S4 D6 S5 S2")
                let hand2 = score (fromString "H3 S4 D6 S7 S5")
                hand1 < hand2 `shouldBe` True

            it "Straight tiebreaker eq " $ do
                let hand1 = score (fromString "H3 S4 D6 S5 S7")
                let hand2 = score (fromString "H3 S4 D6 S7 S5")
                hand1 == hand2 `shouldBe` True

        describe "Flush tiebreakers" $ do

            it "Flush tiebreaker lt highcard" $ do
                let hand1 = score (fromString "H3 H3 H5 H3 HK")
                let hand2 = score (fromString "H5 H5 H5 H6 HA")
                hand1 < hand2 `shouldBe` True

            it "Flush tiebreaker eq" $ do
                let hand1 = score (fromString "H3 H3 H3 H7 H5")
                let hand2 = score (fromString "S3 S3 S3 S5 S7")
                hand1 == hand2 `shouldBe` True

        describe "Fullhouse tiebreakers" $ do

            it "Fullhouse tiebreaker lt higher pair" $ do
                let hand1 = score (fromString "H8 S8 D8 S7 S7")
                let hand2 = score (fromString "H9 S9 D9 S5 S5")
                hand1 < hand2 `shouldBe` True

            it "Fullhouse tiebreaker eq higher pair" $ do
                let hand1 = score (fromString "H9 S9 D9 S7 S7")
                let hand2 = score (fromString "H9 S9 D9 S5 S5")
                hand1 == hand2 `shouldBe` False
            -- Note this cannot be a tie on the triplet level because there are not
            -- enough cards in a deck

        describe "Four of a kind tiebreakers" $ do

            it "4oak tiebreaker lt kicker" $ do
                let hand1 = score (fromString "H3 S3 D3 S3 S7")
                let hand2 = score (fromString "H3 S3 D3 S3 S9")
                hand1 < hand2 `shouldBe` True

            it "4oak tiebreaker lt group" $ do
                let hand1 = score (fromString "H3 S3 D3 S3 S9")
                let hand2 = score (fromString "H5 S5 D5 S5 S9")
                hand1 < hand2 `shouldBe` True

            it "4oak tiebreaker eq kicker" $ do
                let hand1 = score (fromString "H3 S3 D3 S3 S7")
                let hand2 = score (fromString "H3 S3 D3 S3 S7")
                hand1 == hand2 `shouldBe` True

        describe "Straight flush tiebreakers" $ do

            it "Straight flush tiebreaker lt highcard" $ do
                let hand1 = score (fromString "S3 S4 S6 S5 S2")
                let hand2 = score (fromString "D3 D4 D6 D7 D5")
                hand1 < hand2 `shouldBe` True

            it "Straight flush tiebreaker eq " $ do
                let hand1 = score (fromString "S3 S4 S6 S5 S7")
                let hand2 = score (fromString "D3 D4 D6 D7 D5")
                hand1 == hand2 `shouldBe` True

        -- describe "Aces can be low too" $ do
        -- describe "score 7 cards" $ do
        -- need to sort before I group in matchers