{-# 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 (Int -> Rank
Rank -> Int
Rank -> [Rank]
Rank -> Rank
Rank -> Rank -> [Rank]
Rank -> Rank -> Rank -> [Rank]
(Rank -> Rank)
-> (Rank -> Rank)
-> (Int -> Rank)
-> (Rank -> Int)
-> (Rank -> [Rank])
-> (Rank -> Rank -> [Rank])
-> (Rank -> Rank -> [Rank])
-> (Rank -> Rank -> Rank -> [Rank])
-> Enum Rank
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: Rank -> Rank -> Rank -> [Rank]
$cenumFromThenTo :: Rank -> Rank -> Rank -> [Rank]
enumFromTo :: Rank -> Rank -> [Rank]
$cenumFromTo :: Rank -> Rank -> [Rank]
enumFromThen :: Rank -> Rank -> [Rank]
$cenumFromThen :: Rank -> Rank -> [Rank]
enumFrom :: Rank -> [Rank]
$cenumFrom :: Rank -> [Rank]
fromEnum :: Rank -> Int
$cfromEnum :: Rank -> Int
toEnum :: Int -> Rank
$ctoEnum :: Int -> Rank
pred :: Rank -> Rank
$cpred :: Rank -> Rank
succ :: Rank -> Rank
$csucc :: Rank -> Rank
Enum, Rank
Rank -> Rank -> Bounded Rank
forall a. a -> a -> Bounded a
maxBound :: Rank
$cmaxBound :: Rank
minBound :: Rank
$cminBound :: Rank
Bounded, Rank -> Rank -> Bool
(Rank -> Rank -> Bool) -> (Rank -> Rank -> Bool) -> Eq Rank
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Rank -> Rank -> Bool
$c/= :: Rank -> Rank -> Bool
== :: Rank -> Rank -> Bool
$c== :: Rank -> Rank -> Bool
Eq, Eq Rank
Eq Rank
-> (Rank -> Rank -> Ordering)
-> (Rank -> Rank -> Bool)
-> (Rank -> Rank -> Bool)
-> (Rank -> Rank -> Bool)
-> (Rank -> Rank -> Bool)
-> (Rank -> Rank -> Rank)
-> (Rank -> Rank -> Rank)
-> Ord Rank
Rank -> Rank -> Bool
Rank -> Rank -> Ordering
Rank -> Rank -> Rank
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Rank -> Rank -> Rank
$cmin :: Rank -> Rank -> Rank
max :: Rank -> Rank -> Rank
$cmax :: Rank -> Rank -> Rank
>= :: Rank -> Rank -> Bool
$c>= :: Rank -> Rank -> Bool
> :: Rank -> Rank -> Bool
$c> :: Rank -> Rank -> Bool
<= :: Rank -> Rank -> Bool
$c<= :: Rank -> Rank -> Bool
< :: Rank -> Rank -> Bool
$c< :: Rank -> Rank -> Bool
compare :: Rank -> Rank -> Ordering
$ccompare :: Rank -> Rank -> Ordering
$cp1Ord :: Eq Rank
Ord, Int -> Rank -> ShowS
[Rank] -> ShowS
Rank -> String
(Int -> Rank -> ShowS)
-> (Rank -> String) -> ([Rank] -> ShowS) -> Show Rank
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Rank] -> ShowS
$cshowList :: [Rank] -> ShowS
show :: Rank -> String
$cshow :: Rank -> String
showsPrec :: Int -> Rank -> ShowS
$cshowsPrec :: Int -> Rank -> ShowS
Show, ReadPrec [Rank]
ReadPrec Rank
Int -> ReadS Rank
ReadS [Rank]
(Int -> ReadS Rank)
-> ReadS [Rank] -> ReadPrec Rank -> ReadPrec [Rank] -> Read Rank
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Rank]
$creadListPrec :: ReadPrec [Rank]
readPrec :: ReadPrec Rank
$creadPrec :: ReadPrec Rank
readList :: ReadS [Rank]
$creadList :: ReadS [Rank]
readsPrec :: Int -> ReadS Rank
$creadsPrec :: Int -> ReadS Rank
Read, (forall x. Rank -> Rep Rank x)
-> (forall x. Rep Rank x -> Rank) -> Generic Rank
forall x. Rep Rank x -> Rank
forall x. Rank -> Rep Rank x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Rank x -> Rank
$cfrom :: forall x. Rank -> Rep Rank x
Generic)
  deriving (Gen Rank
Gen Rank -> (Rank -> [Rank]) -> Arbitrary Rank
Rank -> [Rank]
forall a. Gen a -> (a -> [a]) -> Arbitrary a
shrink :: Rank -> [Rank]
$cshrink :: Rank -> [Rank]
arbitrary :: Gen Rank
$carbitrary :: Gen Rank
Arbitrary) via GenericArbitrary Rank

-- | >>> pretty <$> allRanks
-- [2,3,4,5,6,7,8,9,T,J,Q,K,A]
instance Pretty Rank where
  pretty :: Rank -> Doc ann
pretty = Text -> Doc ann
forall ann. Text -> Doc ann
unsafeTextWithoutNewlines (Text -> Doc ann) -> (Rank -> Text) -> Rank -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Text
T.singleton (Char -> Text) -> (Rank -> Char) -> Rank -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rank -> Char
rankToChr

-- | >>> allRanks
-- [Two,Three,Four,Five,Six,Seven,Eight,Nine,Ten,Jack,Queen,King,Ace]
allRanks :: [Rank]
allRanks :: [Rank]
allRanks = (Enum Rank, Bounded Rank) => [Rank]
forall a. (Enum a, Bounded a) => [a]
enumerate @Rank

-- | >>> rankToChr <$> allRanks
-- "23456789TJQKA"
rankToChr :: Rank -> Char
rankToChr :: Rank -> Char
rankToChr = \case
  Rank
