general-games (empty) → 0.1.0.0
raw patch · 9 files changed
+648/−0 lines, 9 filesdep +HUnitdep +MonadRandomdep +basesetup-changed
Dependencies added: HUnit, MonadRandom, base, containers, general-games, permutation
Files
- LICENSE +19/−0
- README.md +19/−0
- Setup.hs +2/−0
- general-games.cabal +52/−0
- src/Game/Game/Poker.hs +294/−0
- src/Game/Implement/Card.hs +35/−0
- src/Game/Implement/Card/Standard.hs +80/−0
- src/Game/Implement/Card/Standard/Poker.hs +37/−0
- test/Spec.hs +110/−0
+ LICENSE view
@@ -0,0 +1,19 @@+Copyright (c) 2017 Christopher Albert Gorski++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.
+ README.md view
@@ -0,0 +1,19 @@+# General-games++* [Description](#description)+* [Contribute](#contribute)+* [License](#license)++## Description++Library providing framework for simulating outcomes of a variety of games, including Poker.+++## Contribute++For any problems, comments, or feedback please create an issue [here on GitHub](https://github.com/cgorski/general-games/issues).+++## License++`general-games` is released under the [MIT License](https://opensource.org/licenses/MIT).
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ general-games.cabal view
@@ -0,0 +1,52 @@+name: general-games+version: 0.1.0.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+license: MIT+license-file: LICENSE+author: Christopher A. Gorski+maintainer: cgorski@cgorski.org+copyright: 2017 Christopher A. Gorski+category: Games, Poker+build-type: Simple+extra-source-files: README.md+cabal-version: >=1.10++description:+ Library providing framework for simulating outcomes of a variety+ of games, including Poker.++source-repository head+ type: git+ location: git://github.com/cgorski/general-games.git+ +library+ hs-source-dirs: src+ exposed-modules: Game.Implement.Card+ , Game.Implement.Card.Standard+ , Game.Implement.Card.Standard.Poker+ , Game.Game.Poker++ build-depends: base >= 4.7 && < 5+ , permutation+ , containers+ , MonadRandom+ default-language: Haskell2010+ ghc-options: -Wall++test-suite general-games-test+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Spec.hs+ build-depends: base+ , general-games+ , containers+ , HUnit+ + ghc-options: -threaded -rtsopts -with-rtsopts=-N4+ default-language: Haskell2010++source-repository head+ type: git+ location: https://github.com/cgorski/general-games
+ src/Game/Game/Poker.hs view
@@ -0,0 +1,294 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleContexts #-}+module Game.Game.Poker+ where++import Game.Implement.Card+import Game.Implement.Card.Standard+import Game.Implement.Card.Standard.Poker++import Data.List (tails,nub,find) --, sortBy, nub, find)+import Data.Maybe (isJust)+++type RankHand = [PlayingCard] +type KickerHand = [PlayingCard]+data RankKicker = RankHand KickerHand deriving(Eq,Show)++data PokerHandType =+ HighCard + | Pair + | TwoPair + | ThreeOfAKind + | Straight + | Flush + | FullHouse + | FourOfAKind + | StraightFlush + | 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+++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+ | isPokerHandSize 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+ | isPokerHandSize 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+ | isPokerHandSize 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+ | isPokerHandSize 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+++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))+ else Nothing+ | otherwise = Nothing++isStraight :: [PlayingCard] -> Bool+isStraight hand+ | isJust $ mkStraight hand = True+ | otherwise = False++mkFlush :: [PlayingCard] -> Maybe PokerHand+mkFlush hand+ | isPokerHandSize hand =+ if (isSameSuit hand)+ && (not $ isRoyalFlush hand)+ && (not $ isStraightFlush hand) + then Just (PokerHand Flush (sortCardsBy AceHighRankOrder hand))+ else Nothing+ | otherwise = Nothing++isFlush :: [PlayingCard] -> Bool+isFlush hand+ | isJust $ mkFlush hand = True+ | otherwise = False++mkFullHouse :: [PlayingCard] -> Maybe PokerHand+mkFullHouse hand+ | isPokerHandSize 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+ | isPokerHandSize 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+ | isPokerHandSize hand =+ if (isSameSuit hand)+ && ((hasConsecutiveRanks AceHighRankOrder hand)+ || (hasConsecutiveRanks AceLowRankOrder hand))+ && (not $ isRoyalFlush hand)+ then Just (PokerHand StraightFlush hand)+ else Nothing + | otherwise = Nothing++isStraightFlush :: [PlayingCard] -> Bool+isStraightFlush hand+ | isJust $ mkStraightFlush hand = True+ | otherwise = False++mkRoyalFlush :: [PlayingCard] -> Maybe PokerHand+mkRoyalFlush hand+ | isPokerHandSize 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++isPokerHandSize :: [PlayingCard] -> Bool+isPokerHandSize hand + | (length hand) == 5 = 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]++
+ src/Game/Implement/Card.hs view
@@ -0,0 +1,35 @@+{-# LANGUAGE MultiParamTypeClasses #-}++module Game.Implement.Card+ where++import Data.List (nub, maximumBy, minimumBy, sortBy)++class (Enum c, Eq c, Ord c, Bounded c) => Card c where+ fullDeck :: [c]+ dedupe :: [c] -> [c]+ draw :: Int -> [c] -> Maybe ([c],[c])+ fullDeck = [minBound .. maxBound]+ dedupe l = nub l+ draw n l+ | n > (length l) = Nothing+ | otherwise = Just (drop n l, take n l)++class (Card c) => ValuedCard c v where+ toValue :: c -> v+ toValueLst :: [c] -> [v]+ toValueLst l = map toValue l++class (Card c) => OrderedCard c o where+ highestCardBy :: o -> [c] -> c+ lowestCardBy :: o -> [c] -> c+ compareCardBy :: o -> c -> c -> Ordering+ sortCardsBy :: o -> [c] -> [c]+ highestCardBy o cl = maximumBy (compareCardBy o) cl+ lowestCardBy o cl = minimumBy (compareCardBy o) cl+ sortCardsBy o cl = sortBy (compareCardBy o) cl++class (OrderedCard c o) => OrderedValuedCard c o vt where+ toOrderedValue :: o -> vt -> c -> Int++
+ src/Game/Implement/Card/Standard.hs view
@@ -0,0 +1,80 @@+{-# LANGUAGE MultiParamTypeClasses #-}++module Game.Implement.Card.Standard+ where++import Game.Implement.Card++data Rank =+ Ace |+ Two |+ Three |+ Four |+ Five |+ Six |+ Seven |+ Eight |+ Nine |+ Ten |+ Jack |+ Queen |+ King+ deriving (Show, Enum, Eq, Ord, Bounded)++ranks :: [Rank]+ranks = [minBound .. maxBound]++nRanks :: Int+nRanks = length ranks ++data Suit =+ Clubs |+ Diamonds |+ Hearts |+ Spades+ deriving (Show, Enum, Eq, Ord, Bounded)++suits :: [Suit]+suits = [minBound .. maxBound]++nSuits :: Int+nSuits = length suits++instance Card PlayingCard where++data PlayingCard = PlayingCard Rank Suit deriving (Eq, Ord, Bounded)+data Value = RankValue | SuitValue deriving (Eq)++instance Enum PlayingCard where+ fromEnum (PlayingCard r s) =+ (fromEnum r)+((fromEnum s)*nRanks)+ toEnum n =+ let r = n `mod` nRanks+ s = n `mod` 4+ in+ (PlayingCard (toEnum r) (toEnum s))++instance Show PlayingCard where+ show (PlayingCard r s) = (show r) ++ " of " ++ (show s)++instance ValuedCard PlayingCard Rank where+ toValue (PlayingCard r _) = r++toRank :: PlayingCard -> Rank+toRank c = toValue c ++toRankLst :: [PlayingCard] -> [Rank]+toRankLst l = toValueLst l++instance ValuedCard PlayingCard Suit where+ toValue (PlayingCard _ s) = s++toSuit :: PlayingCard -> Suit+toSuit (PlayingCard _ s) = s+++++++
+ src/Game/Implement/Card/Standard/Poker.hs view
@@ -0,0 +1,37 @@+{-# LANGUAGE MultiParamTypeClasses #-}++module Game.Implement.Card.Standard.Poker+ where++import Game.Implement.Card+import Game.Implement.Card.Standard++data Order = AceHighRankOrder | AceLowRankOrder | SuitOrder deriving (Eq)+data ValueType = RankValueType | SuitValueType++instance OrderedCard PlayingCard Order where+ compareCardBy AceHighRankOrder (PlayingCard Ace _) (PlayingCard _ _) = LT+ compareCardBy AceHighRankOrder (PlayingCard _ _) (PlayingCard Ace _) = GT+ compareCardBy AceHighRankOrder (PlayingCard r1 _) (PlayingCard r2 _) =+ if r1 == r2+ then EQ+ else r2 `compare` r1++ compareCardBy AceLowRankOrder (PlayingCard Ace _) (PlayingCard _ _) = GT+ compareCardBy AceLowRankOrder (PlayingCard _ _) (PlayingCard Ace _) = LT+ compareCardBy AceLowRankOrder (PlayingCard r1 _) (PlayingCard r2 _) =+ if r1 == r2+ then EQ+ else r2 `compare` r1+ + compareCardBy SuitOrder (PlayingCard _ s1) (PlayingCard _ s2) = s1 `compare` s2+++instance OrderedValuedCard PlayingCard Order ValueType where+ toOrderedValue AceLowRankOrder RankValueType (PlayingCard r _) = (fromEnum r) + 1+ toOrderedValue AceHighRankOrder RankValueType (PlayingCard r _) =+ case r of + Ace -> 14+ n -> (fromEnum n) + 1+ toOrderedValue _ _ (PlayingCard _ s) = fromEnum s+
+ test/Spec.hs view
@@ -0,0 +1,110 @@+import Test.HUnit+import Game.Game.Poker+import Game.Implement.Card+import Game.Implement.Card.Standard+import Game.Implement.Card.Standard.Poker++-- allHands = allPossibleHands+allHandsCount = length allPossibleHands+allHandsCountExpected = 2598960++royalFlush =+ [PlayingCard Ace Hearts,+ PlayingCard Queen Hearts,+ PlayingCard King Hearts,+ PlayingCard Jack Hearts,+ PlayingCard Ten Hearts]++royalFlushNot =+ [PlayingCard Ace Hearts,+ PlayingCard Queen Hearts,+ PlayingCard Eight Hearts,+ PlayingCard Jack Hearts,+ PlayingCard Ten Hearts]++singlePair =+ [PlayingCard Three Clubs,+ PlayingCard Three Spades,+ PlayingCard Eight Hearts,+ PlayingCard Jack Hearts,+ PlayingCard Ten Hearts]++twoPair =+ [PlayingCard Three Clubs,+ PlayingCard Three Spades,+ PlayingCard Four Hearts,+ PlayingCard Four Diamonds,+ PlayingCard Ten Hearts]++++-- royalFlushLstAH = AH.fromStandardCardLst royalFlushLst+-- royalFlushLstAL = AL.fromStandardCardLst royalFlushLst++sortedRoyalFlush =+ [PlayingCard Ace Hearts,+ PlayingCard King Hearts,+ PlayingCard Queen Hearts,+ PlayingCard Jack Hearts,+ PlayingCard Ten Hearts]+++ +testPossibleHands = TestCase (assertEqual "Total number of poker hands" allHandsCountExpected allHandsCount)+testPossibleRoyalFlush = TestCase (assertEqual "Total number of royal flushes" 4 (length allRoyalFlush))+testPossibleStraightFlush = TestCase (assertEqual "Total number of straight flushes" 36 (length allStraightFlush))+testPossibleFourOfAKind = TestCase (assertEqual "Total number of four-of-a-kinds" 624 (length allFourOfAKind))+testPossibleFullHouse = TestCase (assertEqual "Total number of full houses" 3744 (length allFullHouse))+testPossibleFlush = TestCase (assertEqual "Total number of flushes" 5108 (length allFlush))+testPossibleStraight = TestCase (assertEqual "Total number of straights" 10200 (length allStraight))+testPossibleThreeOfAKind = TestCase (assertEqual "Total number of three-of-a-kinds" 54912 (length allThreeOfAKind))+testPossibleTwoPair = TestCase (assertEqual "Total number of two-pairs" 123552 (length allTwoPair))+testPossiblePair = TestCase (assertEqual "Total number of pairs" 1098240 (length allPair))+testPossibleHighCard = TestCase (assertEqual "Total number of high cards" 1302540 (length allHighCard))+testMkRoyalFlush = TestCase (assertEqual "Is [AH, KH, QH, JH, TH] a Royal Flush" (Just $ PokerHand RoyalFlush sortedRoyalFlush) (mkRoyalFlush royalFlush))+testIsRoyalFlush = TestCase (assertEqual "Is [AH, QH, KH, JH, TH] a Royal Flush" True (isRoyalFlush royalFlush))+testIsRoyalFlushNot = TestCase (assertEqual "Is [AH, QH, 8H, JH, TH] a Royal Flush" False (isRoyalFlush royalFlushNot))+-- testIsMinHandSize = TestCase (assertEqual "Is min size of 5" True (isMinHandSize royalFlush))+-- testIsMinHandSize2 = TestCase (assertEqual "Is min size of 5" False (isMinHandSize $ DS.fromList [S.Card S.Ace S.Spades]))+-- testSortHighToLow = TestCase (assertEqual "Is sorted from high to low"+-- sortedRoyalFlushLst+-- (sortHighToLow $ AH.fromStandardCardLst royalFlushLst))+-- testIsSameSuit = TestCase (assertEqual "Is same suit" True (isSameSuit $ DS.fromList royalFlushLst)) +-- --testHasConsecutiveRanks = TestCase (assertEqual "Is consecutive" True (AH.fromStdroyalFlush++ +tests = TestList [+ TestLabel "Test for testPossibleHands" testPossibleHands,+ TestLabel "Test for testPossibleRoyalFlush" testPossibleRoyalFlush,+ TestLabel "Test for testPossibleStraightFlush" testPossibleStraightFlush,+ TestLabel "Test for testPossibleFourOfAKind" testPossibleFourOfAKind,+ TestLabel "Test for testPossibleFullHouse" testPossibleFullHouse,+ TestLabel "Test for testPossibleFlush" testPossibleFlush,+ TestLabel "Test for testPossibleStraight" testPossibleStraight,+ TestLabel "Test for testPossibleThreeOfAKind" testPossibleThreeOfAKind,+ TestLabel "Test for testTwoPair" testPossibleTwoPair,+ TestLabel "Test for testPair" testPossiblePair,+ TestLabel "Test for testHighCard" testPossibleHighCard]+-- TestLabel "Test for mkRoyalFlush" testMkRoyalFlush]+-- TestLabel "Test for isRoyalFlush" testIsRoyalFlush,+-- TestLabel "Test for isRoyalFlushNot" testIsRoyalFlushNot++-- TestLabel "Test for isMinHandSize royalFlush" testIsMinHandSize,+-- TestLabel "Test for isMinHandSize singleton" testIsMinHandSize2,+-- TestLabel "Test for sortHighToLow royalFlush" testSortHighToLow,+-- TestLabel "Test for isSameSuit royalFlush" testIsSameSuit]+main :: IO ()+main =+ do+-- putStrLn $ show $ map (fromEnum . S.toRank) $ sort royalFlushLstAH+-- putStrLn $ show $ map (fromEnum . S.toRank) $ sort royalFlushLstAL+-- putStrLn $ show $ allFourOfAKind+ counts <- runTestTT tests+ putStrLn $ show counts+-- putStrLn $ show $ sortCardsBy AceHighRankOrder royalFlush+-- putStrLn $ show $ nOfRank singlePair+-- putStrLn $ show $ nOfRank twoPair+-- putStrLn $ show $ hasNumNOfRank 2 1 singlePair+-- putStrLn $ show $ hasNumNOfRank 2 2 twoPair++