{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiWayIf #-} -- | -- Module : Game.Implement.Card -- Copyright : (c) 2017 Christopher A. Gorski -- License : MIT -- Maintainer : Christopher A. Gorski -- -- The Game.Game.Poker module provides operations for five card poker. module Game.Game.Poker ( AceRank (..) , PokerHand , PokerHandType(..) , cardsOfPokerHand , typeOfPokerHand , allPossibleHands , allRoyalFlush , allStraightFlush , allFourOfAKind , allFullHouse , allFlush , allStraight , allThreeOfAKind , allTwoPair , allPair , allHighCard , isRoyalFlush , isStraightFlush , isFourOfAKind , isFullHouse , isFlush , isStraight , isThreeOfAKind , isTwoPair , isPair , isHighCard , mkHand , mkRoyalFlush , mkStraightFlush , mkFourOfAKind , mkFullHouse , mkFlush , mkStraight , mkThreeOfAKind , mkTwoPair , mkPair , mkHighCard , randomHighCard , randomPair , randomTwoPair , randomThreeOfAKind , randomStraight , randomFlush , randomFullHouse , randomFourOfAKind , randomStraightFlush , randomRoyalFlush , mkConsecutiveRanks ) where import Control.Monad.Loops import Control.Monad.Random import Game.Implement.Card import Game.Implement.Card.Standard import Game.Implement.Card.Standard.Poker import Data.List (tails,nub,find) import Data.Maybe (isJust, fromJust, catMaybes) import System.Random.Shuffle (shuffleM) randomAceRank :: MonadRandom m => m AceRank randomAceRank = let minB = minBound :: AceRank maxB = maxBound :: AceRank in do (randomn :: Int) <- getRandomR(fromEnum minB, fromEnum maxB); return $ toEnum randomn orderOfAceRank :: AceRank -> Order orderOfAceRank AceHigh = AceHighRankOrder orderOfAceRank AceLow = AceLowRankOrder -- | -- Indicates if a poker hand uses the Ace as a high card or a low card. -- -- >>> data AceRank = AceHigh | AceLow deriving (Eq, Show, Enum, Bounded) cardsOfPokerHand (PokerHand _ h) = h typeOfPokerHand (PokerHand t _) = t data PokerHandType = HighCard | Pair | TwoPair | ThreeOfAKind | Straight AceRank | Flush | FullHouse | FourOfAKind | StraightFlush AceRank | RoyalFlush deriving(Eq,Show) data PokerHand = PokerHand PokerHandType [PlayingCard] deriving(Eq,Show) randomHighCard :: RandomGen g => Rand g PokerHand randomHighCard = let r = do randHand <- replicateM 5 randomCard return randHand in do candidate <- r hand <- iterateUntil (\h -> isHighCard h) r return $ PokerHand HighCard hand randomPair :: RandomGen g => Rand g PokerHand randomPair = do numLstR <- uniqueNumList 4 0 12 rank1pair <- return $ replicate 2 $ toEnum $ (fromJust numLstR) !! 0 rank2 <- return $ toEnum $ (fromJust numLstR) !! 1 rank3 <- return $ toEnum $ (fromJust numLstR) !! 2 rank4 <- return $ toEnum $ (fromJust numLstR) !! 3 rankLst <- return $ rank4:rank3:rank2:rank1pair numLstS1 <- uniqueNumList 2 0 3 suitLst1 <- return $ map (\r -> toEnum r) $ fromJust numLstS1 suit2 <- randomSuit suit3 <- randomSuit suit4 <- randomSuit suitLst <- return $ suit4:suit3:suit2:suitLst1 cardset <- zipWithM (\r s -> return(PlayingCard r s)) rankLst suitLst shuffleset <- shuffle cardset return $ PokerHand Pair shuffleset randomTwoPair :: RandomGen g => Rand g PokerHand randomTwoPair = do numLstR <- uniqueNumList 3 0 12 rank1 <- return $ replicate 2 $ toEnum $ (fromJust numLstR) !! 0 rank2 <- return $ replicate 2 $ toEnum $ (fromJust numLstR) !! 1 rank3 <- return $ toEnum $ (fromJust numLstR) !! 2 rankLst :: [Rank] <- return $ rank3:(rank1 ++ rank2) numLstS1 <- uniqueNumList 2 0 3 numLstS2 <- uniqueNumList 2 0 3 numS3 <- randomSuit suitLst1 <- return $ map (\r -> toEnum r) $ fromJust numLstS1 suitLst2 <- return $ map (\r -> toEnum r) $ fromJust numLstS2 suitLst <- return $ numS3:(suitLst1 ++ suitLst2) cardset <- zipWithM (\r s -> return(PlayingCard r s)) rankLst suitLst shuffleset <- shuffle cardset return $ PokerHand TwoPair shuffleset randomThreeOfAKind :: RandomGen g => Rand g PokerHand randomThreeOfAKind = do numLst <- uniqueNumList 3 0 12 rank1 <- return $ replicate 3 $ toEnum $ (fromJust numLst) !! 0 rank2 <- return $ map (\r -> toEnum r) $ drop 1 (fromJust numLst) rankLst :: [Rank] <- return $ rank1 ++ rank2 numLstS1 <- uniqueNumList 3 0 3 suitLst1 <- return $ map (\r -> toEnum r) $ fromJust numLstS1 suitLst2 <- replicateM 2 randomSuit suitLst <- return $ suitLst1 ++ suitLst2 cardset <- zipWithM (\r s -> return(PlayingCard r s)) rankLst suitLst shuffleset <- shuffle cardset return $ PokerHand ThreeOfAKind shuffleset randomStraight :: RandomGen g => Rand g PokerHand randomStraight = let mkRanklst :: Int -> [Rank] mkRanklst n = map (\m -> toEnum ((m+n) `mod` 13) ) [0..4] mergelst r s = return(PlayingCard r s) l = do startRank :: Int <- getRandomR(0,9) ranklst <- return (mkRanklst startRank) suitlst :: [Suit] <- replicateM 5 randomSuit cardset <- zipWithM mergelst ranklst suitlst return cardset in do hand <- iterateUntil (\h -> (not $ isStraightFlush h) && (not $ isRoyalFlush h)) l aceRank <- return (if (toRank $ hand !! 0) == Ace then AceLow else AceHigh) shuffledHand <- shuffle hand return $ PokerHand (Straight aceRank) shuffledHand randomFlush :: RandomGen g => Rand g PokerHand randomFlush = let l = do numLst <- uniqueNumList 5 0 12 rankLst :: [Rank] <- return $ map (\n -> toEnum n) $ fromJust $ numLst randSuit <- randomSuit suitLst :: [Suit] <- return $ replicate 5 randSuit cardset <- zipWithM (\r s -> return(PlayingCard r s)) rankLst suitLst return cardset in do hand <- iterateUntil (\h -> (not $ isRoyalFlush h) && (not $ isStraightFlush h)) l return $ PokerHand Flush hand randomFullHouse :: RandomGen g => Rand g PokerHand randomFullHouse = do numLstR <- uniqueNumList 2 0 12 rank1 <- return $ toEnum $ (fromJust numLstR) !! 0 rank2 <- return $ toEnum $ (fromJust numLstR) !! 1 rankLst :: [Rank] <- return [rank1, rank1, rank1, rank2, rank2] numLstS1 <- uniqueNumList 3 0 3 numLstS2 <- uniqueNumList 2 0 3 suitLst1 <- return $ map (\r -> toEnum r) $ fromJust numLstS1 suitLst2 <- return $ map (\r -> toEnum r) $ fromJust numLstS2 suitLst <- return $ suitLst1 ++ suitLst2 cardset <- zipWithM (\r s -> return(PlayingCard r s)) rankLst suitLst shuffleset <- shuffle cardset return $ PokerHand FullHouse shuffleset randomFourOfAKind :: RandomGen g => Rand g PokerHand randomFourOfAKind = do randRank4 <- randomRank randRank <- iterateUntil (\r -> r /= randRank4) randomRank randRanks <- return $ randRank:(replicate 4 randRank4) randSuit <- randomSuit randSuits <- return [randSuit, Clubs, Diamonds, Hearts, Spades] mergedLst <- zipWithM (\r s -> return(PlayingCard r s)) randRanks randSuits shuffleSet <- shuffle mergedLst return $ PokerHand FourOfAKind $ shuffleSet randomStraightFlush :: RandomGen g => Rand g PokerHand randomStraightFlush = let mkRanklst :: Int -> [Rank] mkRanklst n = map (\m -> toEnum ((m+n) `mod` 13) ) [0..4] mergelst r s = return(PlayingCard r s) l = do startRank :: Int <- getRandomR(0,9) ranklst <- return (mkRanklst startRank) randSuit <- randomSuit suitlst :: [Suit] <- return (replicate 5 randSuit) cardset <- zipWithM mergelst ranklst suitlst return cardset in do hand <- iterateUntil (\h -> (not $ isRoyalFlush h)) l aceRank <- return (if (toRank $ hand !! 0) == Ace then AceLow else AceHigh) shuffledHand <- shuffle hand return $ PokerHand (StraightFlush aceRank) shuffledHand randomRoyalFlush :: RandomGen g => Rand g PokerHand randomRoyalFlush = let mkRanklst :: [Rank] mkRanklst = Ace : (map (\m -> toEnum m) [9..12]) mergelst r s = return(PlayingCard r s) in do startRank :: Int <- getRandomR(0,9) randSuit <- randomSuit suitlst :: [Suit] <- return (replicate 5 randSuit) cardset <- zipWithM mergelst mkRanklst suitlst shuffledHand <- shuffle cardset return $ PokerHand RoyalFlush shuffledHand mkHand :: [PlayingCard] -> Maybe PokerHand mkHand hand = let checks = [mkHighCard ,mkPair ,mkTwoPair ,mkThreeOfAKind ,mkStraight ,mkFlush ,mkFullHouse ,mkFourOfAKind ,mkStraightFlush ,mkRoyalFlush] cat = catMaybes $ map (\f -> f hand) checks in if length cat == 0 then Nothing else Just $ cat !! 0 isSameSuit :: [PlayingCard] -> Bool isSameSuit hand = let ff (Just c0) (Just c1) = if (toSuit c0) == (toSuit c1) then Just c1 else Nothing ff _ _ = Nothing in case foldl1 ff $ map (\x -> Just x) hand of Nothing -> False Just _ -> True hasConsecutiveRanks :: Order -> [PlayingCard] -> Bool hasConsecutiveRanks order hand = let handlst = map (\x -> Just x) $ sortCardsBy order hand ff (Just c0) (Just c1) = case (toOrderedValue order RankValueType c0)-(toOrderedValue order RankValueType c1) of 1 -> Just c1 _ -> Nothing ff _ _ = Nothing in case foldl1 ff handlst of Nothing -> False _ -> True nOfRank :: [PlayingCard] -> [(Rank, Int)] nOfRank hand = let rlst = toRankLst hand uniquelst = nub hand countel :: PlayingCard -> (Rank, Int) countel card = ((toRank card), length [x | x <- rlst, (toRank card)==x]) in nub $ map countel uniquelst hasNOfRank :: Int -> [PlayingCard] -> Bool hasNOfRank i hand = case (find (\(_,n) -> i == n) (nOfRank hand)) of Just _ -> True Nothing -> False hasNumNOfRank :: Int -> Int -> [PlayingCard] -> Bool hasNumNOfRank i num hand = if (length (filter (\(_,n) -> i == n) (nOfRank hand))) == num then True else False mkHighCard :: [PlayingCard] -> Maybe PokerHand mkHighCard hand | isValidPokerHand hand = if (not $ isPair hand) && (not $ isTwoPair hand) && (not $ isThreeOfAKind hand) && (not $ isStraight hand) && (not $ isFlush hand) && (not $ isFullHouse hand) && (not $ isFourOfAKind hand) && (not $ isStraightFlush hand) && (not $ isRoyalFlush hand) then Just (PokerHand HighCard hand) else Nothing | otherwise = Nothing isHighCard :: [PlayingCard] -> Bool isHighCard hand | isJust $ mkHighCard hand = True | otherwise = False mkPair :: [PlayingCard] -> Maybe PokerHand mkPair hand | isValidPokerHand hand = if (hasNumNOfRank 2 1 hand) && (not $ isFullHouse hand) then Just (PokerHand Pair hand) else Nothing | otherwise = Nothing isPair :: [PlayingCard] -> Bool isPair hand | isJust $ mkPair hand = True | otherwise = False mkTwoPair :: [PlayingCard] -> Maybe PokerHand mkTwoPair hand | isValidPokerHand hand = if (hasNumNOfRank 2 2 hand) && (not $ isFullHouse hand) then Just (PokerHand TwoPair hand) else Nothing | otherwise = Nothing isTwoPair :: [PlayingCard] -> Bool isTwoPair hand | isJust $ mkTwoPair hand = True | otherwise = False mkThreeOfAKind :: [PlayingCard] -> Maybe PokerHand mkThreeOfAKind hand | isValidPokerHand hand = if (hasNOfRank 3 hand) && (not $ isFullHouse hand) then Just (PokerHand ThreeOfAKind hand) else Nothing | otherwise = Nothing isThreeOfAKind :: [PlayingCard] -> Bool isThreeOfAKind hand | isJust $ mkThreeOfAKind hand = True | otherwise = False mkConsecutiveRanks :: [PlayingCard] -> Maybe ([PlayingCard], AceRank) mkConsecutiveRanks hand = let consecHigh h = (hasConsecutiveRanks AceHighRankOrder h) consecLow h = (hasConsecutiveRanks AceLowRankOrder h) f h2 | consecHigh h2 = Just (sortCardsBy AceHighRankOrder h2, AceHigh) | consecLow h2 = Just (sortCardsBy AceLowRankOrder h2, AceLow) | otherwise = Nothing in f hand mkStraight :: [PlayingCard] -> Maybe PokerHand mkStraight hand | isValidPokerHand hand = let consecRanks = mkConsecutiveRanks hand isConsecRanks = isJust consecRanks in if isConsecRanks && (not $ isRoyalFlush hand) && (not $ isStraightFlush hand) then Just (PokerHand (Straight $ snd $ fromJust consecRanks) hand) else Nothing | otherwise = Nothing isStraight :: [PlayingCard] -> Bool isStraight hand | isJust $ mkStraight hand = True | otherwise = False mkFlush :: [PlayingCard] -> Maybe PokerHand mkFlush hand | isValidPokerHand hand = if (isSameSuit hand) && (not $ isRoyalFlush hand) && (not $ isStraightFlush hand) then Just (PokerHand Flush hand) else Nothing | otherwise = Nothing isFlush :: [PlayingCard] -> Bool isFlush hand | isJust $ mkFlush hand = True | otherwise = False mkFullHouse :: [PlayingCard] -> Maybe PokerHand mkFullHouse hand | isValidPokerHand hand = if (hasNOfRank 3 hand) && (hasNOfRank 2 hand) then Just (PokerHand FullHouse hand) else Nothing | otherwise = Nothing isFullHouse :: [PlayingCard] -> Bool isFullHouse hand | isJust $ mkFullHouse hand = True | otherwise = False mkFourOfAKind :: [PlayingCard] -> Maybe PokerHand mkFourOfAKind hand | isValidPokerHand hand = if (hasNOfRank 4 hand) then Just (PokerHand FourOfAKind hand) else Nothing | otherwise = Nothing isFourOfAKind :: [PlayingCard] -> Bool isFourOfAKind hand | isJust $ mkFourOfAKind hand = True | otherwise = False mkStraightFlush :: [PlayingCard] -> Maybe PokerHand mkStraightFlush hand | isValidPokerHand hand = let consecRanks = mkConsecutiveRanks hand isConsecRanks = isJust consecRanks in if isConsecRanks && (isSameSuit hand) && (not $ isRoyalFlush hand) then Just (PokerHand (Straight $ snd $ fromJust consecRanks) hand) else Nothing | otherwise = Nothing isStraightFlush :: [PlayingCard] -> Bool isStraightFlush hand | isJust $ mkStraightFlush hand = True | otherwise = False mkRoyalFlush :: [PlayingCard] -> Maybe PokerHand mkRoyalFlush hand | isValidPokerHand hand = if (isSameSuit hand) then let slst :: [PlayingCard] = sortCardsBy AceHighRankOrder hand rlst = toValueLst slst in if (rlst == [Ace, King, Queen, Jack, Ten]) then Just (PokerHand RoyalFlush hand) else Nothing else Nothing | otherwise = Nothing isRoyalFlush :: [PlayingCard] -> Bool isRoyalFlush hand | isJust $ mkRoyalFlush hand = True | otherwise = False isValidPokerHand :: [PlayingCard] -> Bool isValidPokerHand hand | ((length hand) == 5) && ((dedupe hand) == hand) = True | otherwise = False choose :: Ord r => Int -> [r] -> [[r]] choose 0 _ = [[]] choose n lst = do (x:xs) <- tails lst rest <- choose (n-1) xs return $ x : rest allPossibleHands :: [[PlayingCard]] allPossibleHands = choose 5 fullDeck allRoyalFlush :: [[PlayingCard]] allRoyalFlush = [x | x <- allPossibleHands, isRoyalFlush x] allStraightFlush :: [[PlayingCard]] allStraightFlush = [x | x <- allPossibleHands, isStraightFlush x] allFourOfAKind :: [[PlayingCard]] allFourOfAKind = [x | x <- allPossibleHands, isFourOfAKind x] allFullHouse :: [[PlayingCard]] allFullHouse = [x | x <- allPossibleHands, isFullHouse x] allFlush :: [[PlayingCard]] allFlush = [x | x <- allPossibleHands, isFlush x] allStraight :: [[PlayingCard]] allStraight = [x | x <- allPossibleHands, isStraight x] allThreeOfAKind :: [[PlayingCard]] allThreeOfAKind = [x | x <- allPossibleHands, isThreeOfAKind x] allTwoPair :: [[PlayingCard]] allTwoPair = [x | x <- allPossibleHands, isTwoPair x] allPair :: [[PlayingCard]] allPair = [x | x <- allPossibleHands, isPair x] allHighCard :: [[PlayingCard]] allHighCard = [x | x <- allPossibleHands, isHighCard x]