1
\$\begingroup\$

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
```
\$\endgroup\$
3
\$\begingroup\$

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.

\$\endgroup\$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.