Main.hs

{-# LANGUAGE LambdaCase #-}

module Main where

import           Control.Applicative
import           Data.Foldable
import           Data.List.Split
import           Data.Maybe          (fromMaybe, mapMaybe)
import           Safe

import           Types

-- Boring parsing stuff

parseSuit :: Char -> Maybe CardSuit
parseSuit = \case
  'D' -> Just Diamonds
  'S' -> Just Spades
  'H' -> Just Hearts
  'C' -> Just Clubs
  _ -> Nothing

parseCardValue :: Char -> Maybe CardValue
parseCardValue = \case
  '2' -> Just Two
  '3' -> Just Three
  '4' -> Just Four
  '5' -> Just Five
  '6' -> Just Six
  '7' -> Just Seven
  '8' -> Just Eight
  '9' -> Just Nine
  'T' -> Just Ten
  'J' -> Just Jack
  'Q' -> Just Queen
  'K' -> Just King
  'A' -> Just Ace
  _ -> Nothing

parseCard :: String -> Maybe Card
parseCard = \case
  [value', suit'] -> Card <$> parseCardValue value' <*> parseSuit suit'
  _ -> Nothing

parseCards :: String -> Maybe [Card]
parseCards = traverse parseCard . splitOn " "

parseHands :: String -> Maybe (Hand, Hand)
parseHands str = case parseCards str of
  Just list | length list == 10 -> Just (mkHand (take 5 list), mkHand (drop 5 list))
  _         -> Nothing

-- Some utilities

-- Takes chunks of `n` elements from a list at a time and collects them.
-- Useful for splitting a hand into pairs or three of a kind.
ns :: Int -> [a] -> [[a]]
ns n list@(_:xs) = if length list < n then [] else take n list : ns n xs
ns _ []          = []

minValue :: Hand -> CardValue
minValue = value . head . cards

maxValue :: Hand -> CardValue
maxValue = value . last . cards

consecutive :: Hand -> Maybe CardValue -- Minimum Value
consecutive hand =
  if consecutiveValues . map value $ cards hand
  then
    Just . minValue $ hand
  else
    Nothing
  where
    consecutiveValues (x:y:xs)
      | Just x == predMay y = consecutiveValues (y:xs)
      | otherwise = False
    consecutiveValues _ = True

singleValue :: [Card] -> Maybe CardValue
singleValue = \case
  (Card a _:cards')
    | all (== a) (map value cards') -> Just a
  _ -> Nothing

singleSuit :: Hand -> Maybe CardSuit
singleSuit hand = case cards hand of
  Card _ a:cards'
    | all (== a) (map suit cards') -> Just a
  _ -> Nothing

-- Validators for certain hands

royalFlush :: Hand -> Maybe PokerHand
royalFlush hand = case cards hand of
  [Card Ten _, Card Jack _, Card Queen _, Card King _, Card Ace _]
    -> singleSuit hand *> pure RoyalFlush
  _ -> Nothing

straightFlush :: Hand -> Maybe PokerHand
straightFlush hand
  = singleSuit hand *> (StraightFlush <$> consecutive hand)

fourOfAKind :: Hand -> Maybe PokerHand
fourOfAKind hand = case cards hand of
  [a, b, c, d, e] -> FourOfAKind <$> (singleValue [b, c, d, e] <|> singleValue [a, b, c, d])
  _               -> Nothing

fullHouse :: Hand -> Maybe PokerHand
fullHouse hand = case cards hand of
  [a, b, c, d, e] ->
    (FullHouse <$> singleValue [c, d, e] <*> singleValue [a, b])
    <|>
    (FullHouse <$> singleValue [a, b, c] <*> singleValue [d, e])
  _ -> Nothing

straight :: Hand -> Maybe PokerHand
straight hand = Straight <$> consecutive hand

flush :: Hand -> Maybe PokerHand
flush hand = singleSuit hand *> pure (Flush (minValue hand))

threeOfAKind :: Hand -> Maybe PokerHand
threeOfAKind hand = ThreeOfAKind <$> (asum . fmap singleValue . reverse . ns 3 $ cards hand)

-- Note these operate on linear combinations of the tuples in the hand
twoPairs :: Hand -> Maybe PokerHand
twoPairs hand = case cards hand of
  [a, b, c, d, e] ->
    (TwoPairs <$> singleValue [b, c] <*> singleValue [d, e])
    <|>
    (TwoPairs <$> singleValue [a, b] <*> singleValue [d, e])
    <|>
    (TwoPairs <$> singleValue [a, b] <*> singleValue [c, d])
  _ -> Nothing

pair :: Hand -> Maybe PokerHand
pair hand = Pair <$> (asum . fmap singleValue $ reverse $ ns 2 $ cards hand)

highCard :: Hand -> PokerHand
highCard = HighCard . maxValue

pokerHand :: Hand -> PokerHand
pokerHand hand = fromMaybe (highCard hand) $ asum
  [ royalFlush hand
  , straightFlush hand
  , fourOfAKind hand
  , fullHouse hand
  , flush hand
  , straight hand
  , threeOfAKind hand
  , twoPairs hand
  , pair hand
  ]

-- The actual game

highCardFight :: [Card] -> [Card] -> Bool
highCardFight (x:xs) (y:ys)
  | value x < value y = False
  | value x > value y = True
  | otherwise = highCardFight xs ys
highCardFight _ _ = False

player1Wins :: String -> Maybe Bool
player1Wins str = do
  (h1, h2) <- parseHands str
  let ph1 = pokerHand h1
      ph2 = pokerHand h2
  case ph1 `compare` ph2 of
      LT -> Just False
      GT -> Just True
      EQ -> Just $ highCardFight (reverse $ cards h1) (reverse $ cards h2)

player1WinCount :: [String] -> Int
player1WinCount = length . filter id . mapMaybe player1Wins

main :: IO ()
main = do
  matches <- lines <$> readFile "poker.txt"
  print $ player1WinCount matches

Types.hs

module Types (
    CardValue(..),
    CardSuit(..),
    Card(..),
    PokerHand(..),
    Hand,
    -- ^ Just the data type, not the constructor
    cards,
    mkHand,
    -- ^ Smart constructor
) where

import Data.List (sortBy)
import Data.Ord (comparing)

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

data CardSuit
  = Diamonds | Spades | Hearts | Clubs
    deriving (Show, Eq, Enum, Bounded)

data Card = Card
  { value :: CardValue
  , suit  :: CardSuit
  } deriving (Show, Eq, Bounded)

newtype Hand = Hand { cards :: [Card] }
  deriving (Show, Eq)

normalize :: [Card] -> [Card]
normalize = sortBy (comparing value)

mkHand :: [Card] -> Hand
mkHand = Hand . normalize

data PokerHand
  = HighCard CardValue
  | Pair CardValue
  | TwoPairs
      CardValue -- First pair
      CardValue -- Second pair
  | ThreeOfAKind CardValue
  | Straight CardValue -- Lowest value
  | Flush CardValue
  | FullHouse
      CardValue -- Three of a kind
      CardValue -- Pair
  | FourOfAKind CardValue
  | StraightFlush
    CardValue -- Lowest Value
  | RoyalFlush
    deriving (Show, Eq, Ord)