Kata Poker Hands with Haskell

PokerHands.hs

module Main where

import Data.List
import Data.Monoid
import Data.Maybe

main :: IO ()
main = do
  interact process
  where
    process input = unlines $ map (\line -> show $ fromJust $ (uncurry winner) $ parseInput line) (lines input)

parseInput :: String -> (Player, Player)
parseInput input =
  (Player name1 (CardOnHand c11 c12 c13 c14 c15), Player name2 (CardOnHand c21 c22 c23 c24 c25))
  where
    ws = words input
    p1input = take 6 ws
    p2input = drop 6 ws
    name1 = takeWhile (\c -> c /= ':') (head p1input)
    name2 = takeWhile (\c -> c /= ':') (head p2input)
    [c11, c12, c13, c14, c15] = map parseCard (drop 1 p1input)
    [c21, c22, c23, c24, c25] = map parseCard (drop 1 p2input)

data Player = Player { playerName :: String
                     , playerCards :: CardOnHand
                     } deriving (Eq, Show)

parseCard :: String -> Card
parseCard str = Card (parseValue (head str)) (parseSuit (last str))

parseSuit :: Char -> Suit
parseSuit c = case c of
                'C' -> Club
                'D' -> Diamond
                'H' -> Heart
                'S' -> Spade

parseValue :: Char -> Value
parseValue c = case c of
                 '2' -> V2
                 '3' -> V3
                 '4' -> V4
                 '5' -> V5
                 '6' -> V6
                 '7' -> V7
                 '8' -> V8
                 '9' -> V9
                 'T' -> VT
                 'J' -> VJ
                 'Q' -> VQ
                 'K' -> VK
                 'A' -> VA

type Name = String
data Winner = Winner Name PokerHand | Tie

winner :: Player -> Player -> Maybe Winner
winner p1 p2 = do
  pokerHand1 <- cardOnHandToPokerHand $ playerCards p1
  pokerHand2 <- cardOnHandToPokerHand $ playerCards p2

  return $ case compare pokerHand1 pokerHand2 of
             GT -> Winner (playerName p1) pokerHand1
             LT -> Winner (playerName p2) pokerHand2
             EQ -> Tie

instance Show Winner where
  show winner = case winner of
                  Tie -> "Tie."
                  Winner name pokerHand -> name <> " wins. - with " <> displayPokerHand pokerHand

data CardOnHand = CardOnHand Card Card Card Card Card deriving (Eq, Show)

data Card = Card { val :: Value
                 , suit :: Suit
                 } deriving (Eq, Show)


data Suit = Club | Diamond | Heart | Spade deriving (Eq, Show)
data Value = V2 | V3 | V4 | V5 | V6 | V7 | V8 | V9 | VT | VJ | VQ | VK | VA deriving (Eq, Ord, Enum)
instance Show Value where
  show VJ = "Jack"
  show VQ = "Queen"
  show VK = "King"
  show VA = "Ace"
  show v = show $ (fromEnum v + 2)

data PokerHand = HighCard Value Value Value Value Value
               | Pair Value Value Value Value
               | TwoPairs Value Value Value
               | ThreeOfAKind Value Value Value
               | Straight Value Value Value Value Value
               | Flush Value Value Value Value Value
               | FullHouse Value Value
               | FourOfAKind Value Value
               | StraightFlush Value Value Value Value Value
               deriving (Eq, Ord, Show)

displayPokerHand :: PokerHand -> String
displayPokerHand pokerHand = case pokerHand of
                               (HighCard v _ _ _ _) -> "high card: " <> show v
                               (Pair v _ _ _) -> "one pair of: " <> show v
                               (TwoPairs v1 v2 _) -> "two pairs: " <> show v1 <> " over " <> show v2
                               (ThreeOfAKind v _ _) -> "three of a kind: " <> show v
                               (Straight v _ _ _ _) -> "straight: " <> show v <> " high"
                               (Flush v _ _ _ _) -> "flush: " <> show v <> " high"
                               (FullHouse v1 v2) -> "full house: " <> show v1 <> " over " <> show v2
                               (FourOfAKind v1 _) -> "four of a kind: " <> show v1
                               (StraightFlush v _ _ _ _) -> "straight flush: " <> show v <> " high"

cardOnHandToPokerHand :: CardOnHand -> Maybe PokerHand
cardOnHandToPokerHand hand = getFirst
                             $ mconcat
                             $ map First [ rank hand |
                                           rank <- [ straightFlush
                                                   , fourOfAKind
                                                   , fullHouse
                                                   , flush
                                                   , straight
                                                   , threeOfAKind
                                                   , twoPairs
                                                   , pair
                                                   , highCard ]]

