Poker hand identifier

Question

Inspired by this post (along with a number of other people by the looks of it), I created a poker hand identifier with a very similar format. Note that the syntax of the hands is a little different to make parsing easier - rather than "A:C K:C Q:C J:C 10:C", the input is of the form "[(A,C),(K,C),(Q,C),(J,C),(10,C)]".

The code works correctly for the sample inputs in the post, I'm more concerned about coding style and elegance. For example, I've used pointfree style and the Maybe monad (with guard and isJust) where I can so it's not very consistent. getPair doesn't seem very nice but it does save on a reasonable amount of boilerplate; am I right in thinking that returning ((Card,Card),Hand) instead of (Card,Card,Hand) would make the pattern matching on it slightly nicer?

Example usage:

identifyHand "[(5,H),(5,D),(A,S),(10,D),(5,C)]" == "Three of a kind"
identifyHand "[(2,H),(3,H),(4,H),(5,H),(A,D)]"  == "High card: A"

pokerhands.hs

import Data.List (sort, deleteBy, nub)
import Data.Maybe (isJust)
import Control.Monad (guard)
import Data.Function (on)

main :: IO ()
main = readFile "hands.txt" >>= putStrLn . unlines . map identifyHand . lines

-------------------------
-- Types and instances --
-------------------------

type Hand = [Card]
type Card = (Value,Suit)

-- Num n is valid for 2 <= n <= 10
data Value = Num Int | Jack | Queen | King | Ace
    deriving (Eq, Ord)

-- Clubs | Diamonds | Hearts | Spades
data Suit = C | D | H | S
    deriving (Read, Show, Eq)

data Combination
    = Royal
    | StraightFlush
    | Four
    | FullHouse
    | Flush
    | Straight
    | Three
    | TwoPair
    | Pair
    | High Value

instance Show Value where
    show (Num n) = show n
    show Jack    = "J"
    show Queen   = "Q"
    show King    = "K"
    show Ace     = "A"

