poker-base (empty) → 0.1.0.0
raw patch · 14 files changed
+1582/−0 lines, 14 filesdep +QuickCheckdep +basedep +containers
Dependencies added: QuickCheck, base, containers, extra, generic-arbitrary, hspec, poker-base, prettyprinter, safe-money, tasty, tasty-discover, tasty-hspec, tasty-quickcheck, text
Files
- ChangeLog.md +3/−0
- LICENSE +30/−0
- README.md +44/−0
- poker-base.cabal +140/−0
- src/Poker.hs +87/−0
- src/Poker/Amount.hs +150/−0
- src/Poker/Cards.hs +465/−0
- src/Poker/Game.hs +214/−0
- src/Poker/Range.hs +95/−0
- src/Poker/Utils.hs +4/−0
- test/Driver.hs +1/−0
- test/Test/Poker/Cards.hs +303/−0
- test/Test/Poker/Game.hs +13/−0
- test/Test/Poker/Range.hs +33/−0
+ ChangeLog.md view
@@ -0,0 +1,3 @@+# Changelog for Exploit++## Unreleased changes
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2019-2021, Santi Weight 2021, Tony Day++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Santi Weight nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,44 @@+## poker-base++[](https://hackage.haskell.org/package/poker-base)+[](https://github.com/santiweight/poker-base/actions?query=workflow%3Ahaskell-ci)++## Description++`poker-base` provides datatypes and supporting infrastructure to handle poker computation. Once developed, the package intends to be industry-ready and provide capabilities that support poker websites, simulation, research and poker trainers and assistants.++Pull requests or suggestions (preferably created in an issue), are not just encouraged but highly requested! We are quick to respond to any help you might need :)++## Usage++```+-- >>> import Poker+-- >>> Just h = mkHole (Card Ace Club) (Card Two Diamond)+-- >>> holeToShortTxt h+-- "Ac2d"+```++## Goal++To become Haskell's core de facto library for poker applications. We are working on this library so that your poker work can use `poker-base`, and its children packages, seamlessly.++Some principles that this library aims to uphold:+ - Targeted at intermediate Haskellers. This package will not shy away from using Haskell features that we deem right-for-the-job. However, we also make an effort to make `poker-base`'s API usable for the intermediate Haskeller.+ - Thin around the waist. This library aims to contain only such datatypes and functionality that are uncontroversial (~90% agree). If a datatype or API would be incompatible with some people's needs, then that functionality will not be included `poker-base`.+ - 100% test coverage/documentation!+ - Fast. This library is intended to be fast. However, note that API usability will come over speed always. Thankfully, Haskell has features such as `newtype` and `PatternSynonyms` which we use to hide implementation details.++## Libraries based on `poker-base`++ - [`poker-game`](https://github.com/santiweight/poker-game): a library for the rules of no-limit poker (not just holdem)+ - [`poker-histories`](https://github.com/santiweight/poker-histories): a library for parsing poker site hand histories. Currently supports PokerStars and Bovada.+ - [`poker-ai`](https://github.com/tonyday567/poker-fold): an experimental platform for researching poker strategy and intelligence.+ - Various other private repos. If you are interested - please drop a line to the authors :)++## Contributing++See [Contributing.md](Contributing.md) for guidelines.++## Resources++See [Resources.md](Resources.md) for help regarding the rules of poker and resources for implementing poker applications.
+ poker-base.cabal view
@@ -0,0 +1,140 @@+cabal-version: 1.22+name: poker-base+version: 0.1.0.0+description: This package provides datatypes and support for poker computation in Haskell.+ .+ == Usage+ .+ >>> import Poker+ >>> Just h = mkHole (Card Ace Club) (Card Two Diamond)+ >>> holeToShortTxt h+ "Ac2d"+ .+ Please see the README on GitHub at <https://github.com/santiweight/poker-base#readme> for an overview.++category: Poker+synopsis: A library for core poker types+homepage: https://github.com/santiweight/poker-base#readme+bug-reports: https://github.com/santiweight/poker-base/issues+author: Santiago Weight+maintainer: santiago.weight@gmail.com+copyright: 2021 Santiago Weight+license: BSD3+license-file: LICENSE+build-type: Simple+tested-with:+ GHC == 8.6.5+ || == 8.8.4+ || == 8.10.7+ || == 9.0.1++extra-doc-files:+ README.md+ ChangeLog.md++source-repository head+ type: git+ location: https://github.com/santiweight/poker-base++library+ exposed-modules:+ Poker+ Poker.Range+ Poker.Amount+ Poker.Cards+ Poker.Game+ other-modules:+ Poker.Utils+ hs-source-dirs:+ src+ ghc-options:+ -Wall -Wcompat -Wincomplete-record-updates+ -Wincomplete-uni-patterns -Wredundant-constraints+ -funbox-strict-fields+ build-depends:+ base >= 4.11 && <5,+ text >= 0.11 && <1.3,+ containers >= 0.5 && <0.7,+ prettyprinter >= 1.6 && < 1.8,+ safe-money >= 0.9 && < 0.10,+ QuickCheck >= 2.12 && < 2.15,+ generic-arbitrary >= 0.1 && < 0.3+ default-language: Haskell2010+ default-extensions:+ ConstraintKinds+ DataKinds+ DeriveDataTypeable+ DeriveFunctor+ DeriveGeneric+ DeriveTraversable+ EmptyCase+ FlexibleContexts+ FlexibleInstances+ GADTs+ GeneralizedNewtypeDeriving+ InstanceSigs+ LambdaCase+ MultiParamTypeClasses+ PolyKinds+ RankNTypes+ ScopedTypeVariables+ StandaloneDeriving+ TypeApplications+ TypeOperators+ TypeFamilies+ TemplateHaskell+ ViewPatterns++test-suite all-tests+ type: exitcode-stdio-1.0+ main-is: Driver.hs+ other-modules:+ Test.Poker.Cards+ Test.Poker.Game+ Test.Poker.Range+ hs-source-dirs:+ test+ ghc-options:+ -Wall -Wcompat -Wincomplete-record-updates+ -Wincomplete-uni-patterns -Wredundant-constraints+ -funbox-strict-fields+ -threaded -rtsopts -with-rtsopts=-N -Wall+ build-depends:+ base >= 4.11 && <5,+ poker-base,+ text >= 0.11 && <1.3,+ prettyprinter >= 1.6 && < 1.8,+ containers >= 0.5 && <0.7,+ QuickCheck >= 2.13.2 && < 2.15,+ extra >= 1.6.18 && < 1.8,+ hspec >= 2.7.1 && < 2.9,+ tasty >= 1.2.3 && < 1.5,+ tasty-discover,+ tasty-hspec >= 1.1 && < 1.3,+ tasty-quickcheck >= 0.10.1 && < 0.11+ build-tool-depends:+ tasty-discover:tasty-discover+ default-language: Haskell2010+ default-extensions:+ ConstraintKinds+ DataKinds+ DeriveDataTypeable+ DeriveFunctor+ DeriveGeneric+ DeriveTraversable+ EmptyCase+ FlexibleContexts+ FlexibleInstances+ GADTs+ GeneralizedNewtypeDeriving+ InstanceSigs+ LambdaCase+ MultiParamTypeClasses+ PolyKinds+ RankNTypes+ ScopedTypeVariables+ StandaloneDeriving+ TypeApplications+ TypeOperators+ TypeFamilies+ TemplateHaskell
+ src/Poker.hs view
@@ -0,0 +1,87 @@+-- | Datatypes and supporting infrastructure for poker computation.+module Poker+ ( -- * Usage+ -- $usage++ -- * Cards+ Rank (..),+ allRanks,+ Suit (..),+ allSuits,+ suitToUnicode,+ suitFromUnicode,+ Card (..),+ allCards,++ -- * Hole cards+ Hole (..),+ mkHole,+ allHoles,+ ShapedHole (..),+ mkPair,+ mkOffsuit,+ mkSuited,+ allShapedHoles,+ holeToShapedHole,+ Deck,+ freshDeck,+ unsafeDeck,+ shapedHoleToHoles,+ rankToChr,+ chrToRank,+ suitToChr,+ chrToSuit,+ cardToShortTxt,+ cardFromShortTxt,+ shapedHoleToShortTxt,+ holeToShortTxt,+ unsafeOffsuit,+ unsafeSuited,+ unsafeHole,+ holeFromShortTxt,++ -- * Game+ Position (..),+ NumPlayers (..),+ numPlayersToWord8,+ numPlayersFromWord8,+ mkNumPlayers,+ allPositions,+ positionToTxt,+ getPreflopOrder,+ buttonPosition,+ bigBlindPosition,+ getPostFlopOrder,+ sortPostflop,+ Seat (..),+ Pot (..),+ Stack (..),+ Stake (..),++ -- * Amount+ Amount (unAmount),+ unsafeAmount,+ IsBet (..),+ mkAmount,+ BigBlind (..),+ bigBlindToDense,++ -- * Range+ Freq (..),+ Range (..),+ getDecisionFreqRange,+ holdingRangeToShapedRange,+ addHoleToShapedRange,+ )+where++import Poker.Amount+import Poker.Cards+import Poker.Game+import Poker.Range++-- $usage+-- >>> import Poker+-- >>> Just h = mkHole (Card Ace Club) (Card Two Diamond)+-- >>> holeToShortTxt h+-- "Ac2d"
+ src/Poker/Amount.hs view
@@ -0,0 +1,150 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE UndecidableInstances #-}++-- | Representation of money, and bet quantities.+module Poker.Amount+ ( Amount (..),+ unsafeAmount,+ IsBet (..),+ mkAmount,+ bigBlindToDense,+ BigBlind (..),+ )+where++import GHC.Generics (Generic)+import GHC.TypeLits+ ( KnownSymbol,+ Symbol,+ )+import Money++#if MIN_VERSION_prettyprinter(1,7,0)+import Prettyprinter (Pretty (pretty), viaShow)+#else+import Data.Text.Prettyprint.Doc (Pretty (pretty), viaShow)+#endif++-- $setup+-- >>> :set -XDataKinds+-- >>> import Prettyprinter++-- | 'Amount' is the type used to represent amounts of money during a game of poker.+-- The internal representation of 'Amount' is a @Discrete\'@ from the+-- <https://hackage.haskell.org/package/safe-money safe-money> package.+-- The exposed constructors for 'Amount' ensure that no 'Amount' can have a negative value.+--+-- The use of the @safe-money@ package allows for lossless conversion between currencies with+-- well-maintained support for type safety, serialisation, and currency conversions.+--+-- @+-- \{\-\# Language TypeApplications \#\-\}+--+-- case 'unsafeAmount' @\"USD\" ('discrete' 100) of+-- 'UnsafeAmount' x -> x -- x == discrete 100+-- @+data Amount (b :: Symbol) where+ UnsafeAmount :: (GoodScale (CurrencyScale b), KnownSymbol b) => {unAmount :: Discrete' b (CurrencyScale b)} -> Amount b++deriving instance Show (Amount b)++deriving instance Eq (Amount b)++deriving instance Ord (Amount b)++instance Pretty (Amount b) where+ pretty = viaShow++-- |+-- Returns an 'Amount' from a @Discrete\'@ so long as the given @Discrete\'@ is non-negative.+--+-- >>> mkAmount @"USD" 0+-- Just (UnsafeAmount {unAmount = Discrete "USD" 100%1 0})+-- >>> mkAmount @"USD" (-1)+-- Nothing+mkAmount ::+ (GoodScale (CurrencyScale b), KnownSymbol b) =>+ Discrete' b (CurrencyScale b) ->+ Maybe (Amount b)+mkAmount (someDiscreteAmount . toSomeDiscrete -> amt)+ | amt >= 0 = Just $ UnsafeAmount $ discrete amt+ | otherwise = Nothing++-- | Make an 'Amount' from a @Discrete'@. Only use when you are certain that your @Discrete'@ value+-- is positive, since most usages of 'Amount' will break for negative quantities.+unsafeAmount ::+ (GoodScale (CurrencyScale b), KnownSymbol b) =>+ Discrete' b (CurrencyScale b) ->+ Amount b+unsafeAmount = UnsafeAmount++-- |+-- A type @b@ satisfies 'IsBet' if we know:+--+-- * A 'Monoid' instance for @b@. This allows us to construct a zero amount of @b@ and+-- to 'add' two amounts of @b@ together.+--+-- * the smallest non-zero currency unit for @b@ ('smallestAmount'). For example, for USD the minimum currency amount+-- is $0.01.+--+-- * how to 'add' two @b@s. By default, this is the 'Monoid' instance's append for @b@.+--+-- * how to 'minus' two @b@s, which may fail (returning 'Nothing'), if the resulting 'Amount' is negative.+--+-- Types that satisfy 'IsBet' are expected to have both 'Ord' and 'Show' instances, so that packages such as @poker-game@+-- can handle arbitrary new user bet types.+--+-- For an example instance of the 'IsBet' class, see "Poker.BigBlind".+class (Monoid b, Show b, Ord b) => IsBet b where+ smallestAmount :: b+ minus :: b -> b -> Maybe b+ add :: b -> b -> b+ add = (<>)++-- TODO There's probably some way to avoid repeating the Constraints in the typeclasses,+-- since they are implied by the constructor of Amount. However this might require some+-- work from Richard Eisenberg first...+instance (GoodScale (CurrencyScale b), KnownSymbol b) => Semigroup (Amount b) where+ (UnsafeAmount dis) <> (UnsafeAmount dis') = UnsafeAmount $ dis + dis'++instance (GoodScale (CurrencyScale b), KnownSymbol b) => Monoid (Amount b) where+ mempty = UnsafeAmount $ discrete 0++instance (GoodScale (CurrencyScale b), KnownSymbol b) => IsBet (Amount b) where+ smallestAmount = UnsafeAmount $ discrete 1 :: Amount b+ UnsafeAmount l `minus` UnsafeAmount r+ | r > l = Nothing+ | otherwise = Just $ UnsafeAmount $ l - r+ UnsafeAmount l `add` UnsafeAmount r = UnsafeAmount $ l + r++-- | 'BigBlind' is the type describing poker chip amounts that are measured in big blinds.+--+-- The internal representation of 'BigBlind' is @'Amount' "BB"@. This module introduces+-- a new instance of 'CurrencyScale' (from the+-- <https://hackage.haskell.org/package/safe-money safe-money> package), which allows+-- translation from BigBlind to any valid currency in a lossless manner.+--+-- The small unit of a \"BB\" is a \"bb\", with 100 \"bb\"s in a \"BB\".+--+-- TODO include an API for translating from BigBlind to any safe-money currency, given+-- a 'Poker.Game.Stake'.+--+-- Calculations in the safe-money package are done with Discrete and Dense+-- types. Discrete values are used to describe a regular BigBlind value,+-- such as 1.30bb. Dense values are used when calculating some complex+-- (non-discrete) value such as one third of a big blind. When using the BigBlind+-- type, it is best to do all calculation with Dense "BB" values and then+-- convert back to a Discrete "BB" "bb" after all calculation has been completed:+newtype BigBlind = BigBlind {unBigBlind :: Amount "BB"}+ deriving (Show, Generic, Eq, Ord, IsBet, Semigroup, Monoid)++type instance+ UnitScale "BB" "bb" =+ '(100, 1)++type instance CurrencyScale "BB" = UnitScale "BB" "bb"++-- | When working with a 'BigBlind' you might want to (cautiously) retain losslessness+-- when using functions such as % calculations or division. A 'Dense' allows you to do so.+bigBlindToDense :: BigBlind -> Dense "BB"+bigBlindToDense = denseFromDiscrete . unAmount . unBigBlind
+ src/Poker/Cards.hs view
@@ -0,0 +1,465 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE OverloadedStrings #-}++-- | Card types and operators.+module Poker.Cards+ ( Rank (..),+ allRanks,+ Suit (..),+ allSuits,+ suitToUnicode,+ suitFromUnicode,+ Card (..),+ allCards,+ Hole (..),+ mkHole,+ allHoles,+ ShapedHole (..),+ mkPair,+ mkOffsuit,+ mkSuited,+ allShapedHoles,+ holeToShapedHole,+ Deck,+ freshDeck,+ unsafeDeck,+ shapedHoleToHoles,+ rankToChr,+ chrToRank,+ suitToChr,+ chrToSuit,+ cardToShortTxt,+ cardFromShortTxt,+ shapedHoleToShortTxt,+ holeToShortTxt,+ unsafeOffsuit,+ unsafeSuited,+ unsafeHole,+ holeFromShortTxt,+ )+where++#if MIN_VERSION_prettyprinter(1,7,0)+import Prettyprinter+import Prettyprinter.Internal ( unsafeTextWithoutNewlines, Doc(Char) )+#else+import Data.Text.Prettyprint.Doc+#endif+import Control.Applicative+import Control.Monad+import Data.Bifunctor (Bifunctor (second))+import Data.Maybe+import Data.String (IsString (fromString))+import Data.Text (Text)+import qualified Data.Text as T+import GHC.Generics (Generic)+import Poker.Utils+import Test.QuickCheck (Arbitrary (arbitrary), elements)+import Test.QuickCheck.Arbitrary.Generic (GenericArbitrary (..))++-- $setup+-- >>> import Test.QuickCheck+-- >>> import Data.Maybe+-- >>> import Prettyprinter++-- | The 'Rank' of a playing 'Card'+data Rank+ = Two+ | Three+ | Four+ | Five+ | Six+ | Seven+ | Eight+ | Nine+ | Ten+ | Jack+ | Queen+ | King+ | Ace+ deriving (Enum, Bounded, Eq, Ord, Show, Read, Generic)+ deriving (Arbitrary) via GenericArbitrary Rank++-- | >>> pretty <$> allRanks+-- [2,3,4,5,6,7,8,9,T,J,Q,K,A]+instance Pretty Rank where+ pretty = unsafeTextWithoutNewlines . T.singleton . rankToChr++-- | >>> allRanks+-- [Two,Three,Four,Five,Six,Seven,Eight,Nine,Ten,Jack,Queen,King,Ace]+allRanks :: [Rank]+allRanks = enumerate @Rank++-- | >>> rankToChr <$> allRanks+-- "23456789TJQKA"+rankToChr :: Rank -> Char+rankToChr = \case+ Two -> '2'+ Three -> '3'+ Four -> '4'+ Five -> '5'+ Six -> '6'+ Seven -> '7'+ Eight -> '8'+ Nine -> '9'+ Ten -> 'T'+ Jack -> 'J'+ Queen -> 'Q'+ King -> 'K'+ Ace -> 'A'++-- | >>> map (fromJust . chrToRank) "23456789TJQKA"+-- [Two,Three,Four,Five,Six,Seven,Eight,Nine,Ten,Jack,Queen,King,Ace]+-- >>> chrToRank 'x'+-- Nothing+--+-- prop> \r -> chrToRank (rankToChr r) == Just r+chrToRank :: Char -> Maybe Rank+chrToRank = \case+ '2' -> pure Two+ '3' -> pure Three+ '4' -> pure Four+ '5' -> pure Five+ '6' -> pure Six+ '7' -> pure Seven+ '8' -> pure Eight+ '9' -> pure Nine+ 'T' -> pure Ten+ 'J' -> pure Jack+ 'Q' -> pure Queen+ 'K' -> pure King+ 'A' -> pure Ace+ _ -> Nothing++-- | The 'Suit' of a playing 'Card'+data Suit = Club | Diamond | Heart | Spade+ deriving (Enum, Bounded, Eq, Ord, Show, Read, Generic)+ deriving (Arbitrary) via GenericArbitrary Suit++-- | >>> pretty allSuits+-- [c, d, h, s]+instance Pretty Suit where+ pretty = Char . suitToChr++-- | >>> allSuits+-- [Club,Diamond,Heart,Spade]+allSuits :: [Suit]+allSuits = enumerate @Suit++-- | >>> suitToChr <$> allSuits+-- "cdhs"+suitToChr :: Suit -> Char+suitToChr = \case+ Club -> 'c'+ Diamond -> 'd'+ Heart -> 'h'+ Spade -> 's'++-- | >>> map (fromJust . chrToSuit) "cdhs"+-- [Club,Diamond,Heart,Spade]+-- >>> chrToSuit 'x'+-- Nothing+--+-- prop> \s -> chrToSuit (suitToChr s) == Just s+chrToSuit :: Char -> Maybe Suit+chrToSuit = \case+ 'c' -> pure Club+ 'd' -> pure Diamond+ 'h' -> pure Heart+ 's' -> pure Spade+ _ -> Nothing++-- | >>> suitToUnicode <$> [Club, Diamond, Heart, Spade]+-- "\9827\9830\9829\9824"+-- >>> suitFromUnicode . suitToUnicode <$> [Club, Diamond, Heart, Spade]+-- [Just Club,Just Diamond,Just Heart,Just Spade]+suitToUnicode :: Suit -> Char+suitToUnicode = \case+ Club -> '♣'+ Diamond -> '♦'+ Heart -> '♥'+ Spade -> '♠'++-- | >>> suitFromUnicode <$> ['♣', '♦', '♥', '♠']+-- [Just Club,Just Diamond,Just Heart,Just Spade]+--+-- prop> \s -> suitFromUnicode (suitToUnicode s) == Just s+suitFromUnicode :: Char -> Maybe Suit+suitFromUnicode = \case+ '♣' -> Just Club+ '♦' -> Just Diamond+ '♥' -> Just Heart+ '♠' -> Just Spade+ _ -> Nothing++-- | Representation of a playing card.+data Card = Card+ { rank :: !Rank,+ suit :: !Suit+ }+ deriving (Eq, Ord, Show, Read, Generic)+ deriving (Arbitrary) via GenericArbitrary Card++-- | >>> pretty ("Ac" :: Card)+-- Ac+instance Pretty Card where+ pretty c = unsafeTextWithoutNewlines $ cardToShortTxt c++instance IsString Card where+ fromString = fromJust . cardFromShortTxt . T.pack++-- | All cards in a 'Deck'+--+-- >>> length allCards+-- 52+allCards :: [Card]+allCards = liftA2 Card allRanks allSuits++-- | >>> cardToShortTxt "Ac"+-- "Ac"+cardToShortTxt :: Card -> Text+cardToShortTxt (Card r s) = T.pack [rankToChr r, suitToChr s]++-- | >>> cardFromShortTxt "Ac"+-- Just (Card {rank = Ace, suit = Club})+--+-- prop> \c -> cardFromShortTxt (cardToShortTxt c) == Just c+cardFromShortTxt :: Text -> Maybe Card+cardFromShortTxt cs = case second T.uncons <$> T.uncons cs of+ Just (r, Just (s, T.null -> True)) -> Card <$> chrToRank r <*> chrToSuit s+ _ -> Nothing++-- | 'Hole' represents a player's hole cards in a game of Texas Hold\'Em+data Hole+ = -- | First 'Card' is expected to be '>' the second+ UnsafeHole !Card !Card+ deriving (Eq, Ord, Show, Read, Generic)++-- | Unsafely create a new 'Hole'. The first 'Card' should be '>' than the second.+-- See 'mkHole' for a safe way to create a 'Hole'.+unsafeHole :: Card -> Card -> Hole+unsafeHole = UnsafeHole++-- | >>> "AcKd" :: Hole+-- UnsafeHole (Card {rank = Ace, suit = Club}) (Card {rank = King, suit = Diamond})+instance IsString Hole where+ fromString str =+ fromMaybe invalidHole . holeFromShortTxt $ T.pack str+ where+ invalidHole = error $ "Invalid Hole: " <> str++-- | >>> pretty <$> mkHole (Card Ace Heart) (Card King Spade)+-- Just AhKs+instance Pretty Hole where+ pretty (UnsafeHole c1 c2) = pretty c1 <> pretty c2++-- | The 'Arbitrary' instance for 'Hole' generates values whose 'Card' members+-- are already normalised.+instance Arbitrary Hole where+ arbitrary = elements allHoles++-- | >>> holeToShortTxt "AcKd"+-- "AcKd"+holeToShortTxt :: Hole -> Text+holeToShortTxt (UnsafeHole c1 c2) = cardToShortTxt c1 <> cardToShortTxt c2++-- | >>> holeFromShortTxt "AcKd"+-- Just (UnsafeHole (Card {rank = Ace, suit = Club}) (Card {rank = King, suit = Diamond}))+-- >>> ("KdAc" :: Hole) == "AcKd"+-- True+--+-- prop> \h -> holeFromShortTxt (holeToShortTxt h) == Just h+holeFromShortTxt :: Text -> Maybe Hole+holeFromShortTxt (T.splitAt 2 -> (c1, T.splitAt 2 -> (c2, T.unpack -> []))) =+ join $ mkHole <$> cardFromShortTxt c1 <*> cardFromShortTxt c2+holeFromShortTxt _ = Nothing++-- | Returns a 'Hole' if the incoming 'Card's are unique, else 'Nothing'.+-- Note that 'mkHole' automatically normalises the order of the given 'Card's. See 'Hole' for details.+--+-- prop> \c1 c2 -> mkHole c1 c2 == mkHole c2 c1+--+-- prop> \c1 c2 -> (c1 /= c2) ==> isJust (mkHole c1 c2)+mkHole :: Card -> Card -> Maybe Hole+mkHole c1 c2 =+ if c1 /= c2+ then Just $ if c1 > c2 then UnsafeHole c1 c2 else UnsafeHole c2 c1+ else Nothing++-- | All possible valid 'Hole's (the 'Hole's are already normalised).+--+-- >>> length allCards * length allCards+-- 2704+-- >>> length allHoles+-- 1326+-- >>> Data.List.nub allHoles == allHoles+-- True+-- >>> pretty $ take 10 allHoles+-- [AsAh, AsAd, AhAd, AsAc, AhAc, AdAc, AsKs, AhKs, AdKs, AcKs]+allHoles :: [Hole]+allHoles = reverse $ do+ r1 <- allRanks+ r2 <- enumFrom r1+ (s1, s2) <-+ if r1 == r2+ then [(s1, s2) | s1 <- allSuits, s2 <- drop 1 (enumFrom s1)]+ else liftA2 (,) allSuits allSuits+ pure $ unsafeHole (Card r2 s2) (Card r1 s1)++-- | A 'ShapedHole' is the 'Suit'-normalised representation of a+-- poker 'Hole'. For example, the 'Hole' "King of Diamonds, 5 of Hearts" is often referred+-- to as "King-5 offsuit".+--+-- To construct a 'ShapedHole', see 'mkPair', 'mkOffsuit', and mkSuited'.+--+-- >>> "22p" :: ShapedHole+-- Pair Two+-- >>> "A4o" :: ShapedHole+-- UnsafeOffsuit Ace Four+-- >>> "KJs" :: ShapedHole+-- UnsafeSuited King Jack+data ShapedHole+ = Pair !Rank+ | -- | First 'Rank' should be '>' the second+ UnsafeOffsuit !Rank !Rank+ | -- | First 'Rank' should be '>' the second+ UnsafeSuited !Rank !Rank+ deriving (Eq, Ord, Show, Read, Generic)++-- | First 'Rank' should '>' than second 'Rank'+unsafeOffsuit :: Rank -> Rank -> ShapedHole+unsafeOffsuit = UnsafeOffsuit++-- | First 'Rank' should be '>' than second 'Rank'+unsafeSuited :: Rank -> Rank -> ShapedHole+unsafeSuited = UnsafeSuited++-- | >>> "AKs" :: ShapedHole+-- UnsafeSuited Ace King+-- >>> "AKo" :: ShapedHole+-- UnsafeOffsuit Ace King+-- >>> "AAp" :: ShapedHole+-- Pair Ace+-- >>> "KAs" == ("AKs" :: ShapedHole)+-- True+instance IsString ShapedHole where+ fromString str = case str of+ [r1, r2, s] ->+ fromMaybe invalidShapedHole $ do+ r1' <- chrToRank r1+ r2' <- chrToRank r2+ case s of+ 'p' -> if r1' == r2' then Just $ mkPair r1' else Nothing+ 'o' -> mkOffsuit r1' r2'+ 's' -> mkSuited r1' r2'+ _ -> Nothing+ _ -> invalidShapedHole+ where+ invalidShapedHole = error $ "Invalid ShapedHole: " <> str++-- | >>> pretty $ take 10 allShapedHoles+-- [AAp, AKs, AQs, AJs, ATs, A9s, A8s, A7s, A6s, A5s]+instance Pretty ShapedHole where+ pretty = pretty . shapedHoleToShortTxt++-- | The 'Arbitrary' instance for 'ShapedHole' generates values whose 'Rank' members+-- are already normalised.+instance Arbitrary ShapedHole where+ arbitrary = elements allShapedHoles++-- | >>> shapedHoleToShortTxt (mkPair Ace)+-- "AAp"+-- >>> shapedHoleToShortTxt <$> (mkOffsuit Ace King)+-- Just "AKo"+-- >>> shapedHoleToShortTxt <$> (mkSuited Ace King)+-- Just "AKs"+shapedHoleToShortTxt :: ShapedHole -> Text+shapedHoleToShortTxt (UnsafeOffsuit r1 r2) = rankToChr r1 `T.cons` rankToChr r2 `T.cons` "o"+shapedHoleToShortTxt (UnsafeSuited r1 r2) = rankToChr r1 `T.cons` rankToChr r2 `T.cons` "s"+shapedHoleToShortTxt (Pair r) = rankToChr r `T.cons` rankToChr r `T.cons` "p"++-- | Build a pair 'ShapedHole' from the given 'Rank'+mkPair :: Rank -> ShapedHole+mkPair = Pair++-- | Returns a suited 'ShapedHole' if the incoming 'Rank's are unique, else 'Nothing'.+-- Note that 'mkSuited' normalises the order of the incoming 'Rank's.+--+-- prop> \r1 r2 -> mkSuited r1 r2 == mkSuited r2 r1+mkSuited :: Rank -> Rank -> Maybe ShapedHole+mkSuited r1 r2 =+ if r1 /= r2+ then Just $ if r1 > r2 then UnsafeSuited r1 r2 else UnsafeSuited r2 r1+ else Nothing++-- | Returns an offsuit 'ShapedHole' if the incoming 'Rank's are unique, else 'Nothing'.+-- Note that the internal representation of 'ShapedHole' is normalised:+--+-- prop> \r1 r2 -> mkOffsuit r1 r2 == mkOffsuit r2 r1+mkOffsuit :: Rank -> Rank -> Maybe ShapedHole+mkOffsuit r1 r2 =+ if r1 /= r2+ then Just $ if r1 > r2 then UnsafeOffsuit r1 r2 else UnsafeOffsuit r2 r1+ else Nothing++-- | >>> length allShapedHoles+-- 169+-- >>> Data.List.nub allShapedHoles == allShapedHoles+-- True+-- >>> pretty $ take 15 allShapedHoles+-- [AAp, AKs, AQs, AJs, ATs, A9s, A8s, A7s, A6s, A5s, A4s, A3s, A2s, AKo, KKp]+allShapedHoles :: [ShapedHole]+allShapedHoles = reverse $ do+ rank1 <- allRanks+ rank2 <- allRanks+ return $ case compare rank1 rank2 of+ GT -> unsafeSuited rank1 rank2+ EQ -> mkPair rank1+ LT -> unsafeOffsuit rank2 rank1++-- | >>> fmap holeToShortTxt . shapedHoleToHoles $ "55p"+-- ["5d5c","5h5c","5s5c","5h5d","5s5d","5s5h"]+-- >>> fmap holeToShortTxt . shapedHoleToHoles $ "97o"+-- ["9c7d","9c7h","9c7s","9d7c","9d7h","9d7s","9h7c","9h7d","9h7s","9s7c","9s7d","9s7h"]+-- >>> fmap holeToShortTxt . shapedHoleToHoles $ "QTs"+-- ["QcTc","QdTd","QhTh","QsTs"]+shapedHoleToHoles :: ShapedHole -> [Hole]+shapedHoleToHoles = \case+ Pair r -> do+ s1 <- allSuits+ s2 <- drop (fromEnum s1 + 1) allSuits+ pure . fromJust $ mkHole (Card r s1) (Card r s2)+ UnsafeOffsuit r1 r2 -> do+ s1 <- allSuits+ s2 <- filter (s1 /=) allSuits+ pure . fromJust $ mkHole (Card r1 s1) (Card r2 s2)+ UnsafeSuited r1 r2 -> do+ s <- allSuits+ pure . fromJust $ mkHole (Card r1 s) (Card r2 s)++-- | >>> holeToShapedHole "AcKd"+-- UnsafeOffsuit Ace King+-- >>> holeToShapedHole "AcKc"+-- UnsafeSuited Ace King+-- >>> holeToShapedHole "AcAs"+-- Pair Ace+holeToShapedHole :: Hole -> ShapedHole+holeToShapedHole (UnsafeHole (Card r1 s1) (Card r2 s2))+ | r1 == r2 = mkPair r1+ | s1 == s2 = unsafeSuited r1 r2+ | otherwise = unsafeOffsuit r1 r2++-- | A 'Deck' of 'Card's+newtype Deck = UnsafeDeck [Card] deriving (Read, Show, Eq)++-- | A unshuffled 'Deck' with all 'Card's+--+-- >>> freshDeck == unsafeDeck allCards+-- True+freshDeck :: Deck+freshDeck = UnsafeDeck allCards++-- | The input 'Card's are not checked in any way.+unsafeDeck :: [Card] -> Deck+unsafeDeck = UnsafeDeck
+ src/Poker/Game.hs view
@@ -0,0 +1,214 @@+{-# LANGUAGE OverloadedStrings #-}++-- | Representation of a game of holdem, including table structure, positioning, pot and betting state.+module Poker.Game+ ( Position (..),+ NumPlayers (..),+ numPlayersToWord8,+ numPlayersFromWord8,+ mkNumPlayers,+ allPositions,+ positionToTxt,+ getPreflopOrder,+ buttonPosition,+ bigBlindPosition,+ getPostFlopOrder,+ sortPostflop,+ Seat (..),+ Pot (..),+ Stack (..),+ Stake (..),+ )+where++import Data.Data+import Data.Text (Text)+import Data.Word (Word8)+import Poker.Cards+import Prettyprinter++-- | A player's 'Position' in a game of poker.+--+-- 'Position's are ordered by table order (clockwise). The smallest 'Position', @Position 0@,+-- is the first player to act preflop. The largest 'Position' is always the big blind.+--+-- >>> allPositions SixPlayers+-- [Position 0,Position 1,Position 2,Position 3,Position 4,Position 5]+-- >>> positionToTxt SixPlayers <$> allPositions SixPlayers+-- ["LJ","HJ","CO","BU","SB","BB"]+-- >>> positionToTxt NinePlayers <$> allPositions NinePlayers+-- ["UTG","UTG1","UTG2","LJ","HJ","CO","BU","SB","BB"]+--+-- The API for 'Position' is unstable. We are open to better ideas :)+newtype Position = Position Word8+ deriving (Read, Show, Enum, Bounded, Eq, Ord, Data, Typeable)++instance Pretty Position where+ pretty = viaShow++-- | Number of active players at a poker table. Players sitting out do not count, as+-- they do not contribute to the number of 'Position's.+data NumPlayers+ = TwoPlayers+ | ThreePlayers+ | FourPlayers+ | FivePlayers+ | SixPlayers+ | SevenPlayers+ | EightPlayers+ | NinePlayers+ deriving (Enum, Eq, Ord)++-- | Convert a 'NumPlayers' to a 'Word8'.+numPlayersToWord8 :: NumPlayers -> Word8+numPlayersToWord8 TwoPlayers = 2+numPlayersToWord8 ThreePlayers = 3+numPlayersToWord8 FourPlayers = 4+numPlayersToWord8 FivePlayers = 5+numPlayersToWord8 SixPlayers = 6+numPlayersToWord8 SevenPlayers = 7+numPlayersToWord8 EightPlayers = 8+numPlayersToWord8 NinePlayers = 9++-- | Convert a 'Word8' to a 'NumPlayers'.+numPlayersFromWord8 :: Word8 -> Maybe NumPlayers+numPlayersFromWord8 2 = Just TwoPlayers+numPlayersFromWord8 3 = Just ThreePlayers+numPlayersFromWord8 4 = Just FourPlayers+numPlayersFromWord8 5 = Just FivePlayers+numPlayersFromWord8 6 = Just SixPlayers+numPlayersFromWord8 7 = Just SevenPlayers+numPlayersFromWord8 8 = Just EightPlayers+numPlayersFromWord8 9 = Just NinePlayers+numPlayersFromWord8 _ = Nothing++-- | WARNING: The incoming 'Integral' is downcast to a 'Word8'+mkNumPlayers :: Integral a => a -> Maybe NumPlayers+mkNumPlayers num | num >= 2 && num <= 9 = numPlayersFromWord8 $ fromIntegral num+mkNumPlayers _ = Nothing++-- | >>> allPositions SixPlayers+-- [Position 0,Position 1,Position 2,Position 3,Position 4,Position 5]+allPositions :: NumPlayers -> [Position]+allPositions (numPlayersToWord8 -> num) = Position <$> [0 .. num - 1]++-- | >>> positionToTxt TwoPlayers <$> allPositions TwoPlayers+-- ["BU","BB"]+-- >>> positionToTxt SixPlayers <$> allPositions SixPlayers+-- ["LJ","HJ","CO","BU","SB","BB"]+-- >>> positionToTxt NinePlayers <$> allPositions NinePlayers+-- ["UTG","UTG1","UTG2","LJ","HJ","CO","BU","SB","BB"]+positionToTxt :: NumPlayers -> Position -> Text+positionToTxt (numPlayersToWord8 -> num) (Position pos) =+ let allPositionTexts = ["UTG", "UTG1", "UTG2", "LJ", "HJ", "CO", "BU", "SB", "BB"]+ positionTexts = case num of+ 2 -> ["BU", "BB"]+ num' | num' > 2 && num' <= 9 -> drop (9 - fromIntegral num') allPositionTexts+ _ -> error $ "Unexpected NumPlayers value: " <> show num+ in positionTexts !! fromIntegral pos++-- | >>> positionToTxt TwoPlayers <$> getPreflopOrder TwoPlayers+-- ["BU","BB"]+-- >>> positionToTxt SixPlayers <$> getPreflopOrder SixPlayers+-- ["LJ","HJ","CO","BU","SB","BB"]+-- >>> positionToTxt NinePlayers <$> getPreflopOrder NinePlayers+-- ["UTG","UTG1","UTG2","LJ","HJ","CO","BU","SB","BB"]+getPreflopOrder :: NumPlayers -> [Position]+getPreflopOrder = allPositions++-- | >>> buttonPosition TwoPlayers+-- Position 0+-- >>> (\numPlayers -> positionToTxt numPlayers $ buttonPosition numPlayers) <$> enumFromTo TwoPlayers NinePlayers+-- ["BU","BU","BU","BU","BU","BU","BU","BU"]+buttonPosition :: NumPlayers -> Position+buttonPosition (numPlayersToWord8 -> num) = case num of+ 2 -> Position 0+ _ -> Position (num - 3)++-- | >>> bigBlindPosition TwoPlayers+-- Position 1+-- >>> (\numPlayers -> positionToTxt numPlayers $ bigBlindPosition numPlayers) <$> enumFromTo TwoPlayers NinePlayers+-- ["BB","BB","BB","BB","BB","BB","BB","BB"]+bigBlindPosition :: NumPlayers -> Position+bigBlindPosition (numPlayersToWord8 -> num) = Position (num - 1)++-- | >>> positionToTxt TwoPlayers <$> getPostFlopOrder TwoPlayers+-- ["BB","BU"]+-- >>> positionToTxt ThreePlayers <$> getPostFlopOrder ThreePlayers+-- ["SB","BB","BU"]+-- >>> positionToTxt SixPlayers <$> getPostFlopOrder SixPlayers+-- ["SB","BB","LJ","HJ","CO","BU"]+-- >>> positionToTxt NinePlayers <$> getPostFlopOrder NinePlayers+-- ["SB","BB","UTG","UTG1","UTG2","LJ","HJ","CO","BU"]+getPostFlopOrder :: NumPlayers -> [Position]+getPostFlopOrder numPlayers@(fromIntegral . numPlayersToWord8 -> num) =+ take num+ . drop 1+ . dropWhile (/= buttonPosition numPlayers)+ . cycle+ $ allPositions numPlayers++-- | Sort a list of positions acccording to postflop ordering+--+-- >>> positionToTxt TwoPlayers <$> sortPostflop TwoPlayers (allPositions TwoPlayers)+-- ["BB","BU"]+-- >>> positionToTxt ThreePlayers <$> sortPostflop ThreePlayers (allPositions ThreePlayers)+-- ["SB","BB","BU"]+-- >>> positionToTxt SixPlayers <$> sortPostflop SixPlayers (allPositions SixPlayers)+-- ["SB","BB","LJ","HJ","CO","BU"]+-- >>> positionToTxt NinePlayers <$> sortPostflop NinePlayers (allPositions NinePlayers)+-- ["SB","BB","UTG","UTG1","UTG2","LJ","HJ","CO","BU"]+sortPostflop :: NumPlayers -> [Position] -> [Position]+sortPostflop num ps = filter (`elem` ps) $ getPostFlopOrder num++-- | Is a player hero or villain. Hero in poker means that the hand is from+-- the hero player's perspective.+data IsHero = Hero | Villain+ deriving (Read, Show, Eq, Ord, Enum, Bounded)++-- | A player's seat number at a poker table.+newtype Seat = Seat {_seat :: Int} deriving (Read, Show, Eq, Ord, Num)++-- | Total amount of money in the 'Pot'.+newtype Pot b = Pot {_pot :: b}+ deriving (Show, Eq, Ord, Num, Functor, Pretty, Semigroup, Monoid)++-- | Amount of money in a player's stack (not having been bet).+newtype Stack b = Stack {_stack :: b}+ deriving (Show, Eq, Ord, Num, Functor, Pretty, Semigroup)++-- | The state of a game with respect to cards turned and betting rounds.+data Board where+ RiverBoard :: !Card -> !Board -> Board+ TurnBoard :: !Card -> !Board -> Board+ FlopBoard :: (Card, Card, Card) -> !Board -> Board+ PreFlopBoard :: !Board -> Board+ InitialTable ::+ -- | Round where post actions occur.+ Board+ deriving (Eq, Ord, Show)++-- | Amount of money needed to join a game.+newtype Stake b = Stake {_stake :: b}+ deriving (Read, Show, Eq, Functor, Ord, Pretty)++-- | A bet done a player pre- or post-flop.+--+-- WARNING: Unstable API+data BetAction t+ = Call !t+ | Raise+ { raiseBy :: !t, -- TODO remove?+ raiseTo :: !t+ }+ | -- TODO remove AllInRaise+ AllInRaise+ { amountRaisedAI :: !t, -- TODO remove?+ raisedAITo :: !t+ }+ | Bet !t+ | -- TODO remove AllIn+ AllIn !t+ | Fold+ | Check+ deriving (Read, Show, Eq, Ord, Functor, Data, Typeable)
+ src/Poker/Range.hs view
@@ -0,0 +1,95 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DuplicateRecordFields #-}++-- | A range of Hole cards.+module Poker.Range+ ( Freq (..),+ Range (..),+ rangeFromList,+ getDecisionFreqRange,+ holdingRangeToShapedRange,+ addHoleToShapedRange,+ )+where++import Data.Bool (bool)+import Data.Map (Map)+import qualified Data.Map.Strict as Map+#if MIN_VERSION_prettyprinter(1,7,0)+import Prettyprinter+#else+import Data.Text.Prettyprint.Doc+#endif+import Poker.Cards++-- $setup+-- >>> :set -XTypeApplications+-- >>> :set -XOverloadedStrings+-- >>> import Poker.Cards+-- >>> import Poker.Range++-- | A frequency is an unevaluated ratio that indicates how often a decision was+-- made. For example, the value Freq (12, 34) indicates that out of the 34+-- people who faced this decision, 12 chose to make this decision.+data Freq = Freq !Int !Int+ deriving (Show, Eq)++instance Monoid Freq where+ mempty = Freq 0 0++instance Semigroup Freq where+ (Freq l1 r1) <> (Freq l2 r2) = Freq (l1 + l2) (r1 + r2)++-- | A simple wrapper around a 'Map' that uses different instances+-- for Semigroup. 'Range'\'s 'Semigroup' instance combines values at the same keys with '<>'+-- (unlike the 'Map' 'Semigroup' instance from @containers@).+--+-- Note that the 'Range'\'s internal 'Map' is strict.+newtype Range a b = Range+ {_range :: Map a b}+ deriving (Read, Eq, Show)++-- | Make a Range form a list.+rangeFromList :: Ord a => [(a, b)] -> Range a b+rangeFromList = Range . Map.fromList++-- | >>> mempty @(Range Hole Freq)+-- Range {_range = fromList []}+instance (Ord a, Monoid b) => Monoid (Range a b) where+ mempty = Range Map.empty++-- |+-- >>> let left = rangeFromList [("55p" :: ShapedHole, Freq 1 3)]+-- >>> let right = rangeFromList [("55p", Freq 10 32)]+-- >>> left <> right+-- Range {_range = fromList [(Pair Five,Freq 11 35)]}+instance (Ord a, Monoid b) => Semigroup (Range a b) where+ Range x <> Range y = Range $ x `uniRange` y+ where+ uniRange = Map.unionWith (<>)++instance (Pretty a, Pretty b) => Pretty (Range a b) where+ pretty ran =+ let m = Map.toList $ _range ran+ prettyValues =+ concatWith (surround comma) $+ map (\(c, i) -> pretty c <+> colon <+> pretty i) m+ in lbrace <+> prettyValues <+> rbrace++-- | Converts a 'Range' from key to action, to a 'Range' from key to decision+-- frequency, given a predicate that returns 'True' if the action matched the+-- decision.+getDecisionFreqRange ::+ Foldable f => (b -> Bool) -> Range a (f b) -> Range a Freq+getDecisionFreqRange p (Range m) =+ Range $ Map.map (foldMap (\v -> Freq (bool 0 1 $ p v) 1)) m++-- | Convert from a 'Range' of hole cards to a 'Range' of 'ShapedHole'.+holdingRangeToShapedRange :: Monoid v => Range Hole v -> Range ShapedHole v+holdingRangeToShapedRange (Range r) =+ Range $ Map.mapKeysWith (<>) holeToShapedHole r++-- | Add a singleton 'Hole' hand to a 'Range' of 'ShapedHole'.+addHoleToShapedRange :: Num a => a -> Hole -> Range ShapedHole a -> Range ShapedHole a+addHoleToShapedRange n comb (Range r) =+ Range $ Map.alter (pure . maybe 0 (+ n)) (holeToShapedHole comb) r
+ src/Poker/Utils.hs view
@@ -0,0 +1,4 @@+module Poker.Utils where++enumerate :: (Enum a, Bounded a) => [a]+enumerate = [minBound .. maxBound]
+ test/Driver.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF tasty-discover -optF --hide-successes #-}
+ test/Test/Poker/Cards.hs view
@@ -0,0 +1,303 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++module Test.Poker.Cards where++import Control.Applicative+import Control.Monad+#if MIN_VERSION_prettyprinter(1,7,0)+import Prettyprinter+#else+import Data.Text.Prettyprint.Doc+#endif+import Data.Functor+import Data.List.Extra+import Data.Maybe+import Data.String (IsString (fromString))+import Data.Text (Text)+import Poker+import Test.Hspec++spec_rankToChr :: SpecWith ()+spec_rankToChr = do+ it "rankToChr" $ (allRanks <&> rankToChr) `shouldBe` "23456789TJQKA"++spec_chrToRank :: SpecWith ()+spec_chrToRank = do+ it "chrToRank <$> \"23456789TJQKA\"" $ (fromJust . chrToRank <$> "23456789TJQKA") `shouldBe` allRanks+ it "chrToRank '1' == Nothing" $ chrToRank '1' `shouldBe` Nothing++spec_suitToChr :: SpecWith ()+spec_suitToChr = do+ it "suitToChr" $ (allSuits <&> suitToChr) `shouldBe` "cdhs"++spec_chrToSuit :: SpecWith ()+spec_chrToSuit = do+ it "chrToSuit <$> \"cdhs\"" $ (fromJust . chrToSuit <$> "cdhs") `shouldBe` allSuits+ it "chrToSuit '1' == Nothing" $ chrToSuit '1' `shouldBe` Nothing++spec_cardToShortTxt :: SpecWith ()+spec_cardToShortTxt = it "cardToShortTxt" $ forM_ cardCases \(txt, card) -> cardToShortTxt card `shouldBe` txt++spec_cardFromShortTxt :: SpecWith ()+spec_cardFromShortTxt = do+ it "cardFromShortTxt returns Just for all cards" $ forM_ cardCases \(txt, card) -> cardFromShortTxt txt `shouldBe` Just card+ it "cardFromShortTxt \"Ac\" == Just (Card Ace Club)" $ cardFromShortTxt "Ac" `shouldBe` Just (Card Ace Club)+ it "cardFromShortTxt \"Acd\" == Nothing" $ cardFromShortTxt "Acd" `shouldBe` Nothing+ it "cardFromShortTxt \"AcAd\" == Nothing" $ cardFromShortTxt "AcAd" `shouldBe` Nothing++cardCases :: [(Text, Card)]+cardCases =+ [ ("As", Card Ace Spade),+ ("Ah", Card Ace Heart),+ ("Ad", Card Ace Diamond),+ ("Ac", Card Ace Club),+ ("Ks", Card King Spade),+ ("Kh", Card King Heart),+ ("Kd", Card King Diamond),+ ("Kc", Card King Club),+ ("Qs", Card Queen Spade),+ ("Qh", Card Queen Heart),+ ("Qd", Card Queen Diamond),+ ("Qc", Card Queen Club),+ ("Js", Card Jack Spade),+ ("Jh", Card Jack Heart),+ ("Jd", Card Jack Diamond),+ ("Jc", Card Jack Club),+ ("Ts", Card Ten Spade),+ ("Th", Card Ten Heart),+ ("Td", Card Ten Diamond),+ ("Tc", Card Ten Club),+ ("9s", Card Nine Spade),+ ("9h", Card Nine Heart),+ ("9d", Card Nine Diamond),+ ("9c", Card Nine Club),+ ("8s", Card Eight Spade),+ ("8h", Card Eight Heart),+ ("8d", Card Eight Diamond),+ ("8c", Card Eight Club),+ ("7s", Card Seven Spade),+ ("7h", Card Seven Heart),+ ("7d", Card Seven Diamond),+ ("7c", Card Seven Club),+ ("6s", Card Six Spade),+ ("6h", Card Six Heart),+ ("6d", Card Six Diamond),+ ("6c", Card Six Club),+ ("5s", Card Five Spade),+ ("5h", Card Five Heart),+ ("5d", Card Five Diamond),+ ("5c", Card Five Club),+ ("4s", Card Four Spade),+ ("4h", Card Four Heart),+ ("4d", Card Four Diamond),+ ("4c", Card Four Club),+ ("3s", Card Three Spade),+ ("3h", Card Three Heart),+ ("3d", Card Three Diamond),+ ("3c", Card Three Club),+ ("2s", Card Two Spade),+ ("2h", Card Two Heart),+ ("2d", Card Two Diamond),+ ("2c", Card Two Club)+ ]++spec_mkHole :: SpecWith ()+spec_mkHole = do+ let aceS = Card Ace Spade+ let kingD = Card King Diamond+ it "mkHole" $+ mkHole aceS kingD `shouldSatisfy` \case+ Just (UnsafeHole c1 c2) | c1 == aceS, c2 == kingD -> True+ _ -> False+ it "mkHole order doesn't matter" $+ mkHole aceS kingD `shouldBe` mkHole kingD aceS+ it "fail" $ let c = Card Two Club in mkHole c c `shouldBe` Nothing+ it "order doesn't matter" $+ allCardPairs+ `shouldSatisfy` all+ (\(c1, c2) -> mkHole c1 c2 == mkHole c2 c1)+ it "non-equal cards always succeed" $+ allCardPairs+ `shouldSatisfy` all+ (\(c1, c2) -> c1 == c2 || isJust (mkHole c1 c2))+ where+ allCardPairs = [(c1, c2) | c1 <- allCards, c2 <- allCards]++spec_mkShapedHole :: SpecWith ()+spec_mkShapedHole = do+ it "mkPair" $+ mkPair Ace `shouldSatisfy` \case+ Pair Ace -> True+ _ -> False+ it "mkSuited success" $+ mkSuited Ace King+ `shouldSatisfy` ( \case+ Just (UnsafeSuited Ace King) -> True+ _ -> False+ )+ it "mkSuited wrong order succeeds" $+ mkSuited King Ace+ `shouldSatisfy` ( \case+ Just (UnsafeSuited Ace King) -> True+ _ -> False+ )+ it "mkSuited failure" $ mkSuited King King `shouldBe` Nothing+ it "mkOffsuit success" $+ mkOffsuit Ace King+ `shouldSatisfy` ( \case+ Just (UnsafeOffsuit Ace King) -> True+ _ -> False+ )+ it "mkOffsuit wrong order succeeds" $+ mkOffsuit King Ace+ `shouldSatisfy` ( \case+ Just (UnsafeOffsuit Ace King) -> True+ _ -> False+ )+ it "mkOffsuit failure" $ mkOffsuit King King `shouldBe` Nothing++spec_prettyCard :: SpecWith ()+spec_prettyCard = do+ it "Ac" $ show (pretty (Card Ace Club)) `shouldBe` "Ac"+ it "2h" $ show (pretty (Card Two Heart)) `shouldBe` "2h"++spec_cardIsString :: SpecWith ()+spec_cardIsString = do+ it "Ac is Card Ace Club" $ "Ac" `shouldBe` Card Ace Club+ it "2h is Card Two Heart" $ "2h" `shouldBe` Card Two Heart+ let failCase = failingIsString @Card+ mapM_ failCase ["Ac2h", "AA", "cc"]++spec_holeIsString :: SpecWith ()+spec_holeIsString = do+ it "AcKh" $ "AcKh" `shouldBe` fromJust (mkHole (Card Ace Club) (Card King Heart))+ it "AcKh == KhAc" $ ("AcKh" :: Hole) `shouldBe` "KhAc"+ let failCase = failingIsString @Hole+ mapM_ failCase ["AAKh", "AcKK", "Ac", "AcK", "AcKhQd"]++spec_prettyHole :: SpecWith ()+spec_prettyHole = do+ it "AcKh" $ show (pretty . fromJust $ mkHole (Card Ace Club) (Card King Heart)) `shouldBe` "AcKh"+ it "5s2d" $ show (pretty . fromJust $ mkHole (Card Five Spade) (Card Two Diamond)) `shouldBe` "5s2d"++spec_prettyShapedHole :: SpecWith ()+spec_prettyShapedHole = do+ it "Offsuit" $ show (pretty (mkOffsuit Ace Two)) `shouldBe` "A2o"+ it "Pair" $ show (pretty (mkPair Ace)) `shouldBe` "AAp"+ it "Suited" $ show (pretty (mkSuited Ace Two)) `shouldBe` "A2s"++spec_isStringShapedHole :: SpecWith ()+spec_isStringShapedHole = do+ it "AKo" $ "AKo" `shouldBe` unsafeOffsuit Ace King+ it "AKo == KAo" $ ("AKo" :: ShapedHole) `shouldBe` "KAo"+ it "AKs" $ "AKs" `shouldBe` unsafeSuited Ace King+ it "AKs == KAs" $ ("AKs" :: ShapedHole) `shouldBe` "KAs"+ it "AAp" $ "AAp" `shouldBe` Pair Ace+ let failCase = failingIsString @ShapedHole+ mapM_+ failCase+ ["AKp", "AKf", "AFo", "FKo", "Kp", "AA", "p"]++spec_holeToShaped :: SpecWith ()+spec_holeToShaped = do+ let doCase hole shaped = it (hole <> " => " <> shaped) $ holeToShapedHole (fromString hole) `shouldBe` fromString shaped+ doCase "AcKd" "AKo"+ doCase "AcKc" "AKs"+ doCase "AcAs" "AAp"++spec_shapedHoleToHoles :: SpecWith ()+spec_shapedHoleToHoles = do+ mkCase "Pair" "55p" ["5d5c", "5h5c", "5s5c", "5h5d", "5s5d", "5s5h"]+ mkCase "Suited" "AKs" ["AcKc", "AdKd", "AhKh", "AsKs"]+ mkCase "Offsuit" "QTo" offSuitExpected+ it "Sanity test OffSuit" $ offSuitExpected `shouldSatisfy` not . anySame+ where+ offSuitExpected =+ [ "QcTd",+ "QcTh",+ "QcTs",+ "QdTc",+ "QdTh",+ "QdTs",+ "QhTc",+ "QhTd",+ "QhTs",+ "QsTc",+ "QsTd",+ "QsTh"+ ]+ mkCase name combo expected =+ it name $+ shapedHoleToHoles (fromString combo)+ `shouldBe` fromString+ <$> expected++spec_toUnicode :: SpecWith ()+spec_toUnicode = do+ it "encode Suit" $+ suitToUnicode+ <$> (enumerate @Suit)+ `shouldBe` "\9827\9830\9829\9824" -- TODO fix tasty-discover bug wrt unicode+ it "fromUnicode . toUnicode forms isomorphism" $+ fromJust+ . suitFromUnicode+ . suitToUnicode+ <$> enumerate @Suit+ `shouldBe` enumerate @Suit+ it "fromUnicode fail" $ suitFromUnicode 'b' `shouldBe` Nothing++spec_all :: SpecWith ()+spec_all = do+ describe "enumerate" $ do+ it "Rank" $ allRanks `shouldBe` allRanksExpected+ it "Suit" $ allSuits `shouldBe` allSuitsExpected+ it "Card" $ allCards `shouldBe` allCardsExpected+ it "number of Holes should be 1326" $ length allHoles `shouldBe` 1326+ it "allHoles are unique" $ nub allHoles `shouldBe` allHoles+ it "allHoles Hole cards are valid" $+ allHoles `forM_` flip shouldSatisfy (\(UnsafeHole c1 c2) -> c1 > c2)+ it "number of ShapedHoles should be 169" $+ length allShapedHoles+ `shouldBe` 169+ it "allShapedHoles are unique" $ nub allShapedHoles `shouldBe` allShapedHoles+ it "allShapedHoles" $ allShapedHoles `shouldBe` allShapedHolesExpected+ it "allShapedHoles ShapedHole ranks are valid" $+ allShapedHoles+ `forM_` flip+ shouldSatisfy+ ( \case+ (Pair _) -> True+ (UnsafeOffsuit r1 r2) -> r1 > r2+ (UnsafeSuited r1 r2) -> r1 > r2+ )+ where+ allSuitsExpected = [Club, Diamond, Heart, Spade]+ allRanksExpected =+ [ Two,+ Three,+ Four,+ Five,+ Six,+ Seven,+ Eight,+ Nine,+ Ten,+ Jack,+ Queen,+ King,+ Ace+ ]+ allCardsExpected = liftA2 Card allRanks allSuits+ allShapedHolesExpected = ["AAp", "AKs", "AQs", "AJs", "ATs", "A9s", "A8s", "A7s", "A6s", "A5s", "A4s", "A3s", "A2s", "AKo", "KKp", "KQs", "KJs", "KTs", "K9s", "K8s", "K7s", "K6s", "K5s", "K4s", "K3s", "K2s", "AQo", "KQo", "QQp", "QJs", "QTs", "Q9s", "Q8s", "Q7s", "Q6s", "Q5s", "Q4s", "Q3s", "Q2s", "AJo", "KJo", "QJo", "JJp", "JTs", "J9s", "J8s", "J7s", "J6s", "J5s", "J4s", "J3s", "J2s", "ATo", "KTo", "QTo", "JTo", "TTp", "T9s", "T8s", "T7s", "T6s", "T5s", "T4s", "T3s", "T2s", "A9o", "K9o", "Q9o", "J9o", "T9o", "99p", "98s", "97s", "96s", "95s", "94s", "93s", "92s", "A8o", "K8o", "Q8o", "J8o", "T8o", "98o", "88p", "87s", "86s", "85s", "84s", "83s", "82s", "A7o", "K7o", "Q7o", "J7o", "T7o", "97o", "87o", "77p", "76s", "75s", "74s", "73s", "72s", "A6o", "K6o", "Q6o", "J6o", "T6o", "96o", "86o", "76o", "66p", "65s", "64s", "63s", "62s", "A5o", "K5o", "Q5o", "J5o", "T5o", "95o", "85o", "75o", "65o", "55p", "54s", "53s", "52s", "A4o", "K4o", "Q4o", "J4o", "T4o", "94o", "84o", "74o", "64o", "54o", "44p", "43s", "42s", "A3o", "K3o", "Q3o", "J3o", "T3o", "93o", "83o", "73o", "63o", "53o", "43o", "33p", "32s", "A2o", "K2o", "Q2o", "J2o", "T2o", "92o", "82o", "72o", "62o", "52o", "42o", "32o", "22p"]++spec_freshDeck :: SpecWith ()+spec_freshDeck = it "freshDeck" $ freshDeck `shouldBe` unsafeDeck allCards++-- Check that a call to IsString fails for the given type. Values are forced via+-- value's Show instance+failingIsString :: forall a. (IsString a, Show a) => String -> SpecWith ()+failingIsString str = it (str <> " fails") $ print (fromString @a str) `shouldThrow` anyErrorCall
+ test/Test/Poker/Game.hs view
@@ -0,0 +1,13 @@+{-# LANGUAGE OverloadedStrings #-}++module Test.Poker.Game where++import Poker+import Test.Hspec++spec_allPositions :: SpecWith ()+spec_allPositions = do+ it "heads up all positions" $ (positionToTxt TwoPlayers <$> allPositions TwoPlayers) `shouldBe` ["BU", "BB"]+ it "3max all positions" $ (positionToTxt ThreePlayers <$> allPositions ThreePlayers) `shouldBe` ["BU", "SB", "BB"]+ it "4max all positions" $ (positionToTxt FourPlayers <$> allPositions FourPlayers) `shouldBe` ["CO", "BU", "SB", "BB"]+ it "9max all positions" $ (positionToTxt NinePlayers <$> allPositions NinePlayers) `shouldBe` ["UTG", "UTG1", "UTG2", "LJ", "HJ", "CO", "BU", "SB", "BB"]
+ test/Test/Poker/Range.hs view
@@ -0,0 +1,33 @@+module Test.Poker.Range where++import qualified Data.Map.Strict as Map+import Poker.Range+ ( Freq (Freq),+ Range (Range),+ )+import qualified Poker.Range as Range+import Test.Hspec++spec_RangefromList :: SpecWith ()+spec_RangefromList =+ let m = Range.rangeFromList [(1 :: Int, "bar")]+ in it "fromList" $ m `shouldBe` Range (Map.fromList [(1, "bar")])++spec_RangeMonoid :: SpecWith ()+spec_RangeMonoid = describe "Monoid instance for Range" $ do+ it "mempty is empty map" $+ mempty @(Range Int String)+ `shouldBe` Range Map.empty+ it "<> uses <> itemwise" $+ Range.rangeFromList [(1 :: Int, "foo")]+ <> Range.rangeFromList [(1, "bar")]+ `shouldBe` Range.rangeFromList [(1, "foobar")]+ it "empty items are not lost" $+ Range.rangeFromList [(1 :: Int, "foo")]+ <> Range.rangeFromList [(2, "bar")]+ `shouldBe` Range.rangeFromList [(1, "foo"), (2, "bar")]++spec_FreqMonoid :: SpecWith ()+spec_FreqMonoid = describe "Freq Monoid instance" $ do+ it "mempty is (0, 0)" $ mempty @Freq `shouldBe` Freq 0 0+ it "<> adds each side" $ Freq 0 1 <> Freq 7 11 `shouldBe` Freq 7 12