Two -> Char
'2'
  Rank
Three -> Char
'3'
  Rank
Four -> Char
'4'
  Rank
Five -> Char
'5'
  Rank
Six -> Char
'6'
  Rank
Seven -> Char
'7'
  Rank
Eight -> Char
'8'
  Rank
Nine -> Char
'9'
  Rank
Ten -> Char
'T'
  Rank
Jack -> Char
'J'
  Rank
Queen -> Char
'Q'
  Rank
King -> Char
'K'
  Rank
Ace -> Char
'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 :: Char -> Maybe Rank
chrToRank = \case
  Char
'2' -> Rank -> Maybe Rank
forall (f :: * -> *) a. Applicative f => a -> f a
pure Rank
Two
  Char
'3' -> Rank -> Maybe Rank
forall (f :: * -> *) a. Applicative f => a -> f a
pure Rank
Three
  Char
'4' -> Rank -> Maybe Rank
forall (f :: * -> *) a. Applicative f => a -> f a
pure Rank
Four
  Char
'5' -> Rank -> Maybe Rank
forall (f :: * -> *) a. Applicative f => a -> f a
pure Rank
Five
  Char
'6' -> Rank -> Maybe Rank
forall (f :: * -> *) a. Applicative f => a -> f a
pure Rank
Six
  Char
'7' -> Rank -> Maybe Rank
forall (f :: * -> *) a. Applicative f => a -> f a
pure Rank
Seven
  Char
'8' -> Rank -> Maybe Rank
forall (f :: * -> *) a. Applicative f => a -> f a
pure Rank
Eight
  Char
'9' -> Rank -> Maybe Rank
forall (f :: * -> *) a. Applicative f => a -> f a
pure Rank
Nine
  Char
'T' -> Rank -> Maybe Rank
forall (f :: * -> *) a. Applicative f => a -> f a
pure Rank
Ten
  Char
'J' -> Rank -> Maybe Rank
forall (f :: * -> *) a. Applicative f => a -> f a
pure Rank
Jack
  Char
'Q' -> Rank -> Maybe Rank
forall (f :: * -> *) a. Applicative f => a -> f a
pure Rank
Queen
  Char
'K' -> Rank -> Maybe Rank
forall (f :: * -> *) a. Applicative f => a -> f a
pure Rank
King
  Char
'A' -> Rank -> Maybe Rank
forall (f :: * -> *) a. Applicative f => a -> f a
pure Rank
Ace
  Char
_ -> Maybe Rank
forall a. Maybe a
Nothing

-- | The 'Suit' of a playing 'Card'
data Suit = Club | Diamond | Heart | Spade
  deriving (Int -> Suit
Suit -> Int
Suit -> [Suit]
Suit -> Suit
Suit -> Suit -> [Suit]
Suit -> Suit -> Suit -> [Suit]
(Suit -> Suit)
-> (Suit -> Suit)
-> (Int -> Suit)
-> (Suit -> Int)
-> (Suit -> [Suit])
-> (Suit -> Suit -> [Suit])
-> (Suit -> Suit -> [Suit])
-> (Suit -> Suit -> Suit -> [Suit])
-> Enum Suit
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: Suit -> Suit -> Suit -> [Suit]
$cenumFromThenTo :: Suit -> Suit -> Suit -> [Suit]
enumFromTo :: Suit -> Suit -> [Suit]
$cenumFromTo :: Suit -> Suit -> [Suit]
enumFromThen :: Suit -> Suit -> [Suit]
$cenumFromThen :: Suit -> Suit -> [Suit]
enumFrom :: Suit -> [Suit]
$cenumFrom :: Suit -> [Suit]
fromEnum :: Suit -> Int
$cfromEnum :: Suit -> Int
toEnum :: Int -> Suit
$ctoEnum :: Int -> Suit
pred :: Suit -> Suit
$cpred :: Suit -> Suit
succ :: Suit -> Suit
$csucc :: Suit -> Suit
Enum, Suit
Suit -> Suit -> Bounded Suit
forall a. a -> a -> Bounded a
maxBound :: Suit
$cmaxBound :: Suit
minBound :: Suit
$cminBound :: Suit
Bounded, Suit -> Suit -> Bool
(Suit -> Suit -> Bool) -> (Suit -> Suit -> Bool) -> Eq Suit
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Suit -> Suit -> Bool
$c/= :: Suit -> Suit -> Bool
== :: Suit -> Suit -> Bool
$c== :: Suit -> Suit -> Bool
Eq, Eq Suit
Eq Suit
-> (Suit -> Suit -> Ordering)
-> (Suit -> Suit -> Bool)
-> (Suit -> Suit -> Bool)
-> (Suit -> Suit -> Bool)
-> (Suit -> Suit -> Bool)
-> (Suit -> Suit -> Suit)
-> (Suit -> Suit -> Suit)
-> Ord Suit
Suit -> Suit -> Bool
Suit -> Suit -> Ordering
Suit -> Suit -> Suit
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Suit -> Suit -> Suit
$cmin :: Suit -> Suit -> Suit
max :: Suit -> Suit -> Suit
$cmax :: Suit -> Suit -> Suit
>= :: Suit -> Suit -> Bool
$c>= :: Suit -> Suit -> Bool
> :: Suit -> Suit -> Bool
$c> :: Suit -> Suit -> Bool
<= :: Suit -> Suit -> Bool
$c<= :: Suit -> Suit -> Bool
< :: Suit -> Suit -> Bool
$c< :: Suit -> Suit -> Bool
compare :: Suit -> Suit -> Ordering
$ccompare :: Suit -> Suit -> Ordering
$cp1Ord :: Eq Suit
Ord, Int -> Suit -> ShowS
[Suit] -> ShowS
Suit -> String
(Int -> Suit -> ShowS)
-> (Suit -> String) -> ([Suit] -> ShowS) -> Show Suit
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Suit] -> ShowS
$cshowList :: [Suit] -> ShowS
show :: Suit -> String
$cshow :: Suit -> String
showsPrec :: Int -> Suit -> ShowS
$cshowsPrec :: Int -> Suit -> ShowS
Show, ReadPrec [Suit]
ReadPrec Suit
Int -> ReadS Suit
ReadS [Suit]
(Int -> ReadS Suit)
-> ReadS [Suit] -> ReadPrec Suit -> ReadPrec [Suit] -> Read Suit
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Suit]
$creadListPrec :: ReadPrec [Suit]
readPrec :: ReadPrec Suit
$creadPrec :: ReadPrec Suit
readList :: ReadS [Suit]
$creadList :: ReadS [Suit]
readsPrec :: Int -> ReadS Suit
$creadsPrec :: Int -> ReadS Suit
Read, (forall x. Suit -> Rep Suit x)
-> (forall x. Rep Suit x -> Suit) -> Generic Suit
forall x. Rep Suit x -> Suit
forall x. Suit -> Rep Suit x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Suit x -> Suit
$cfrom :: forall x. Suit -> Rep Suit x
Generic)
  deriving (Gen Suit
Gen Suit -> (Suit -> [Suit]) -> Arbitrary Suit
Suit -> [Suit]
forall a. Gen a -> (a -> [a]) -> Arbitrary a
shrink :: Suit -> [Suit]
$cshrink :: Suit -> [Suit]
arbitrary :: Gen Suit
$carbitrary :: Gen Suit
Arbitrary) via GenericArbitrary Suit

