-- | -- Module : HoldEm -- Copyright : (c) Joe Vargas 2014 -- License : BSD-style -- Maintainer : jxv@hush.com -- Stability : stable -- Portability : portable module HoldEm ( Rank(..) -- :: Rank , Suit(..) -- :: Suit , Card(..) -- :: Card , Hand(..) -- :: Hand , PHand -- :: PHand , HandSet -- :: HandSet , Table(..) -- :: Table , deck -- :: [Card] , bestHand -- :: PHand -> Table -> Hand , deal -- :: RandomGen g => g -> Int -> Either (Table, [PHand]) ) where import Control.Applicative import Control.Monad import qualified Data.List as List import qualified Data.Maybe as Maybe import qualified System.Random as Random import qualified Safe as Safe import qualified Safe.Exact as Safe {----------------------------------------------------------------------------------------- Types -----------------------------------------------------------------------------------------} -- | Value of a card. data Rank = R2 | R3 | R4 | R5 | R6 | R7 | R8 | R9 | R10 | Jack | Queen | King | Ace deriving (Enum, Ord, Bounded, Eq) -- | Family of a card. data Suit = Clubs | Hearts | Diamonds | Spades deriving (Enum, Bounded, Eq) -- | Combined record for Rank and Suit. data Card = Card { rank :: Rank, suit :: Suit } deriving (Eq) -- | The value of a playable hand. -- Use its instance of Ord for comparing better hands. data Hand = High Rank Rank Rank Rank Rank | Pair1 Rank Rank Rank Rank | Pair2 Rank Rank Rank | Kind3 Rank Rank Rank | Straight Rank | Flush Rank Rank Rank Rank Rank | FHouse Rank Rank | Kind4 Rank Rank | SFlush Rank deriving (Show, Eq, Ord) -- | A dealt hand to a player. type PHand = (Card, Card) -- | A set of 5 cards which can be played. type HandSet = (Card, Card, Card, Card, Card) -- | The cards on the board. data Table = Table { flop :: (Card, Card, Card) , turn :: Card , river :: Card } deriving (Show, Eq) {----------------------------------------------------------------------------------------- Instances -----------------------------------------------------------------------------------------} instance Show Rank where show r = case r of R2 -> "2"; R3 -> "3"; R4 -> "4"; R5 -> "5"; R6 -> "6"; R7 -> "7"; R8 -> "8" R9 -> "9"; R10 -> "10"; Jack -> "J"; Queen -> "Q"; King -> "K"; Ace -> "A" instance Show Suit where show s = case s of Clubs -> "c"; Hearts -> "h"; Diamonds -> "d"; Spades -> "s" instance Show Card where show (Card r s) = (show r) ++ (show s) -- | The Ord instance of Card compares the ranks and ignores suits. instance Ord Card where compare (Card a _) (Card v _) = compare a v -- | All possible cards in a deck. deck :: [Card] deck = [Card r s | s <- [minBound..maxBound], r <- [minBound..maxBound]] -- | Generates initial data for a game. -- The number of players must be between 2 and 9 inclusively. -- And, the length of the returning [PHand] will match the number of players. deal :: Random.RandomGen g => g -> Int -> Either String (Table, [PHand]) deal rg numPlayers | numPlayers < 2 || numPlayers > 9 = Left "must be 2-9 players" | otherwise = Right $ let (a:b:c:d:e:cs) = map snd $ List.sort $ zip (Random.randoms rg :: [Int]) deck foldPHands xs = let (x:y:_,xs') = List.splitAt 2 xs in (x,y) : foldPHands xs' in (Table (a,b,c) d e, take numPlayers $ foldPHands cs) -- | Finds the highest scoring hand from a player's hand and the table. bestHand :: PHand -> Table -> (Hand, HandSet) bestHand (a,b) (Table (c,d,e) f g) = Maybe.fromMaybe high tryFst where seven = [a,b,c,d,e,f,g] handsMay = [ sFlushMay, kind4May, fHouseMay, flushMay , straightMay, kind3May, pair2May, pair1May ] tryFst = foldr (<|>) Nothing (map ($ seven) handsMay) high = let (v:w:x:y:z:_) = revSort seven in (High (rank v) (rank w) (rank x) (rank y) (rank z), (v,w,x,y,z)) -- | Finds 'One Pair' pair1May :: [Card] -> Maybe (Hand, HandSet) pair1May xs = do h:hs <- Safe.takeExactMay 4 (clusterByRank xs) a:b:[] <- Safe.takeExactMay 2 h c:d:e:[] <- Safe.takeExactMay 3 (List.concat hs) Just (Pair1 (rank a) (rank c) (rank d) (rank e), (a,b,c,d,e)) -- | Finds 'Two Pair' pair2May :: [Card] -> Maybe (Hand, HandSet) pair2May xs = do h:i:j:[] <- Safe.takeExactMay 3 (clusterByRank xs) a:b:[] <- Safe.takeExactMay 2 h c:d:[] <- Safe.takeExactMay 2 i e <- Safe.headMay j Just (Pair2 (rank a) (rank c) (rank e), (a,b,c,d,e)) -- | Finds 'Three of a Kind' kind3May :: [Card] -> Maybe (Hand, HandSet) kind3May xs = do h:hs <- Safe.takeExactMay 3 (clusterByRank xs) a:b:c:[] <- Safe.takeExactMay 3 h d:e:[] <- Safe.takeExactMay 2 (List.concat hs) Just (Kind3 (rank a) (rank d) (rank e), (a,b,c,d,e)) -- | Finds 'Straight' straightMay :: [Card] -> Maybe (Hand, HandSet) straightMay xs = do h <- Safe.headMay $ filter (\h -> let rs = map rank h in length h == 5 && (revConsecutive rs || rs == [R5,R4,R3,R2,Ace])) (possible xs) a:b:c:d:e:[] <- Safe.takeExactMay 5 h Just (Straight (rank a), (a,b,c,d,e)) where cvtLow x = if map rank x == [Ace,R5,R4,R3,R2] then (tail x) ++ [head x] else x possible = revSort . map cvtLow . List.subsequences . revSort . List.nubBy (\a b -> rank a == rank b) -- | Finds 'Flush' flushMay :: [Card] -> Maybe (Hand, HandSet) flushMay xs = do h <- Safe.headMay (clusterBySuit xs) a:b:c:d:e:[] <- Safe.takeExactMay 5 (revSort h) Just (Flush (rank a) (rank b) (rank c) (rank d) (rank e), (a,b,c,d,e)) -- | Finds 'Full House' fHouseMay :: [Card] -> Maybe (Hand, HandSet) fHouseMay xs = do h:i:[] <- Safe.takeExactMay 2 (clusterByRank xs) a:b:c:[] <- Safe.takeExactMay 3 h d:e:[] <- Safe.takeExactMay 2 i Just (FHouse (rank a) (rank d), (a,b,c,d,e)) -- | Finds 'Four of a Kind' kind4May :: [Card] -> Maybe (Hand, HandSet) kind4May xs = do h:i:[] <- Safe.takeExactMay 2 (clusterByRank xs) a:b:c:d:[] <- Safe.takeExactMay 4 h e <- Safe.headMay i Just (Kind4 (rank a) (rank e), (a,b,c,d,e)) -- | Finds 'Straight Flush' sFlushMay :: [Card] -> Maybe (Hand, HandSet) sFlushMay xs = do xs' <- Safe.headMay (clusterBySuit xs) (h,set) <- flushMay xs' case h of Straight r -> Just (SFlush r, set); _ -> Nothing -- | Separates all cards by rank, then descendingly sorts them by length. clusterByRank :: [Card] -> [[Card]] clusterByRank = List.sortBy (\a b -> compare (length b) (length a)) . List.groupBy (\x y -> rank x == rank y) . revSort -- | Separates all cards by suit, then descendingly sorts them by length. clusterBySuit :: [Card] -> [[Card]] clusterBySuit = List.sortBy (\a b -> compare (length b) (length a)) . List.groupBy (\x y -> suit x == suit y) . List.sortBy (\a b -> cmp (suit a) (suit b)) where cmp a b = case a of Clubs -> case b of Clubs -> EQ; Hearts -> LT; Diamonds -> LT; Spades -> LT Hearts -> case b of Clubs -> GT; Hearts -> EQ; Diamonds -> LT; Spades -> LT Diamonds -> case b of Clubs -> GT; Hearts -> GT; Diamonds -> EQ; Spades -> LT Spades -> case b of Clubs -> GT; Hearts -> GT; Diamonds -> GT; Spades -> EQ -- | A descending sort. revSort :: Ord a => [a] -> [a] revSort = List.sortBy (flip compare) -- | Returns true if all elements are in consecutive and descending order. revConsecutive :: (Enum a, Eq a, Bounded a) => [a] -> Bool revConsecutive as = case as of [] -> True; [a] -> True (a:b:as) -> b /= maxBound && a == succ b && revConsecutive (b:as) -- | Quick test suite based on -- > http://en.wikipedia.org/wiki/Texas_hold_%27em#Sample_showdown tests :: Bool tests = let tbl = Table (Card R4 Clubs, Card King Spades, Card R4 Hearts) (Card R8 Spades) (Card R7 Spades) bob = (Card Ace Clubs, Card R4 Diamonds) carol = (Card Ace Spades, Card R9 Spades) ted = (Card King Hearts, Card King Diamonds) alice = (Card R5 Diamonds, Card R6 Diamonds) in Kind3 R4 Ace King == fst (bestHand bob tbl) && Flush Ace King R9 R8 R7 == fst (bestHand carol tbl) && FHouse King R4 == fst (bestHand ted tbl) && Straight R8 == fst (bestHand alice tbl)