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.