-- | >>> pretty allSuits
-- [c, d, h, s]
instance Pretty Suit where
  pretty :: Suit -> Doc ann
pretty = Char -> Doc ann
forall ann. Char -> Doc ann
Char (Char -> Doc ann) -> (Suit -> Char) -> Suit -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Suit -> Char
suitToChr

-- | >>> allSuits
-- [Club,Diamond,Heart,Spade]
allSuits :: [Suit]
allSuits :: [Suit]
allSuits = (Enum Suit, Bounded Suit) => [Suit]
forall a. (Enum a, Bounded a) => [a]
enumerate @Suit

-- | >>> suitToChr <$> allSuits
-- "cdhs"
suitToChr :: Suit -> Char
suitToChr :: Suit -> Char
suitToChr = \case
  Suit
Club -> Char
'c'
  Suit
Diamond -> Char
'd'
  Suit
Heart -> Char
'h'
  Suit
Spade -> Char
's'

-- | >>> map (fromJust . chrToSuit) "cdhs"
-- [Club,Diamond,Heart,Spade]
-- >>> chrToSuit 'x'
-- Nothing
--
-- prop> \s -> chrToSuit (suitToChr s) == Just s
chrToSuit :: Char -> Maybe Suit
chrToSuit :: Char -> Maybe Suit
chrToSuit = \case
  Char
'c' -> Suit -> Maybe Suit
forall (f :: * -> *) a. Applicative f => a -> f a
pure Suit
Club
  Char
'd' -> Suit -> Maybe Suit
forall (f :: * -> *) a. Applicative f => a -> f a
pure Suit
Diamond
  Char
'h' -> Suit -> Maybe Suit
forall (f :: * -> *) a. Applicative f => a -> f a
pure Suit
Heart
  Char
's' -> Suit -> Maybe Suit
forall (f :: * -> *) a. Applicative f => a -> f a
pure Suit
Spade
  Char
_ -> Maybe Suit
forall a. Maybe a
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 :: Suit -> Char
suitToUnicode = \case
  Suit
Club -> Char
'♣'
  Suit
Diamond -> Char
'♦'
  Suit
Heart -> Char
'♥'
  Suit
Spade -> Char
'♠'

-- | >>> suitFromUnicode <$> ['♣', '♦', '♥', '♠']
-- [Just Club,Just Diamond,Just Heart,Just Spade]
--
-- prop> \s -> suitFromUnicode (suitToUnicode s) == Just s
suitFromUnicode :: Char -> Maybe Suit
suitFromUnicode :: Char -> Maybe Suit
suitFromUnicode = \case
  Char
'♣' -> Suit -> Maybe Suit
forall a. a -> Maybe a
Just Suit
Club
  Char
'♦' -> Suit -> Maybe Suit
forall a. a -> Maybe a
Just Suit
Diamond
  Char
'♥' -> Suit -> Maybe Suit
forall a. a -> Maybe a
Just Suit
Heart
  Char
'♠' -> Suit -> Maybe Suit
forall a. a -> Maybe a
Just Suit
Spade
  Char
_ -> Maybe Suit
forall a. Maybe a
Nothing

