diff --git a/general-games.cabal b/general-games.cabal --- a/general-games.cabal +++ b/general-games.cabal @@ -1,5 +1,5 @@ name: general-games -version: 0.2.0 +version: 0.3.0 synopsis: Library supporting simulation of a number of games homepage: https://github.com/cgorski/general-games bug-reports: https://github.com/cgorski/general-games/issues @@ -8,7 +8,7 @@ author: Christopher A. Gorski maintainer: cgorski@cgorski.org copyright: 2017 Christopher A. Gorski -category: Games, Poker +category: Game, Poker build-type: Simple extra-source-files: README.md cabal-version: >=1.10 @@ -29,6 +29,8 @@ , Game.Game.Poker build-depends: base >= 4.7 && < 5 + , random-shuffle + , MonadRandom default-language: Haskell2010 ghc-options: -Wall @@ -40,7 +42,8 @@ , general-games , HUnit , hspec - ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N + , MonadRandom + ghc-options: -fhpc -Wall -threaded -rtsopts -with-rtsopts=-N default-language: Haskell2010 source-repository head diff --git a/src/Game/Game/Poker.hs b/src/Game/Game/Poker.hs --- a/src/Game/Game/Poker.hs +++ b/src/Game/Game/Poker.hs @@ -1,5 +1,6 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE FlexibleContexts #-} + module Game.Game.Poker where @@ -7,35 +8,54 @@ import Game.Implement.Card.Standard import Game.Implement.Card.Standard.Poker -import Data.List (tails,nub,find) --, sortBy, nub, find) -import Data.Maybe (isJust) +import Data.List (tails,nub,find) +import Data.Maybe (isJust, fromJust, catMaybes) type RankHand = [PlayingCard] type KickerHand = [PlayingCard] data RankKicker = RankHand KickerHand deriving(Eq,Show) +data AceRank = AceHigh | AceLow deriving (Eq, Show) + +orderOfAceRank :: AceRank -> Order +orderOfAceRank AceHigh = AceHighRankOrder +orderOfAceRank AceLow = AceLowRankOrder + data PokerHandType = HighCard | Pair | TwoPair | ThreeOfAKind - | Straight + | Straight AceRank | Flush | FullHouse | FourOfAKind - | StraightFlush + | StraightFlush AceRank | RoyalFlush deriving(Eq,Show) data PokerHandSplit = PokerHandType RankKicker deriving(Eq,Show) data PokerHand = PokerHand PokerHandType [PlayingCard] deriving(Eq,Show) --- mkBestHand :: S.Hand -> Maybe PokerHand --- mkBestHand hand --- | isPokerHandSize hand = Nothing --- | otherwise = mkHighCard hand - +mkBestHand :: [PlayingCard] -> Maybe PokerHand +mkBestHand hand = + let checks = + [mkHighCard hand + ,mkPair hand + ,mkTwoPair hand + ,mkThreeOfAKind hand + ,mkStraight hand + ,mkFlush hand + ,mkFullHouse hand + ,mkFourOfAKind hand + ,mkStraightFlush hand + ,mkRoyalFlush hand] + cat = catMaybes checks + in + if length cat == 0 + then Nothing + else Just $ cat !! 0 isSameSuit :: [PlayingCard] -> Bool isSameSuit hand = @@ -150,15 +170,27 @@ | 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 | isPokerHandSize hand = - if ((hasConsecutiveRanks AceHighRankOrder hand) - || (hasConsecutiveRanks AceLowRankOrder hand)) - && (not $ isRoyalFlush hand) - && (not $ isStraightFlush hand) - then Just (PokerHand Straight (sortCardsBy AceHighRankOrder 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 @@ -173,7 +205,7 @@ if (isSameSuit hand) && (not $ isRoyalFlush hand) && (not $ isStraightFlush hand) - then Just (PokerHand Flush (sortCardsBy AceHighRankOrder hand)) + then Just (PokerHand Flush hand) else Nothing | otherwise = Nothing @@ -212,12 +244,13 @@ mkStraightFlush :: [PlayingCard] -> Maybe PokerHand mkStraightFlush hand | isPokerHandSize hand = - if (isSameSuit hand) - && ((hasConsecutiveRanks AceHighRankOrder hand) - || (hasConsecutiveRanks AceLowRankOrder hand)) - && (not $ isRoyalFlush hand) - then Just (PokerHand StraightFlush hand) - else Nothing + 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 diff --git a/src/Game/Implement/Card.hs b/src/Game/Implement/Card.hs --- a/src/Game/Implement/Card.hs +++ b/src/Game/Implement/Card.hs @@ -1,16 +1,42 @@ {-# LANGUAGE MultiParamTypeClasses #-} - +-- | +-- Module : Game.Implement.Card +-- Copyright : (c) 2017 Christopher A. Gorski +-- License : MIT +-- Maintainer : Christopher A. Gorski +-- +-- The Game.Implement.Card module provides fundamental operations for a deck of cards. module Game.Implement.Card + ( + Card (..) + , ValuedCard (..) + , OrderedCard (..) + , OrderedValuedCard (..) + ) where +import Control.Monad.Random +import System.Random.Shuffle (shuffleM) import Data.List (nub, maximumBy, minimumBy, sortBy, foldl1') +-- | +-- Represents a physical card with no order and no value. +-- Inherited Enum, Eq, Ord and Bounded typeclasses are used to +-- distingish cards for the purposes of manipulation within lists. +-- Game value functions are provided by other typeclasses. class (Enum c, Eq c, Ord c, Bounded c) => Card c where + -- | + -- Return all cards in a list. Cards will appear at most once. Order is not guaranteed. + -- + -- >>> fullDeck :: [PlayingCard] + -- [Ace of Clubs,Two of Clubs,Three of Clubs,Four of Clubs,Five of Clubs,Six of Clubs,Seven of Clubs,Eight of Clubs,Nine of Clubs,Ten of Clubs,Jack of Clubs,Queen of Clubs,King of Clubs,Ace of Diamonds,Two of Diamonds,Three of Diamonds,Four of Diamonds,Five of Diamonds,Six of Diamonds,Seven of Diamonds,Eight of Diamonds,Nine of Diamonds,Ten of Diamonds,Jack of Diamonds,Queen of Diamonds,King of Diamonds,Ace of Hearts,Two of Hearts,Three of Hearts,Four of Hearts,Five of Hearts,Six of Hearts,Seven of Hearts,Eight of Hearts,Nine of Hearts,Ten of Hearts,Jack of Hearts,Queen of Hearts,King of Hearts,Ace of Spades,Two of Spades,Three of Spades,Four of Spades,Five of Spades,Six of Spades,Seven of Spades,Eight of Spades,Nine of Spades,Ten of Spades,Jack of Spades,Queen of Spades,King of Spades] fullDeck :: [c] dedupe :: [c] -> [c] draw :: [Int] -> [c] -> Maybe ([[c]],[c]) + shuffle :: MonadRandom m => [c] -> m [c] fullDeck = [minBound .. maxBound] dedupe l = nub l + shuffle deck = shuffleM deck draw handSizeLst deck | let total = (foldl1' (+) handSizeLst) @@ -24,13 +50,18 @@ newDeck = drop nToTake deckOutput in draw2 hst (newHand:handOutput, newDeck) in Just (draw2 handSizeLst ([],deck)) - - +-- | +-- Represents a playing card with a game value. For instance, +-- a standard playing card with a type representing +-- rank and suit. class (Card c) => ValuedCard c v where toValue :: c -> v toValueLst :: [c] -> [v] toValueLst l = map toValue l +-- | +-- Orderings independent of a specific value +-- type of a Card. class (Card c) => OrderedCard c o where highestCardBy :: o -> [c] -> c lowestCardBy :: o -> [c] -> c @@ -40,7 +71,10 @@ lowestCardBy o cl = minimumBy (compareCardBy o) cl sortCardsBy o cl = sortBy (compareCardBy o) cl + class (OrderedCard c o) => OrderedValuedCard c o vt where + -- | + -- Return an Int based on a card, an ordering and a value type. toOrderedValue :: o -> vt -> c -> Int diff --git a/src/Game/Implement/Card/Standard.hs b/src/Game/Implement/Card/Standard.hs --- a/src/Game/Implement/Card/Standard.hs +++ b/src/Game/Implement/Card/Standard.hs @@ -47,10 +47,10 @@ instance Enum PlayingCard where fromEnum (PlayingCard r s) = - (fromEnum r)+((fromEnum s)*nRanks) + ((fromEnum s)*nRanks)+(fromEnum r) toEnum n = let r = n `mod` nRanks - s = n `mod` 4 + s = n `div` nRanks in (PlayingCard (toEnum r) (toEnum s)) diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,9 +1,9 @@ +import Control.Monad.Random import Test.Hspec import Game.Game.Poker import Game.Implement.Card import Game.Implement.Card.Standard - allHandsCount :: Int allHandsCount = length allPossibleHands allHandsCountExpected :: Int @@ -80,42 +80,90 @@ [PlayingCard Three Clubs, PlayingCard Four Clubs]) +confirmDisjoint :: (Int, Bool) +confirmDisjoint = + let mfunc1 hand = [mkRoyalFlush hand, + mkStraightFlush hand, + mkFourOfAKind hand, + mkFullHouse hand, + mkFlush hand, + mkStraight hand, + mkThreeOfAKind hand, + mkTwoPair hand, + mkPair hand, + mkHighCard hand] + maybem (Just _) = 1 + maybem Nothing = 0 + countJust hand = sum $ map maybem $ mfunc1 hand + allSums = map countJust allPossibleHands + collect _ (outsum, False) = (outsum, False) + collect (x:xs) (outsum, _) = + collect xs (x+outsum, if x==0 || x==1 then True else False) + collect [] output = output + in + collect allSums (0, True) + +isUnique :: Eq a => [a] -> Bool +isUnique lst = f lst True where + f _ False = False + f [] result = result + f (x:xs) _ = if x `elem` xs then f xs False else f xs True + +shuffledDeck :: RandomGen g => Rand g [PlayingCard] +shuffledDeck = shuffle $ fullDeck + main :: IO () -main = hspec $ do - describe "Game.Implement.Card instance" $ do - it "returns drawn hands from a deck, plus the remaining deck" $ do - (draw drawDeckSizes drawDeck) `shouldBe` drawDeckExpectedOutput - it "returns Nothing when trying to return more cards than in deck" $ do - (draw drawDeckSizesFail drawDeck) `shouldBe` Nothing - it "returns Nothing when trying to return negative cards" $ do - (draw drawDeckSizesFailNeg drawDeck) `shouldBe` Nothing +main = + do + randdecks <- evalRandIO $ replicateM 10000 shuffledDeck; - describe "Game.Implement.Card.Standard.Poker.isRoyalFlush" $ do - it "confirms that [AH, QH, KH, JH, TH] is a Royal Flush" $ do - (isRoyalFlush royalFlush) `shouldBe` True - it "confirms that [AH, QH, 8H, JH, TH] is not a Royal Flush" $ do - (isRoyalFlush royalFlushNot) `shouldBe` False - describe "Game.Implement.Card.Standard.Poker allPossibleHands / isHand functions" $ do - it "confirms the total number of poker hands" $ do - allHandsCount `shouldBe` allHandsCountExpected - it "confirms the total number of royal flushes" $ do - (length allRoyalFlush) `shouldBe` allRoyalFlushCountExpected - it "confirms the total number of straight flushes" $ do - (length allStraightFlush) `shouldBe` allStraightFlushCountExpected - it "confirms the total number of four-of-a-kinds" $ do - (length allFourOfAKind) `shouldBe` allFourOfAKindCountExpected - it "confirms the total number of full houses" $ do - (length allFullHouse) `shouldBe` allFullHouseCountExpected - it "confirms the total number of flushes" $ do - (length allFlush) `shouldBe` allFlushCountExpected - it "confirms the total number of straights" $ do - (length allStraight) `shouldBe` allStraightCountExpected - it "confirms the total number of three-of-a-kinds" $ do - (length allThreeOfAKind) `shouldBe` allThreeOfAKindCountExpected - it "confirms the total number of two-pairs" $ do - (length allTwoPair) `shouldBe` allTwoPairCountExpected - it "confirms the total number of pairs" $ do - (length allPair) `shouldBe` allPairCountExpected - it "confirms the total number of high card hands" $ do - (length allHighCard) `shouldBe` allHighCardCountExpected + hspec $ do + describe "Game.Implement.Card.draw (PlayingCard)" $ do + it "returns drawn hands from a deck, plus the remaining deck" $ do + (draw drawDeckSizes drawDeck) `shouldBe` drawDeckExpectedOutput + it "returns Nothing when trying to return more cards than in deck" $ do + (draw drawDeckSizesFail drawDeck) `shouldBe` Nothing + it "returns Nothing when trying to return negative cards" $ do + (draw drawDeckSizesFailNeg drawDeck) `shouldBe` Nothing + + describe "Game.Implement.Card.fullDeck (PlayingCard)" $ do + it "returns 52 cards" $ do + length (fullDeck :: [PlayingCard]) `shouldBe` 52 + it "returns unique cards" $ do + isUnique (fullDeck :: [PlayingCard]) `shouldBe` True + + describe "Game.Implement.Card.shuffle (PlayingCard)" $ do + it "returns 10000 different fullDeck shuffles using the global random generator" $ do + (isUnique randdecks) `shouldBe` True + + describe "Game.Implement.Card.Standard.Poker.isRoyalFlush" $ do + it "confirms that [AH, QH, KH, JH, TH] is a Royal Flush" $ do + (isRoyalFlush royalFlush) `shouldBe` True + it "confirms that [AH, QH, 8H, JH, TH] is not a Royal Flush" $ do + (isRoyalFlush royalFlushNot) `shouldBe` False + describe "Game.Implement.Card.Standard.Poker allPossibleHands / mkHand / isHand functions" $ do + it "confirms that sets of each hand are disjoint and that total count correct" $ do + confirmDisjoint `shouldBe` (allHandsCountExpected, True) + it "confirms the total number of poker hands" $ do + allHandsCount `shouldBe` allHandsCountExpected + it "confirms the total number of royal flushes" $ do + (length allRoyalFlush) `shouldBe` allRoyalFlushCountExpected + it "confirms the total number of straight flushes" $ do + (length allStraightFlush) `shouldBe` allStraightFlushCountExpected + it "confirms the total number of four-of-a-kinds" $ do + (length allFourOfAKind) `shouldBe` allFourOfAKindCountExpected + it "confirms the total number of full houses" $ do + (length allFullHouse) `shouldBe` allFullHouseCountExpected + it "confirms the total number of flushes" $ do + (length allFlush) `shouldBe` allFlushCountExpected + it "confirms the total number of straights" $ do + (length allStraight) `shouldBe` allStraightCountExpected + it "confirms the total number of three-of-a-kinds" $ do + (length allThreeOfAKind) `shouldBe` allThreeOfAKindCountExpected + it "confirms the total number of two-pairs" $ do + (length allTwoPair) `shouldBe` allTwoPairCountExpected + it "confirms the total number of pairs" $ do + (length allPair) `shouldBe` allPairCountExpected + it "confirms the total number of high card hands" $ do + (length allHighCard) `shouldBe` allHighCardCountExpected