diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,3 @@ +# Changelog for Exploit + +## Unreleased changes diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,44 @@ +## poker-base + +[![Hackage](https://img.shields.io/hackage/v/poker-base.svg)](https://hackage.haskell.org/package/poker-base) +[![Build Status](https://github.com/santiweight/poker-base/workflows/haskell-ci/badge.svg)](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. diff --git a/poker-base.cabal b/poker-base.cabal new file mode 100644 --- /dev/null +++ b/poker-base.cabal @@ -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 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 diff --git a/src/Poker.hs b/src/Poker.hs new file mode 100644 --- /dev/null +++ b/src/Poker.hs @@ -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" diff --git a/src/Poker/Amount.hs b/src/Poker/Amount.hs new file mode 100644 --- /dev/null +++ b/src/Poker/Amount.hs @@ -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 +-- 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 +-- 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 diff --git a/src/Poker/Cards.hs b/src/Poker/Cards.hs new file mode 100644 --- /dev/null +++ b/src/Poker/Cards.hs @@ -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 diff --git a/src/Poker/Game.hs b/src/Poker/Game.hs new file mode 100644 --- /dev/null +++ b/src/Poker/Game.hs @@ -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) diff --git a/src/Poker/Range.hs b/src/Poker/Range.hs new file mode 100644 --- /dev/null +++ b/src/Poker/Range.hs @@ -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 diff --git a/src/Poker/Utils.hs b/src/Poker/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Poker/Utils.hs @@ -0,0 +1,4 @@ +module Poker.Utils where + +enumerate :: (Enum a, Bounded a) => [a] +enumerate = [minBound .. maxBound] diff --git a/test/Driver.hs b/test/Driver.hs new file mode 100644 --- /dev/null +++ b/test/Driver.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF tasty-discover -optF --hide-successes #-} diff --git a/test/Test/Poker/Cards.hs b/test/Test/Poker/Cards.hs new file mode 100644 --- /dev/null +++ b/test/Test/Poker/Cards.hs @@ -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 diff --git a/test/Test/Poker/Game.hs b/test/Test/Poker/Game.hs new file mode 100644 --- /dev/null +++ b/test/Test/Poker/Game.hs @@ -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"] diff --git a/test/Test/Poker/Range.hs b/test/Test/Poker/Range.hs new file mode 100644 --- /dev/null +++ b/test/Test/Poker/Range.hs @@ -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