-- | Representation of a playing card.
data Card = Card
  { Card -> Rank
rank :: !Rank,
    Card -> Suit
suit :: !Suit
  }
  deriving (Card -> Card -> Bool
(Card -> Card -> Bool) -> (Card -> Card -> Bool) -> Eq Card
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Card -> Card -> Bool
$c/= :: Card -> Card -> Bool
== :: Card -> Card -> Bool
$c== :: Card -> Card -> Bool
Eq, Eq Card
Eq Card
-> (Card -> Card -> Ordering)
-> (Card -> Card -> Bool)
-> (Card -> Card -> Bool)
-> (Card -> Card -> Bool)
-> (Card -> Card -> Bool)
-> (Card -> Card -> Card)
-> (Card -> Card -> Card)
-> Ord Card
Card -> Card -> Bool
Card -> Card -> Ordering
Card -> Card -> Card
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Card -> Card -> Card
$cmin :: Card -> Card -> Card
max :: Card -> Card -> Card
$cmax :: Card -> Card -> Card
>= :: Card -> Card -> Bool
$c>= :: Card -> Card -> Bool
> :: Card -> Card -> Bool
$c> :: Card -> Card -> Bool
<= :: Card -> Card -> Bool
$c<= :: Card -> Card -> Bool
< :: Card -> Card -> Bool
$c< :: Card -> Card -> Bool
compare :: Card -> Card -> Ordering
$ccompare :: Card -> Card -> Ordering
$cp1Ord :: Eq Card
Ord, Int -> Card -> ShowS
[Card] -> ShowS
Card -> String
(Int -> Card -> ShowS)
-> (Card -> String) -> ([Card] -> ShowS) -> Show Card
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Card] -> ShowS
$cshowList :: [Card] -> ShowS
show :: Card -> String
$cshow :: Card -> String
showsPrec :: Int -> Card -> ShowS
$cshowsPrec :: Int -> Card -> ShowS
Show, ReadPrec [Card]
ReadPrec Card
Int -> ReadS Card
ReadS [Card]
(Int -> ReadS Card)
-> ReadS [Card] -> ReadPrec Card -> ReadPrec [Card] -> Read Card
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Card]
$creadListPrec :: ReadPrec [Card]
readPrec :: ReadPrec Card
$creadPrec :: ReadPrec Card
readList :: ReadS [Card]
$creadList :: ReadS [Card]
readsPrec :: Int -> ReadS Card
$creadsPrec :: Int -> ReadS Card
Read, (forall x. Card -> Rep Card x)
-> (forall x. Rep Card x -> Card) -> Generic Card
forall x. Rep Card x -> Card
forall x. Card -> Rep Card x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Card x -> Card
$cfrom :: forall x. Card -> Rep Card x
Generic)
  deriving (Gen Card
Gen Card -> (Card -> [Card]) -> Arbitrary Card
Card -> [Card]
forall a. Gen a -> (a -> [a]) -> Arbitrary a
shrink :: Card -> [Card]
$cshrink :: Card -> [Card]
arbitrary :: Gen Card
$carbitrary :: Gen Card
Arbitrary) via GenericArbitrary Card

-- | >>> pretty ("Ac" :: Card)
-- Ac
instance Pretty Card where
  pretty :: Card -> Doc ann
pretty Card
c = Text -> Doc ann
forall ann. Text -> Doc ann
unsafeTextWithoutNewlines (Text -> Doc ann) -> Text -> Doc ann
forall a b. (a -> b) -> a -> b
$ Card -> Text
cardToShortTxt Card
c

instance IsString Card where
  fromString :: String -> Card
fromString = Maybe Card -> Card
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Card -> Card) -> (String -> Maybe Card) -> String -> Card
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Maybe Card
cardFromShortTxt (Text -> Maybe Card) -> (String -> Text) -> String -> Maybe Card
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack

-- | All cards in a 'Deck'
--
-- >>> length allCards
-- 52
allCards :: [Card]
allCards :: [Card]
allCards = (Rank -> Suit -> Card) -> [Rank] -> [Suit] -> [Card]
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 Rank -> Suit -> Card
Card [Rank]
allRanks [Suit]
allSuits

-- | >>> cardToShortTxt "Ac"
-- "Ac"
cardToShortTxt :: Card -> Text
cardToShortTxt :: Card -> Text
cardToShortTxt (Card Rank
r Suit
s) = String -> Text
T.pack [Rank -> Char
rankToChr Rank
r, Suit -> Char
suitToChr Suit
s]

-- | >>> cardFromShortTxt "Ac"
-- Just (Card {rank = Ace, suit = Club})
--
-- prop> \c -> cardFromShortTxt (cardToShortTxt c) == Just c
cardFromShortTxt :: Text -> Maybe Card
cardFromShortTxt :: Text -> Maybe Card
cardFromShortTxt Text
cs = case (Text -> Maybe (Char, Text))
-> (Char, Text) -> (Char, Maybe (Char, Text))
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second Text -> Maybe (Char, Text)
T.uncons ((Char, Text) -> (Char, Maybe (Char, Text)))
-> Maybe (Char, Text) -> Maybe (Char, Maybe (Char, Text))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Maybe (Char, Text)
T.uncons Text
cs of
  Just (Char
r, Just (Char
s, Text -> Bool
T.null -> Bool
True)) -> Rank -> Suit -> Card
Card (Rank -> Suit -> Card) -> Maybe Rank -> Maybe (Suit -> Card)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Char -> Maybe Rank
chrToRank Char
r Maybe (Suit -> Card) -> Maybe Suit -> Maybe Card
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Char -> Maybe Suit
chrToSuit Char
s
  Maybe (Char, Maybe (Char, Text))
