Poker Hand Evaluator in Haskell

Question

The idea is to represent a hand as a list of cards and create a frequency mapping, which can then be used to identify what rank of hand you have and arrange your hand in a way that allows the Ord type class to compare hands of the same rank.

My solution feels a little cumbersome, however this is a lot nicer than anything I could have written imperatively, as poker hand evaluation is a little awkward in general.

card.hs

module Card
(Card(..), Suit(..), Rank(..), rankVal) where

data Card = Card Suit Rank

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

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

instance Eq Card where 
    Card _ rank1 == Card _ rank2 = rank1 == rank2

instance Ord Card where 
    Card _ rank1 `compare` Card _ rank2 = rank1 `compare` rank2

instance Show Card where 
    show (Card suit rank) = "(" ++ (show suit) ++ ", " ++ (show rank) ++ ")"

rankVal :: Rank -> Int
rankVal Two = 2
rankVal Three = 3
rankVal Four = 4
rankVal Five = 5
rankVal Six = 6
rankVal Seven = 7
rankVal Eight = 8
rankVal Nine = 9
rankVal Ten = 10
rankVal Jack = 10
rankVal Queen = 10
rankVal King = 10
rankVal Ace = 11

solver.hs

module Hand
(Card(..), Suit(..), Rank(..), compareHands) where

import Card
import Data.List

--TODO Add tests for every function

type Hand = [Card]

-- Cards arranged such that `compare` will return which hand is better
type RelativeRank = [Card]

-- A mapping between an element in a list and it's frequency
-- For example, [1, 2, 2, 2, 2] is [(1,1),(2,4),(2,4),(2,4),(2,4)]
type FreqMapping a = [(a, Int)]

data HandRank = 
      HighCard 
    | Pair
    | TwoPairs 
    | ThreeOfKind
    | Straight
    | Flush
    | FullHouse 
    | FourOfKind 
    | StraightFlush
    | RoyalFlush 
  
    deriving (Show, Eq, Ord, Enum, Bounded)

compareHands :: Hand -> Hand -> Ordering
compareHands hand1 hand2 = (handRank1, relativeRank1) `compare` (handRank2, relativeRank2)

    where relativeRank1 = computeRelativeRank hand1 handRank1
          relativeRank2 = computeRelativeRank hand2 handRank2
          handRank1 = computeHandRank hand1
          handRank2 = computeHandRank hand2

maxVal :: Hand -> Int
maxVal = foldr (\(Card _ rank) acc -> max acc $ rankVal rank) 0

isStraight :: Hand -> Bool
isStraight = isStraightHelper . sort

isStraightHelper :: Hand -> Bool
isStraightHelper [] = True
isStraightHelper [x] = True
isStraightHelper (card1:card2:xs) = isValidStep && isStraightHelper (card2:xs)
    where isValidStep = 1 + rankVal rank1 == rankVal rank2
          (Card _ rank1) = card1
          (Card _ rank2) = card2

isFlush :: Hand -> Bool
isFlush (x:xs) = (replicate len $ suit x) == (map suit (x:xs))
    where suit = (\(Card suit _) -> suit)
          len = length (x:xs)

computeHandRank :: Hand -> HandRank
computeHandRank xs 
    | flush && straight && maxVal xs == 12 = RoyalFlush
    | flush && straight                    = StraightFlush
    | freqList == [1, 4, 4, 4, 4]          = FourOfKind
    | freqList == [2, 2, 3, 3, 3]          = FullHouse
    | flush                                = Flush
    | straight                             = Straight
    | freqList == [1, 1, 3, 3, 3]          = ThreeOfKind
    | freqList == [1, 2, 2, 2, 2]          = TwoPairs
    | freqList == [1, 1, 1, 2, 2]          = Pair
    | otherwise                            = HighCard
   
    where straight = isStraight xs
          flush = isFlush xs
          freqList = sort $ map snd $ computeFreqMapping xs 

