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
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?
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"
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