_ -> Maybe Card
forall a. Maybe a
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 (Hole -> Hole -> Bool
(Hole -> Hole -> Bool) -> (Hole -> Hole -> Bool) -> Eq Hole
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Hole -> Hole -> Bool
$c/= :: Hole -> Hole -> Bool
== :: Hole -> Hole -> Bool
$c== :: Hole -> Hole -> Bool
Eq, Eq Hole
Eq Hole
-> (Hole -> Hole -> Ordering)
-> (Hole -> Hole -> Bool)
-> (Hole -> Hole -> Bool)
-> (Hole -> Hole -> Bool)
-> (Hole -> Hole -> Bool)
-> (Hole -> Hole -> Hole)
-> (Hole -> Hole -> Hole)
-> Ord Hole
Hole -> Hole -> Bool
Hole -> Hole -> Ordering
Hole -> Hole -> Hole
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Hole -> Hole -> Hole
$cmin :: Hole -> Hole -> Hole
max :: Hole -> Hole -> Hole
$cmax :: Hole -> Hole -> Hole
>= :: Hole -> Hole -> Bool
$c>= :: Hole -> Hole -> Bool
> :: Hole -> Hole -> Bool
$c> :: Hole -> Hole -> Bool
<= :: Hole -> Hole -> Bool
$c<= :: Hole -> Hole -> Bool
< :: Hole -> Hole -> Bool
$c< :: Hole -> Hole -> Bool
compare :: Hole -> Hole -> Ordering
$ccompare :: Hole -> Hole -> Ordering
$cp1Ord :: Eq Hole
Ord, Int -> Hole -> ShowS
[Hole] -> ShowS
Hole -> String
(Int -> Hole -> ShowS)
-> (Hole -> String) -> ([Hole] -> ShowS) -> Show Hole
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Hole] -> ShowS
$cshowList :: [Hole] -> ShowS
show :: Hole -> String
$cshow :: Hole -> String
showsPrec :: Int -> Hole -> ShowS
$cshowsPrec :: Int -> Hole -> ShowS
Show, ReadPrec [Hole]
ReadPrec Hole
Int -> ReadS Hole
ReadS [Hole]
(Int -> ReadS Hole)
-> ReadS [Hole] -> ReadPrec Hole -> ReadPrec [Hole] -> Read Hole
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Hole]
$creadListPrec :: ReadPrec [Hole]
readPrec :: ReadPrec Hole
$creadPrec :: ReadPrec Hole
readList :: ReadS [Hole]
$creadList :: ReadS [Hole]
readsPrec :: Int -> ReadS Hole
$creadsPrec :: Int -> ReadS Hole
Read, (forall x. Hole -> Rep Hole x)
-> (forall x. Rep Hole x -> Hole) -> Generic Hole
forall x. Rep Hole x -> Hole
forall x. Hole -> Rep Hole x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Hole x -> Hole
$cfrom :: forall x. Hole -> Rep Hole x
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 :: Card -> Card -> Hole
unsafeHole = Card -> Card -> Hole
UnsafeHole

-- | >>> "AcKd" :: Hole
-- UnsafeHole (Card {rank = Ace, suit = Club}) (Card {rank = King, suit = Diamond})
instance IsString Hole where
  fromString :: String -> Hole
fromString String
str =
    Hole -> Maybe Hole -> Hole
forall a. a -> Maybe a -> a
fromMaybe Hole
invalidHole (Maybe Hole -> Hole) -> (Text -> Maybe Hole) -> Text -> Hole
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Maybe Hole
holeFromShortTxt (Text -> Hole) -> Text -> Hole
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
str
    where
      invalidHole :: Hole
invalidHole = String -> Hole
forall a. HasCallStack => String -> a
error (String -> Hole) -> String -> Hole
forall a b. (a -> b) -> a -> b
$ String
"Invalid Hole: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
str

-- | >>> pretty <$> mkHole (Card Ace Heart) (Card King Spade)
-- Just AhKs
instance Pretty Hole where
  pretty :: Hole -> Doc ann
pretty (UnsafeHole Card
c1 Card
c2) = Card -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Card
c1 Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Card -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Card
c2

-- | The 'Arbitrary' instance for 'Hole' generates values whose 'Card' members
-- are already normalised.
instance Arbitrary Hole where
  arbitrary :: Gen Hole
arbitrary = [Hole] -> Gen Hole
forall a. [a] -> Gen a
elements [Hole]
allHoles

-- | >>> holeToShortTxt "AcKd"
-- "AcKd"
holeToShortTxt :: Hole -> Text
holeToShortTxt :: Hole -> Text
holeToShortTxt (UnsafeHole Card
c1 Card
c2) = Card -> Text
cardToShortTxt Card
c1 Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Card -> Text
cardToShortTxt Card
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 :: Text -> Maybe Hole
holeFromShortTxt (Int -> Text -> (Text, Text)
T.splitAt Int
2 -> (Text
c1, Int -> Text -> (Text, Text)
T.splitAt Int
2 -> (Text
c2, Text -> String
T.unpack -> []))) =
  Maybe (Maybe Hole) -> Maybe Hole
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Maybe (Maybe Hole) -> Maybe Hole)
-> Maybe (Maybe Hole) -> Maybe Hole
forall a b. (a -> b) -> a -> b
$ Card -> Card -> Maybe Hole
mkHole (Card -> Card -> Maybe Hole)
-> Maybe Card -> Maybe (Card -> Maybe Hole)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Maybe Card
cardFromShortTxt Text
c1 Maybe (Card -> Maybe Hole) -> Maybe Card -> Maybe (Maybe Hole)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Text -> Maybe Card
cardFromShortTxt Text
c2
holeFromShortTxt Text
_ = Maybe Hole
forall a. Maybe a
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 :: Card -> Card -> Maybe Hole
mkHole Card
c1 Card
c2 =
  if Card
c1 Card -> Card -> Bool
forall a. Eq a => a -> a -> Bool
/= Card
c2
    then Hole -> Maybe Hole
forall a. a -> Maybe a
Just (Hole -> Maybe Hole) -> Hole -> Maybe Hole
forall a b. (a -> b) -> a -> b
$ if Card
c1 Card -> Card -> Bool
forall a. Ord a => a -> a -> Bool
> Card
c2 then Card -> Card -> Hole
UnsafeHole Card
c1 Card
c2 else Card -> Card -> Hole
UnsafeHole Card
c2 Card
c1
    else Maybe Hole
forall a. Maybe a
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 :: [Hole]
allHoles = [Hole] -> [Hole]
forall a. [a] -> [a]
reverse ([Hole] -> [Hole]) -> [Hole] -> [Hole]
forall a b. (a -> b) -> a -> b
$ do
  Rank
r1 <- [Rank]
allRanks
  Rank
r2 <- Rank -> [Rank]
forall a. Enum a => a -> [a]
enumFrom Rank
r1
  (Suit
s1, Suit
s2) <-
    if Rank
r1 Rank -> Rank -> Bool
forall a. Eq a => a -> a -> Bool
== Rank
r2
      then [(Suit
s1, Suit
s2) | Suit
s1 <- [Suit]
allSuits, Suit
s2 <- Int -> [Suit] -> [Suit]
forall a. Int -> [a] -> [a]
drop Int
1 (Suit -> [Suit]
forall a. Enum a => a -> [a]
enumFrom Suit
s1)]
      else (Suit -> Suit -> (Suit, Suit))