-- Used to compare hands of the same rank 
computeRelativeRank :: Hand -> HandRank -> RelativeRank
computeRelativeRank xs handRank 
    | handRank == RoyalFlush    = []
    | handRank == StraightFlush = revSort xs
    | handRank == FourOfKind    = valsAtFreq 4 freqs ++ valsAtFreq 1 freqs
    | handRank == FullHouse     = valsAtFreq 3 freqs ++ valsAtFreq 2 freqs
    | handRank == Flush         = revSort xs
    | handRank == Straight      = revSort xs
    | handRank == ThreeOfKind   = valsAtFreq 3 freqs ++ (revSort $ valsAtFreq 1 freqs)
    | handRank == TwoPairs      = (maximum $ valsAtFreq 2 freqs) : (minimum $ valsAtFreq 2 freqs) : (valsAtFreq 1 freqs)
    | handRank == Pair          = valsAtFreq 2 freqs ++ (revSort $ valsAtFreq 1 freqs)
    | handRank == HighCard      = revSort xs

    where freqs = computeFreqMapping xs 

computeFreqMapping :: (Eq a) => [a] -> FreqMapping a
computeFreqMapping xs = map (\elem -> (elem, elemCount elem xs)) xs

-- Return number of times an element appears in a list
elemCount :: (Eq a) => a -> [a] -> Int
elemCount elem = length . filter (elem==)

--Return set of all values that appear at a given frequency in the freqency mapping
valsAtFreq :: (Ord a) => Int -> FreqMapping a -> [a]
valsAtFreq freq xs = [fst x | x <- xs, snd x == freq]

revSort :: (Ord a) => [a] -> [a]
revSort = reverse . sort
```

Answer 1

Just a few ideas - successfully compiled, not tested further.

Using record syntax yields the functions suit, rank for "free", i.e.

data Card = Card { suit :: Suit
                 , rank :: Rank }

allows for shorter definitions:

instance Eq Card where 
    c1 == c2 = rank c1 == rank c2

instance Ord Card where 
    c1 `compare` c2 = rank c1 `compare` rank c2

Similarly the following three functions become clearer.

maxVal :: Hand -> Int
maxVal = maximum . map (rankVal . rank)

isStraight :: Hand -> Bool
isStraight hand = [head sortedRanks .. last sortedRanks] == sortedRanks
    where sortedRanks = sort . map rank $ hand

isFlush :: Hand -> Bool
isFlush = (1==) . length . nub . map suit

To me computeRelativeRank calls for a case expression.

computeRelativeRank :: Hand -> HandRank -> RelativeRank
computeRelativeRank xs handRank = case handRank of
     RoyalFlush    -> []
     StraightFlush -> revSort xs
     FourOfKind    -> valsAtFreq 4 freqs ++ valsAtFreq 1 freqs
     FullHouse     -> valsAtFreq 3 freqs ++ valsAtFreq 2 freqs
     Flush         -> revSort xs
     Straight      -> revSort xs
     ThreeOfKind   -> valsAtFreq 3 freqs ++ (revSort $ valsAtFreq 1 freqs)
     TwoPairs      -> (maximum $ valsAtFreq 2 freqs) : (minimum $ valsAtFreq 2 freqs) : (valsAtFreq 1 freqs)
     Pair          -> valsAtFreq 2 freqs ++ (revSort $ valsAtFreq 1 freqs)
     HighCard      -> revSort xs
    where freqs = computeFreqMapping xs 

I'd count the number of elements using a Map.

import qualified Data.Map.Strict as M

computeFreqMapping :: (Ord a) => [a] -> FreqMapping a
computeFreqMapping = M.toList . foldl incrementCounter M.empty
    where incrementCounter m k = M.insertWith (+) k 1 m

In fact, the whole frequency mapping could be handled using such maps - sorting is automatic that way. If you are so inclined, take a look at the documentation - particularly the functions keys, elems.