instance Read Value where
   -- readsPrec :: Int -> String -> [(Value,String)]
   -- p.s. I do not really know how readsPrec works
   readsPrec _ ('J':xs) = [(Jack ,xs)]
   readsPrec _ ('Q':xs) = [(Queen,xs)]
   readsPrec _ ('K':xs) = [(King ,xs)]
   readsPrec _ ('A':xs) = [(Ace  ,xs)]
   readsPrec _ xs = case reads xs of
       ((n,xs'):_) | n >= 2 && n <= 10
                       -> [(Num n,xs')]
       _               -> []

instance Show Combination where
    show Royal         = "Royal flush"
    show StraightFlush = "Straight flush"
    show Four          = "Four of a kind"
    show FullHouse     = "Full house"
    show Flush         = "Flush"
    show Straight      = "Straight"
    show Three         = "Three of a kind"
    show TwoPair       = "Two pair"
    show Pair          = "One pair"
    show (High v)      = "High card: " ++ show v

-----------------------
-- Identifying hands --
-----------------------

identifyHand :: String -> String
identifyHand s = case reads s of
    ((h,_):_) | nub h /= h   -> "ERROR: Duplicate card"
              | length h < 5 -> "ERROR: Too few cards"
              | length h > 5 -> "ERROR: Too many cards"
              | otherwise    -> show (getComb h)
    _                        -> "ERROR: parse error"

getComb :: Hand -> Combination
getComb h
    | isStraight h
      && isFlush h  = if isRoyal h then Royal else StraightFlush
    | isFour h      = Four
    | isFullHouse h = FullHouse
    | isFlush h     = Flush
    | isStraight h  = Straight
    | isThree h     = Three
    | isTwoPair h   = TwoPair
    | isPair h      = Pair
    | otherwise     = High . maximum . map fst $ h

isRoyal :: Hand -> Bool
-- h must be a straight flush
isRoyal h = maximum (map fst h) == Ace

isStraight :: Hand -> Bool
isStraight = isConsecutive . sort . map fst

isFlush :: Hand -> Bool
isFlush h = all (x==) xs
    where (x:xs) = map snd h

isFour :: Hand -> Bool
isFour h = isJust $ do
    ((c1,_),(_,_),h') <- getPair h
    ((c2,_),(_,_),_ ) <- getPair h'
    guard $ c1 == c2

isFullHouse :: Hand -> Bool
isFullHouse h = isJust $ do
    (_,_,h') <- getPair h
    guard (isThree h')

isThree :: Hand -> Bool
isThree h = case getPair h of
    Just ((c1,_),(c2,_),h') -> any (`elem` [c1,c2]) (map fst h')
    Nothing                 -> False

isTwoPair :: Hand -> Bool
isTwoPair h = isJust $ do
    (_,_,h') <- getPair h
    getPair h'

isPair :: Hand -> Bool
isPair = isJust . getPair

----------------------
-- Helper functions --
----------------------

getPair :: Hand -> Maybe (Card,Card,Hand)
-- if the hand has at least one pair then the two cards
-- from the first pair are removed from the hand and then
-- that pair and the remaining hand are returned
getPair ((c,s):h) = case lookup c h of
     Just s' -> Just ((c,s),(c,s')
                     ,deleteBy ((==) `on` fst) (c,undefined) h)
     Nothing -> getPair h
getPair [] = Nothing

isConsecutive :: [Value] -> Bool
isConsecutive (x:x1:xs) = isNext x x1 && isConsecutive (x1:xs)
isConsecutive _ = True

isNext :: Value -> Value -> Bool
isNext (Num 10) Jack     = True
isNext (Num n)  (Num n') = n' == n+1
isNext Jack     Queen    = True
isNext Queen    King     = True
isNext King     Ace      = True
isNext _        _        = False

Answer 1

Some more ideas - you could have an Enum instance / isNext derived without all the boilerplate if you defined Value either as

{-# LANGUAGE GeneralizedNewtypeDeriving #-}
newtype Value = Val Int
   deriving (Eq, Ord, Enum, Bounded)

or as

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

depending on whether that seems like a good idea to you or not. The latter representation is better than it might appear at first - after all, the Enum instance allows you to easily convert to and from numerical values using toEnum / fromEnum, so you don't have to change your Read & Show instances much.

---

Also, I feel like your hand matching could be simplified if you preprocessed the hand a bit:

getComb :: Hand -> Combination
getComb h
     ...
  where hg = sortBy (compare `on` length) $
             groupBy ((==) `on` fst) $
             sortBy (compare `on` fst) h

This "grouped" hand representation has the nice property that you can write hand group checks like follows:

type HandGrouped = [[Card]]

isPair :: HandGrouped -> Maybe HandGrouped
isPair ([_,_]:xs) = Just xs
isPair _          = Nothing

isTwoPair :: HandGrouped -> Maybe HandGrouped
isTwoPair h = isPair h >>= isPair

---

Hm, but isn't your implementation actually quite incomplete? Right now, you can't distinguish between ace-high and jack-high straights, for example, or equal pairs with different kickers.

Here's a quick (untested) sketch of how I think you could build the program to have all the mentioned features, using slightly more involved trickery:

-- Low-value combinations first, so it works well with Value
data Combination = HighCard | Pair Value | TwoPair Value Value | ...
    deriving Ord

-- Combination, remaining cards / kicker. Implicit Ord instance gives
-- you card value order!
type Evaluation = (Combination, HandGrouped)

getPair, getTwoPair :: HandGrouped -> Maybe Evaluation
getPair ([c,_]:xs) = Just (Pair (fst c), xs)
getPair _          = Nothing
getTwoPair xs      = do
  (Pair v1, xs') <- getPair xs
  (Pair v2, xs'') <- getPair xs'
  return (TwoPair v1 v2, xs'')

getCombination :: HandGrouped -> Maybe Evaluation
getCombination xs = msum
  [ ...
  , getTwoPair xs
  , getPair xs
  , return (HighCard, xs)
  ]

Using that msum returns the first value in the list that is not Nothing.

Answer 2

So here is my version of your program. It took some pragmas, but I hope it is alright?

{-# LANGUAGE FlexibleInstances,IncoherentInstances,ScopedTypeVariables #-}
import Data.List (sort, deleteBy, nub)
import Data.Maybe (isJust)
import Control.Monad (guard)
import Data.Function (on)

main :: IO ()
main = readFile "hands.txt" >>= putStrLn . unlines . map identifyHand . lines

-------------------------
-- Types and instances --
-------------------------

type Hand = [Card]
type Card = (Value,Suit)

-- Num n is valid for 2 <= n <= 10
data Value = Num Int | Jack | Queen | King | Ace
    deriving (Eq, Ord)

I removed the Combination data type because it did not seem to be adding any use to the program. Instead I modified the show to be more intelligent.

I also got rid of isNext because it is actually trying to do an Enum poorly. So instead we have an Enum and a Bound (They are not completely necessary, but going by the spirit of building the language in which to describe the problem first, I would say they are justified.)

instance Enum Value where
  succ King = Ace
  succ Queen = King
  succ Jack = Queen
  succ (Num 10) = Jack
  succ (Num i) = Num $ succ i

  pred Ace = King
  pred Queen = Jack
  pred King = Queen
  pred Jack = (Num 10)
  pred (Num i) = Num (pred i)

  fromEnum (Num i) = i
  fromEnum v = succ $ fromEnum (pred v)
  toEnum i | i <= 10 = Num i
  toEnum i = pred $ toEnum (succ i)

instance Bounded Value where
  minBound = Num 2
  maxBound = Ace

data Suit = C | D | H | S
    deriving (Read, Show, Eq)

instance Show Value where
    show (Num n) = show n
    show Jack    = "J"
    show Queen   = "Q"
    show King    = "K"
    show Ace     = "A"

instance Read Value where
   readsPrec _ ('J':xs) = [(Jack ,xs)]
   readsPrec _ ('Q':xs) = [(Queen,xs)]
   readsPrec _ ('K':xs) = [(King ,xs)]
   readsPrec _ ('A':xs) = [(Ace  ,xs)]
   readsPrec _ xs = case reads xs of
       ((n,xs'):_) | n >= 2 && n <= 10
                       -> [(Num n,xs')]
       _               -> []

So, our show changes.

instance Show [Card] where
    show h
      | isStraight  h
        && isFlush  h   = if isRoyal h then "Royal" else "Straight flush"
      | isFour      h   = "Four of a kind"
      | isFullHouse h   = "Full house"
      | isFlush     h   = "Flush"
      | isStraight  h   = "Straight"
      | isThree     h   = "Three of a kind"
      | isTwoPair   h   = "Two pair"
      | isPair      h   = "One pair"
      | otherwise       = "High card: " ++ show (maximum . map fst $ h)

-----------------------
-- Identifying hands --
-----------------------

identifyHand :: String -> String
identifyHand s = case reads s of
    ((h::Hand,_):_) | nub h /= h   -> "ERROR: Duplicate card"
              | length h < 5 -> "ERROR: Too few cards"
              | length h > 5 -> "ERROR: Too many cards"
              | otherwise    -> show h
    _                        -> "ERROR: parse error"

isRoyal :: Hand -> Bool
isRoyal h = maximum (map fst h) == Ace

isStraight :: Hand -> Bool
isStraight = isConsecutive . sort . map fst

When possible, define generic methods, and use them

isFlush :: Hand -> Bool
isFlush = same . (map snd)

same :: Eq a => [a] -> Bool
same = (1 ==) . length . nub

I found isThree to be rather similar to isFour. So in the interests of consistency they are defined similarly

isFour :: Hand -> Bool
isFour h = isJust $ do
    ((c1,_),(_,_),h') <- getPair h
    ((c2,_),(_,_),_ ) <- getPair h'
    guard $ c1 == c2

isThree :: Hand -> Bool
isThree h = isJust $  do
    ((c1,_),x,h') <- getPair h
    ((_,_),(c2,_),_ ) <- getPair (x:h')
    guard $ c1 == c2

I like the cleanliness of chaining rather than the do notation, but that is subjective.

isFullHouse :: Hand -> Bool
isFullHouse h = isJust $ return h >>= getPair >>= (guard . isThree . remHand)

isTwoPair :: Hand -> Bool
isTwoPair h = isJust $ return h >>= getPair >>= (getPair . remHand)

isPair :: Hand -> Bool
isPair = isJust . getPair

----------------------
-- Helper functions --
----------------------

Did a little bit of modifications here too. I feel this is more idiomatic than your version.

-- if the hand has at least one pair then the two cards
-- from the first pair are removed from the hand and then
-- that pair and the remaining hand are returned
getPair :: Hand -> Maybe (Card,Card,Hand)
getPair (x:h) = case h'' of
    [] -> Nothing
    _  -> Just (x, head h'', h' ++ tail h'')
  where (h',h'') = break (\ x' -> fst x' == fst x) h

remHand :: (Card,Card,Hand) -> Hand
remHand (_,_,h) = h

A side benefit is isConsecutive which is now applicable for any arrays that have Enum defined for their elements.

isConsecutive :: (Enum a, Eq a) => [a] -> Bool
isConsecutive (x:xs) 
  | x == maxBound = False
  | otherwise = succ x == (head xs) && isConsecutive xs

-- isConsecutive (x:xs) = snd $ foldl (\(x,b) y -> (y, succ x == y && b)) (x,True) xs

I would encourage you to add a quickcheck to these functions.