-> [Suit] -> [Suit] -> [(Suit, Suit)]
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (,) [Suit]
allSuits [Suit]
allSuits
  Hole -> [Hole]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Hole -> [Hole]) -> Hole -> [Hole]
forall a b. (a -> b) -> a -> b
$ Card -> Card -> Hole
unsafeHole (Rank -> Suit -> Card
Card Rank
r2 Suit
s2) (Rank -> Suit -> Card
Card Rank
r1 Suit
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 (ShapedHole -> ShapedHole -> Bool
(ShapedHole -> ShapedHole -> Bool)
-> (ShapedHole -> ShapedHole -> Bool) -> Eq ShapedHole
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ShapedHole -> ShapedHole -> Bool
$c/= :: ShapedHole -> ShapedHole -> Bool
== :: ShapedHole -> ShapedHole -> Bool
$c== :: ShapedHole -> ShapedHole -> Bool
Eq, Eq ShapedHole
Eq ShapedHole
-> (ShapedHole -> ShapedHole -> Ordering)
-> (ShapedHole -> ShapedHole -> Bool)
-> (ShapedHole -> ShapedHole -> Bool)
-> (ShapedHole -> ShapedHole -> Bool)
-> (ShapedHole -> ShapedHole -> Bool)
-> (ShapedHole -> ShapedHole -> ShapedHole)
-> (ShapedHole -> ShapedHole -> ShapedHole)
-> Ord ShapedHole
ShapedHole -> ShapedHole -> Bool
ShapedHole -> ShapedHole -> Ordering
ShapedHole -> ShapedHole -> ShapedHole
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: ShapedHole -> ShapedHole -> ShapedHole
$cmin :: ShapedHole -> ShapedHole -> ShapedHole
max :: ShapedHole -> ShapedHole -> ShapedHole
$cmax :: ShapedHole -> ShapedHole -> ShapedHole
>= :: ShapedHole -> ShapedHole -> Bool
$c>= :: ShapedHole -> ShapedHole -> Bool
> :: ShapedHole -> ShapedHole -> Bool
$c> :: ShapedHole -> ShapedHole -> Bool
<= :: ShapedHole -> ShapedHole -> Bool
$c<= :: ShapedHole -> ShapedHole -> Bool
< :: ShapedHole -> ShapedHole -> Bool
$c< :: ShapedHole -> ShapedHole -> Bool
compare :: ShapedHole -> ShapedHole -> Ordering
$ccompare :: ShapedHole -> ShapedHole -> Ordering
$cp1Ord :: Eq ShapedHole
Ord, Int -> ShapedHole -> ShowS
[ShapedHole] -> ShowS
ShapedHole -> String
(Int -> ShapedHole -> ShowS)
-> (ShapedHole -> String)
-> ([ShapedHole] -> ShowS)
-> Show ShapedHole
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ShapedHole] -> ShowS
$cshowList :: [ShapedHole] -> ShowS
show :: ShapedHole -> String
$cshow :: ShapedHole -> String
showsPrec :: Int -> ShapedHole -> ShowS
$cshowsPrec :: Int -> ShapedHole -> ShowS
Show, ReadPrec [ShapedHole]
ReadPrec ShapedHole
Int -> ReadS ShapedHole
ReadS [ShapedHole]
(Int -> ReadS ShapedHole)
-> ReadS [ShapedHole]
-> ReadPrec ShapedHole
-> ReadPrec [ShapedHole]
-> Read ShapedHole
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [ShapedHole]
$creadListPrec :: ReadPrec [ShapedHole]
readPrec :: ReadPrec ShapedHole
$creadPrec :: ReadPrec ShapedHole
readList :: ReadS [ShapedHole]
$creadList :: ReadS [ShapedHole]
readsPrec :: Int -> ReadS ShapedHole
$creadsPrec :: Int -> ReadS ShapedHole
Read, (forall x. ShapedHole -> Rep ShapedHole x)
-> (forall x. Rep ShapedHole x -> ShapedHole) -> Generic ShapedHole
forall x. Rep ShapedHole x -> ShapedHole
forall x. ShapedHole -> Rep ShapedHole x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep ShapedHole x -> ShapedHole
$cfrom :: forall x. ShapedHole -> Rep ShapedHole x
Generic)

-- | First 'Rank' should '>' than second 'Rank'
unsafeOffsuit :: Rank -> Rank -> ShapedHole
unsafeOffsuit :: Rank -> Rank -> ShapedHole
unsafeOffsuit = Rank -> Rank -> ShapedHole
UnsafeOffsuit

-- | First 'Rank' should be '>' than second 'Rank'
unsafeSuited :: Rank -> Rank -> ShapedHole
unsafeSuited :: Rank -> Rank -> ShapedHole
unsafeSuited = Rank -> Rank -> ShapedHole
UnsafeSuited

-- | >>> "AKs" :: ShapedHole
-- UnsafeSuited Ace King
-- >>> "AKo" :: ShapedHole
-- UnsafeOffsuit Ace King
-- >>> "AAp" :: ShapedHole
-- Pair Ace
-- >>> "KAs" == ("AKs" :: ShapedHole)
-- True
instance IsString ShapedHole where
  fromString :: String -> ShapedHole
fromString String
str = case String
str of
    [Char
r1, Char
r2, Char
s] ->
      ShapedHole -> Maybe ShapedHole -> ShapedHole
forall a. a -> Maybe a -> a
fromMaybe ShapedHole
invalidShapedHole (Maybe ShapedHole -> ShapedHole) -> Maybe ShapedHole -> ShapedHole
forall a b. (a -> b) -> a -> b
$ do
        Rank
r1' <- Char -> Maybe Rank
chrToRank Char
r1
        Rank