straightFlush :: CardOnHand -> Maybe PokerHand
straightFlush hand =
  if sameSuit (cards hand)  && consecutiveValue (cards hand) then
    Just $ StraightFlush c1 c2 c3 c4 c5
  else
    Nothing
  where
    rv = revVals hand
    c1 = rv !! 0
    c2 = rv !! 1
    c3 = rv !! 2
    c4 = rv !! 3
    c5 = rv !! 4

fourOfAKind :: CardOnHand -> Maybe PokerHand
fourOfAKind hand =
  if (length $ head grps) == 4 then
    Just $ FourOfAKind c1 c2
  else
    Nothing
  where
    grps = groupRevVals hand
    c1 = (head.head $ grps)
    c2 = (head.last $ grps)

fullHouse :: CardOnHand -> Maybe PokerHand
fullHouse hand =
  if (length $ head grps) == 3 && (length grps) == 2 then
    Just $ FullHouse c1 c2
  else
    Nothing
  where
    grps = groupRevVals hand
    c1 = (head.head $ grps)
    c2 = (head.last $ grps)

flush :: CardOnHand -> Maybe PokerHand
flush hand =
  if sameSuit (cards hand) then
    Just $ Flush c1 c2 c3 c4 c5
  else
    Nothing
  where
    rv = revVals hand
    c1 = rv !! 0
    c2 = rv !! 1
    c3 = rv !! 2
    c4 = rv !! 3
    c5 = rv !! 4

straight :: CardOnHand -> Maybe PokerHand
straight hand =
  if consecutiveValue (cards hand) then
    Just $ Straight c1 c2 c3 c4 c5
  else
    Nothing
  where
    rv = revVals hand
    c1 = rv !! 0
    c2 = rv !! 1
    c3 = rv !! 2
    c4 = rv !! 3
    c5 = rv !! 4

threeOfAKind :: CardOnHand -> Maybe PokerHand
threeOfAKind hand =
  if (length $ head grps) == 3 && (length grps) == 3 then
    Just $ ThreeOfAKind c1 c2 c3
  else
    Nothing
  where
    grps = groupRevVals hand
    c1 = (head.head $ grps)
    c2 = (head (grps !! 1))
    c3 = (head.last $ grps)

twoPairs :: CardOnHand -> Maybe PokerHand
twoPairs hand =
  if (length $ head grps) == 2 && (length grps) == 3 then
    Just $ TwoPairs c1 c2 c3
  else
    Nothing
  where
    grps = groupRevVals hand
    c1 = (head.head $ grps)
    c2 = (head (grps !! 1))
    c3 = (head.last $ grps)

pair :: CardOnHand -> Maybe PokerHand
pair hand =
  if (length $ head grps) == 2 && (length grps) == 4 then
    Just $ Pair c1 c2 c3 c4
  else
    Nothing
  where
    grps = groupRevVals hand
    c1 = (head.head $ grps)
    c2 = (head (grps !! 1))
    c3 = (head (grps !! 2))
    c4 = (head.last $ grps)

highCard :: CardOnHand -> Maybe PokerHand
highCard hand =
  if (length grps) == 5 then
    Just $ HighCard c1 c2 c3 c4 c5
  else
    Nothing
  where
    grps = groupRevVals hand
    c1 = (head (grps !! 0))
    c2 = (head (grps !! 1))
    c3 = (head (grps !! 2))
    c4 = (head (grps !! 3))
    c5 = (head (grps !! 4))

cards :: CardOnHand -> [Card]
cards (CardOnHand c1 c2 c3 c4 c5) = [c1, c2, c3, c4, c5]

revVals :: CardOnHand -> [Value]
revVals hand = reverse $ sort $ map val $ cards hand

groupRevVals :: CardOnHand -> [[Value]]
groupRevVals hand = reverse $ sortBy compareVals $ groupBy (==) $ revVals hand

sameSuit (x:xs) = all (\Card{suit = s} -> s == (suit x)) xs

consecutiveValue cards =
  let
    xs = sort $ map (fromEnum.val) cards
  in
    all (== -1) $ zipWith (-) xs (drop 1 xs)

compareVals :: [Value] -> [Value] -> Ordering
compareVals vs1 vs2 = case lenOrdering of
                        EQ -> compare (head vs1) (head vs2)
                        _  -> lenOrdering
  where
    lenOrdering = compare (length vs1) (length vs2)