In today’s Programming Praxis exercise we have to write a program to rank poker hands. The provided Scheme solution clocks in at 62 lines. Let’s see if we can’t bring that number down a little.

As usual, some imports:

import Data.Char
import Data.List
import qualified Data.List.Key as K

We’ll need to convert the two-character strings that are used to define the card to something that’s easier to work with.

toCard :: String -> (Int, Char)
toCard ~[v,s] = maybe undefined (flip (,) $ toUpper s) .
lookup v $ zip "23456789TJQKA" [2..]

If a hand is a flush, grouping on the suit should produce a list with only one element.

flush :: [(Int, Char)] -> Bool
flush = (== 1) . length . K.group snd

If a hand is a straight, it should consist of ascending values or be ace through five.

straight :: [Int] -> Bool
straight xs = (l:r) == [2,3,4,5,14] || isPrefixOf r [l + 1..]
where (l:r) = reverse $ map fromEnum xs

As with flushes, we use grouping to find how many cards we have with the same value. This function assumes that the list of values is already sorted.

same :: [Int] -> [Int]
same = map length . group

Calculating the rank of a hand then becomes a fairly simple matter of using the functions above to find the highest possible rank. We also add the sorted card values to the result so that multiple hands with the same rank will be compared on highest card value.

UPDATE: The original version had a bug where n-of-a-kinds were compared on the highest value of the other cards. I altered the definition of s to remedy this.

rank :: [String] -> (Int, [Int])
rank xs | straight s && flush cs = (9, s)
| elem 4 $ same s = (8, s)
| same s == [3,2] = (7, s)
| flush cs = (6, s)
| straight s = (5, s)
| elem 3 $ same s = (4, s)
| elem 2 . delete 2 $ same s = (3, s)
| elem 2 $ same s = (2, s)
| otherwise = (1, s)
where s = concat . reverse . K.sort (\x -> (length x, head x)) .
group . sort $ map fst cs
cs = map toCard xs

To determine the best hand, we need a way to look at every possible hand that can be chosen from the 7 available cards.

choose :: Int -> [a] -> [[a]]
choose 0 _ = [[]]
choose _ [] = []
choose n (x:xs) = map (x: ) (choose (n-1) xs) ++ choose n xs

The best hand is simply the one with the highest rank.

bestHand :: [String] -> [String]
bestHand = K.maximum rank . choose 5

Nothing left but to test if everything works correctly:

main :: IO ()
main = do
mapM_ print [fst (rank ["AH", "KH", "QH", "JH", "TH"]) == 9
,fst (rank ["7H", "7C", "3H", "7S", "7D"]) == 8
,fst (rank ["TH", "JC", "TS", "JD", "TC"]) == 7
,fst (rank ["4H", "7H", "AH", "KH", "9H"]) == 6
,fst (rank ["AH", "2C", "3S", "4D", "5H"]) == 5
,fst (rank ["9C", "4S", "KD", "9D", "9H"]) == 4
,fst (rank ["6D", "6C", "8H", "TD", "8D"]) == 3
,fst (rank ["9C", "3S", "4D", "7C", "3D"]) == 2
,fst (rank ["4C", "KD", "8S", "6D", "2D"]) == 1]
print $ bestHand ["AC", "JD", "8S", "8C", "AS", "3D", "4D"]
--Added after Phil's bug report
print $ rank ["AC", "7D", "7S", "7H", "7C"] <
rank ["4C", "8D", "8S", "8H", "8C"]

Yup. And at around a third of the line count of the Scheme version, that will do just fine.