r2' <- Char -> Maybe Rank
chrToRank Char
r2
        case Char
s of
          Char
'p' -> if Rank
r1' Rank -> Rank -> Bool
forall a. Eq a => a -> a -> Bool
== Rank
r2' then ShapedHole -> Maybe ShapedHole
forall a. a -> Maybe a
Just (ShapedHole -> Maybe ShapedHole) -> ShapedHole -> Maybe ShapedHole
forall a b. (a -> b) -> a -> b
$ Rank -> ShapedHole
mkPair Rank
r1' else Maybe ShapedHole
forall a. Maybe a
Nothing
          Char
'o' -> Rank -> Rank -> Maybe ShapedHole
mkOffsuit Rank
r1' Rank
r2'
          Char
's' -> Rank -> Rank -> Maybe ShapedHole
mkSuited Rank
r1' Rank
r2'
          Char
_ -> Maybe ShapedHole
forall a. Maybe a
Nothing
    String
_ -> ShapedHole
invalidShapedHole
    where
      invalidShapedHole :: ShapedHole
invalidShapedHole = String -> ShapedHole
forall a. HasCallStack => String -> a
error (String -> ShapedHole) -> String -> ShapedHole
forall a b. (a -> b) -> a -> b
$ String
"Invalid ShapedHole: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
str

-- | >>> pretty $ take 10 allShapedHoles
-- [AAp, AKs, AQs, AJs, ATs, A9s, A8s, A7s, A6s, A5s]
instance Pretty ShapedHole where
  pretty :: ShapedHole -> Doc ann
pretty = Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (Text -> Doc ann) -> (ShapedHole -> Text) -> ShapedHole -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShapedHole -> Text
shapedHoleToShortTxt

-- | The 'Arbitrary' instance for 'ShapedHole' generates values whose 'Rank' members
-- are already normalised.
instance Arbitrary ShapedHole where
  arbitrary :: Gen ShapedHole
arbitrary = [ShapedHole] -> Gen ShapedHole
forall a. [a] -> Gen a
elements [ShapedHole]
allShapedHoles

-- | >>> shapedHoleToShortTxt (mkPair Ace)
-- "AAp"
-- >>> shapedHoleToShortTxt <$> (mkOffsuit Ace King)
-- Just "AKo"
-- >>> shapedHoleToShortTxt <$> (mkSuited Ace King)
-- Just "AKs"
shapedHoleToShortTxt :: ShapedHole -> Text
shapedHoleToShortTxt :: ShapedHole -> Text
shapedHoleToShortTxt (UnsafeOffsuit Rank
r1 Rank
r2) = Rank -> Char
rankToChr Rank
r1 Char -> Text -> Text
`T.cons` Rank -> Char
rankToChr Rank
r2 Char -> Text -> Text
`T.cons` Text
"o"
shapedHoleToShortTxt (UnsafeSuited Rank
r1 Rank
r2) = Rank -> Char
rankToChr Rank
r1 Char -> Text -> Text
`T.cons` Rank -> Char
rankToChr Rank
r2 Char -> Text -> Text
`T.cons` Text
"s"
shapedHoleToShortTxt (Pair Rank
r) = Rank -> Char
rankToChr Rank
r Char -> Text -> Text
`T.cons` Rank -> Char
rankToChr Rank
r Char -> Text -> Text
`T.cons` Text
"p"

-- | Build a pair 'ShapedHole' from the given 'Rank'
mkPair :: Rank -> ShapedHole
mkPair :: Rank -> ShapedHole
mkPair = Rank -> ShapedHole
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 :: Rank -> Rank -> Maybe ShapedHole
mkSuited Rank
r1 Rank
r2 =
  if Rank
r1 Rank -> Rank -> Bool
forall a. Eq a => a -> a -> Bool
/= Rank
r2
    then ShapedHole -> Maybe ShapedHole
forall a. a -> Maybe a
Just (ShapedHole -> Maybe ShapedHole) -> ShapedHole -> Maybe ShapedHole
forall a b. (a -> b) -> a -> b
$ if Rank
r1 Rank -> Rank -> Bool
forall a. Ord a => a -> a -> Bool
> Rank
r2 then Rank -> Rank -> ShapedHole
UnsafeSuited Rank
r1 Rank
r2 else Rank -> Rank -> ShapedHole
UnsafeSuited Rank
r2 Rank
r1
    else Maybe ShapedHole
forall a. Maybe a
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 :: Rank -> Rank -> Maybe ShapedHole
mkOffsuit Rank
r1 Rank
r2 =
  if Rank
r1 Rank -> Rank -> Bool
forall a. Eq a => a -> a -> Bool
/= Rank
r2
    then ShapedHole -> Maybe ShapedHole
forall a. a -> Maybe a
Just (ShapedHole -> Maybe ShapedHole) -> ShapedHole -> Maybe ShapedHole
forall a b. (a -> b) -> a -> b
$ if Rank
r1 Rank -> Rank -> Bool
forall a. Ord a => a -> a -> Bool
> Rank
r2 then Rank -> Rank -> ShapedHole
UnsafeOffsuit Rank
r1 Rank
r2 else Rank -> Rank -> ShapedHole
UnsafeOffsuit Rank
r2 Rank
r1
    else Maybe ShapedHole
forall a. Maybe a
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 :: [ShapedHole]
allShapedHoles = [ShapedHole] -> [ShapedHole]
forall a. [a] -> [a]
reverse ([ShapedHole] -> [ShapedHole]) -> [ShapedHole] -> [ShapedHole]
forall a b. (a -> b) -> a -> b
$ do
  Rank
rank1 <- [Rank]
allRanks
  Rank
rank2 <- [Rank]
allRanks
  ShapedHole -> [ShapedHole]
forall (m :: * -> *) a. Monad m => a -> m a
return (ShapedHole -> [ShapedHole]) -> ShapedHole -> [ShapedHole]
forall a b. (a -> b) -> a -> b
$ case Rank -> Rank -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Rank
rank1 Rank
rank2 of
    Ordering
GT -> Rank -> Rank -> ShapedHole
unsafeSuited Rank
rank1 Rank
rank2
    Ordering
EQ -> Rank -> ShapedHole
mkPair Rank
rank1
    Ordering
LT -> Rank -> Rank -> ShapedHole
unsafeOffsuit Rank
rank2 Rank
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 :: ShapedHole -> [Hole]
shapedHoleToHoles = \case
  Pair Rank
r -> do
    Suit
s1 <- [Suit]
allSuits
    Suit
s2 <- Int -> [Suit] -> [Suit]
forall a. Int -> [a] -> [a]
drop (Suit -> Int
forall a. Enum a => a -> Int
fromEnum Suit
s1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) [Suit]
allSuits
    Hole -> [Hole]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Hole -> [Hole]) -> (Maybe Hole -> Hole) -> Maybe Hole -> [Hole]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Hole -> Hole
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Hole -> [Hole]) -> Maybe Hole -> [Hole]
forall a b. (a -> b) -> a -> b
$ Card -> Card -> Maybe Hole
mkHole (Rank -> Suit -> Card
Card Rank
r Suit
s1) (Rank -> Suit -> Card
Card Rank
r Suit
s2)
  UnsafeOffsuit Rank
r1 Rank
r2 -> do
    Suit
s1 <- [Suit]
allSuits
    Suit
s2 <- (Suit -> Bool) -> [Suit] -> [Suit]
forall a. (a -> Bool) -> [a] -> [a]
filter (Suit
s1 Suit -> Suit -> Bool
forall a. Eq a => a -> a -> Bool
/=) [Suit]
allSuits
    Hole -> [Hole]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Hole -> [Hole]) -> (Maybe Hole -> Hole) -> Maybe Hole -> [Hole]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Hole -> Hole
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Hole -> [Hole]) -> Maybe Hole -> [Hole]
forall a b. (a -> b) -> a -> b
$ Card -> Card -> Maybe Hole
mkHole (Rank -> Suit -> Card
Card Rank
r1 Suit
s1) (Rank -> Suit -> Card
Card Rank
r2 Suit
s2)
  UnsafeSuited Rank
r1 Rank
r2 -> do
    Suit
s <- [Suit]
allSuits
    Hole -> [Hole]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Hole -> [Hole]) -> (Maybe Hole -> Hole) -> Maybe Hole -> [Hole]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Hole -> Hole
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Hole -> [Hole]) -> Maybe Hole -> [Hole]
forall a b. (a -> b) -> a -> b
$ Card -> Card -> Maybe Hole
mkHole (Rank -> Suit -> Card
Card Rank
r1 Suit
s) (Rank -> Suit -> Card
Card Rank
r2 Suit
s)

-- | >>> holeToShapedHole "AcKd"
-- UnsafeOffsuit Ace King
-- >>> holeToShapedHole "AcKc"
-- UnsafeSuited Ace King
-- >>> holeToShapedHole "AcAs"
-- Pair Ace
holeToShapedHole :: Hole -> ShapedHole
holeToShapedHole :: Hole -> ShapedHole
holeToShapedHole (UnsafeHole (Card Rank
r1 Suit
s1) (Card Rank
r2 Suit
s2))
  | Rank
r1 Rank -> Rank -> Bool
forall a. Eq a => a -> a -> Bool
== Rank
r2 = Rank -> ShapedHole
mkPair Rank
r1
  | Suit
s1 Suit -> Suit -> Bool
forall a. Eq a => a -> a -> Bool
== Suit
s2 = Rank -> Rank -> ShapedHole
unsafeSuited Rank
r1 Rank
r2
  | Bool
otherwise = Rank -> Rank -> ShapedHole
unsafeOffsuit Rank
r1 Rank
r2

-- | A 'Deck' of 'Card's
newtype Deck = UnsafeDeck [Card] deriving (ReadPrec [Deck]
ReadPrec Deck
Int -> ReadS Deck
ReadS [Deck]
(Int -> ReadS Deck)
-> ReadS [Deck] -> ReadPrec Deck -> ReadPrec [Deck] -> Read Deck
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Deck]
$creadListPrec :: ReadPrec [Deck]
readPrec :: ReadPrec Deck
$creadPrec :: ReadPrec Deck
readList :: ReadS [Deck]
$creadList :: ReadS [Deck]
readsPrec :: Int -> ReadS Deck
$creadsPrec :: Int -> ReadS Deck
Read, Int -> Deck -> ShowS
[Deck] -> ShowS
Deck -> String
(Int -> Deck -> ShowS)
-> (Deck -> String) -> ([Deck] -> ShowS) -> Show Deck
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Deck] -> ShowS
$cshowList :: [Deck] -> ShowS
show :: Deck -> String
$cshow :: Deck -> String
showsPrec :: Int -> Deck -> ShowS
$cshowsPrec :: Int -> Deck -> ShowS
Show, Deck -> Deck -> Bool
(Deck -> Deck -> Bool) -> (Deck -> Deck -> Bool) -> Eq Deck
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Deck -> Deck -> Bool
$c/= :: Deck -> Deck -> Bool
== :: Deck -> Deck -> Bool
$c== :: Deck -> Deck -> Bool
Eq)

-- | A unshuffled 'Deck' with all 'Card's
--
-- >>> freshDeck == unsafeDeck allCards
-- True
freshDeck :: Deck
freshDeck :: Deck
freshDeck = [Card] -> Deck
UnsafeDeck [Card]
allCards

-- | The input 'Card's are not checked in any way.
unsafeDeck :: [Card] -> Deck
unsafeDeck :: [Card] -> Deck
unsafeDeck = [Card] -> Deck
UnsafeDeck