-- |
-- Module      : Poker.Deck
-- Description : A deck of cards and its operations.
-- Copyright   : (c) Ghais Issa, 2021
module Poker.Deck
  (
    Suit(..)
  , Rank(..)
  , Card(..)
  , newCard
  , randomCard
  , Deck(..)
  , stdDeck
  , shuffleT
  , shuffle
  , draw
  , draw_
  , draw1
  , draw1_
  , remove
  ) where

import           Data.Bits (shift, (.&.))
import           Data.List (foldl1', (\\))
import           Data.Random (RVar)
import           Data.Random.Distribution.Uniform (uniform)
import           Data.Random.List (shuffleN, shuffleNT)
import           Data.Random.RVar (RVarT)
import           Text.Read (Lexeme (Ident), Read (readPrec), lexP)

data Suit
  = Club
  | Diamond
  | Heart
  | Spade
  deriving stock (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, 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, 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, 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, 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)

data Rank
  = Two
  | Three
  | Four
  | Five
  | Six
  | Seven
  | Eight
  | Nine
  | Ten
  | Jack
  | Queen
  | King
  | Ace
  deriving stock (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, 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, 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, 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, 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)

-- | A card is represented as an int where the lower 4 bits representing the
-- and the rest represents the rank ranging from 0-12.
--
-- Use 'newCard' to construct a new card.
newtype Card = Card Int deriving stock (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)

-- | Construct a new card.
newCard :: Rank -> Suit -> Card
newCard :: Rank -> Suit -> Card
newCard Rank
rank Suit
suite = Int -> Card
Card (Int -> Card) -> Int -> Card
forall a b. (a -> b) -> a -> b
$ Rank -> Int
forall a. Enum a => a -> Int
fromEnum Rank
rank Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
4 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Suit -> Int
forall a. Enum a => a -> Int
fromEnum Suit
suite


randomCard :: RVar Card
randomCard :: RVar Card
randomCard = do
  Int
suit   <- Int -> Int -> RVar Int
forall a. Distribution Uniform a => a -> a -> RVar a
uniform Int
0 Int
3
  Int
rank   <- Int -> Int -> RVar Int
forall a. Distribution Uniform a => a -> a -> RVar a
uniform Int
0 Int
12
  Card -> RVar Card
forall (m :: * -> *) a. Monad m => a -> m a
return (Card -> RVar Card) -> Card -> RVar Card
forall a b. (a -> b) -> a -> b
$ Rank -> Suit -> Card
newCard (Int -> Rank
forall a. Enum a => Int -> a
toEnum Int
rank) (Int -> Suit
forall a. Enum a => Int -> a
toEnum Int
suit)


data Deck = Deck !Int ![Card]

-- | construct a full 52-card playing deck. The resulting deck is not shuffled.
stdDeck :: Deck
stdDeck :: Deck
stdDeck =
  let suits :: [Suit]
suits = Suit -> [Suit]
forall a. Enum a => a -> [a]
enumFrom Suit
Club
      ranks :: [Rank]
ranks = Rank -> [Rank]
forall a. Enum a => a -> [a]
enumFrom Rank
Two
   in Int -> [Card] -> Deck
Deck Int
52 [Rank -> Suit -> Card
newCard Rank
rank Suit
suit | Suit
suit <- [Suit]
suits, Rank
rank <- [Rank]
ranks]

-- | Shuffle a deck.
shuffleT :: Deck -> RVarT m Deck
shuffleT :: Deck -> RVarT m Deck
shuffleT (Deck Int
n [Card]
cards) = do
  [Card]
shuffledCards <- Int -> [Card] -> RVarT m [Card]
forall a (m :: * -> *). Int -> [a] -> RVarT m [a]
shuffleNT Int
n [Card]
cards
  Deck -> RVarT m Deck
forall (m :: * -> *) a. Monad m => a -> m a
return (Deck -> RVarT m Deck) -> Deck -> RVarT m Deck
forall a b. (a -> b) -> a -> b
$ Int -> [Card] -> Deck
Deck Int
n [Card]
shuffledCards

-- | Shuffle a deck.
shuffle :: Deck -> RVar Deck
shuffle :: Deck -> RVar Deck
shuffle (Deck Int
n [Card]
cards) = do
  [Card]
shuffledCards <- Int -> [Card] -> RVar [Card]
forall a. Int -> [a] -> RVar [a]
shuffleN Int
n [Card]
cards
  Deck -> RVar Deck
forall (m :: * -> *) a. Monad m => a -> m a
return (Deck -> RVar Deck) -> Deck -> RVar Deck
forall a b. (a -> b) -> a -> b
$ Int -> [Card] -> Deck
Deck Int
n [Card]
shuffledCards

-- | Remove a set of cards from a deck, returning the new deck.
remove :: [Card] -> Deck -> Deck
remove :: [Card] -> Deck -> Deck
remove [Card]
cards (Deck Int
n [Card]
deck) = Int -> [Card] -> Deck
Deck (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- [Card] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Card]
cards) ([Card]
deck [Card] -> [Card] -> [Card]
forall a. Eq a => [a] -> [a] -> [a]
\\ [Card]
cards)

-- | Draw a list of cards from the deck and group them based on the list of hands provided.
--
-- Returns the grouped cards and the remaining deck.
--
-- Arguments that are negative or exceed the length of the deck return Nothing.
--
-- For instance, to simulate a two player Hold'em game, one might wish
-- to draw two cards for each player, and five cards for the community:
--
-- >>> deck <- runRVar (shuffle stdDeck) DevRandom
-- >>> fst . fromJust $ draw [2,2,5] deck
-- [[Ace Club,Queen Club],[Four Diamond,Nine Club],[Jack Heart,King Diamond,Three Heart,Four Club,Two Diamond]]
draw ::
  -- | a list of hand sizes.
  [Int] ->
  -- | The deck.
  Deck ->
  -- | Nothing if the requested number of cards exceeds the deck size, or any of the hands is negative
  -- otherwise returns the hands and the remainder of the deck.
  Maybe ([[Card]], Deck)
draw :: [Int] -> Deck -> Maybe ([[Card]], Deck)
draw [Int]
handSizeLst (Deck Int
n [Card]
deck)
  | let anyNeg :: Bool
anyNeg = (Int -> Bool) -> [Int] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0) [Int]
handSizeLst
     in Int
total Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
n Bool -> Bool -> Bool
|| Int
total Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 Bool -> Bool -> Bool
|| Bool
anyNeg =
    Maybe ([[Card]], Deck)
forall a. Maybe a
Nothing
  | Bool
otherwise =
    let draw2 :: [Int] -> ([[a]], [a]) -> ([[a]], [a])
draw2 [] ([[a]]
houtput, [a]
doutput) = ([[a]] -> [[a]]
forall a. [a] -> [a]
reverse [[a]]
houtput, [a]
doutput)
        draw2 (Int
nToTake : [Int]
hst) ([[a]]
handOutput, [a]
deckOutput) =
          let newHand :: [a]
newHand = Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
take Int
nToTake [a]
deckOutput
              newDeck :: [a]
newDeck = Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
drop Int
nToTake [a]
deckOutput
           in [Int] -> ([[a]], [a]) -> ([[a]], [a])
draw2 [Int]
hst ([a]
newHand [a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
: [[a]]
handOutput, [a]
newDeck)
        ([[Card]]
hands, [Card]
remainder) = [Int] -> ([[Card]], [Card]) -> ([[Card]], [Card])
forall a. [Int] -> ([[a]], [a]) -> ([[a]], [a])
draw2 [Int]
handSizeLst ([], [Card]
deck)
     in ([[Card]], Deck) -> Maybe ([[Card]], Deck)
forall a. a -> Maybe a
Just ([[Card]]
hands, Int -> [Card] -> Deck
Deck (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
total) [Card]
remainder)
  where
    total :: Int
total = (Int -> Int -> Int) -> [Int] -> Int
forall a. (a -> a -> a) -> [a] -> a
foldl1' Int -> Int -> Int
forall a. Num a => a -> a -> a
(+) [Int]
handSizeLst


-- | Just like 'draw' but throws away the deck.
draw_ :: [Int] -> Deck -> Maybe [[Card]]
draw_ :: [Int] -> Deck -> Maybe [[Card]]
draw_ [Int]
handSizes (Deck Int
n [Card]
deck) =
  let f :: Maybe (a, b) -> Maybe a
f (Just (a
h, b
_)) = a -> Maybe a
forall a. a -> Maybe a
Just a
h
      f Maybe (a, b)
_             = Maybe a
forall a. Maybe a
Nothing
   in Maybe ([[Card]], Deck) -> Maybe [[Card]]
forall a b. Maybe (a, b) -> Maybe a
f (Maybe ([[Card]], Deck) -> Maybe [[Card]])
-> Maybe ([[Card]], Deck) -> Maybe [[Card]]
forall a b. (a -> b) -> a -> b
$ [Int] -> Deck -> Maybe ([[Card]], Deck)
draw [Int]
handSizes (Int -> [Card] -> Deck
Deck Int
n [Card]
deck)

-- | The same as 'draw', except draw only one hand of specified size.
draw1 :: Int -> Deck -> Maybe ([Card], Deck)
draw1 :: Int -> Deck -> Maybe ([Card], Deck)
draw1 Int
handSize (Deck Int
n [Card]
deck) =
  let f :: Maybe ([a], b) -> Maybe (a, b)
f (Just ([a
h], b
d)) = (a, b) -> Maybe (a, b)
forall a. a -> Maybe a
Just (a
h, b
d)
      f Maybe ([a], b)
_               = Maybe (a, b)
forall a. Maybe a
Nothing
   in Maybe ([[Card]], Deck) -> Maybe ([Card], Deck)
forall a b. Maybe ([a], b) -> Maybe (a, b)
f (Maybe ([[Card]], Deck) -> Maybe ([Card], Deck))
-> Maybe ([[Card]], Deck) -> Maybe ([Card], Deck)
forall a b. (a -> b) -> a -> b
$ [Int] -> Deck -> Maybe ([[Card]], Deck)
draw [Int
handSize] (Int -> [Card] -> Deck
Deck Int
n [Card]
deck)

-- | Same as 'draw1' but throws away the deck.
draw1_ :: Int -> Deck -> Maybe [Card]
draw1_ :: Int -> Deck -> Maybe [Card]
draw1_ Int
handSize (Deck Int
n [Card]
deck) =
  let f :: Maybe ([a], b) -> Maybe a
f (Just ([a
h], b
_)) = a -> Maybe a
forall a. a -> Maybe a
Just a
h
      f Maybe ([a], b)
_               = Maybe a
forall a. Maybe a
Nothing
   in Maybe ([[Card]], Deck) -> Maybe [Card]
forall a b. Maybe ([a], b) -> Maybe a
f (Maybe ([[Card]], Deck) -> Maybe [Card])
-> Maybe ([[Card]], Deck) -> Maybe [Card]
forall a b. (a -> b) -> a -> b
$ [Int] -> Deck -> Maybe ([[Card]], Deck)
draw [Int
handSize] (Int -> [Card] -> Deck
Deck Int
n [Card]
deck)

-- A card is represented as an Int. So we implement Show and Read explicitly.
instance Show Card where
  show :: Card -> String
show (Card Int
c) = Rank -> String
forall a. Show a => a -> String
show Rank
rank String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Suit -> String
forall a. Show a => a -> String
show Suit
suit
    where
      suit :: Suit
      suit :: Suit
suit = Int -> Suit
forall a. Enum a => Int -> a
toEnum (Int
c Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int
0x3)
      rank :: Rank
      rank :: Rank
rank = Int -> Rank
forall a. Enum a => Int -> a
toEnum (Int -> Rank) -> Int -> Rank
forall a b. (a -> b) -> a -> b
$ (Int
c Int -> Int -> Int
forall a. Num a => a -> a -> a
- Suit -> Int
forall a. Enum a => a -> Int
fromEnum Suit
suit) Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shift` (-Int
2)

instance Read Card where
  readPrec :: ReadPrec Card
readPrec = do
    (Ident String
rank) <- ReadPrec Lexeme
lexP
    (Ident String
suit) <- ReadPrec Lexeme
lexP
    Card -> ReadPrec Card
forall (m :: * -> *) a. Monad m => a -> m a
return (Card -> ReadPrec Card) -> Card -> ReadPrec Card
forall a b. (a -> b) -> a -> b
$ Rank -> Suit -> Card
newCard (String -> Rank
forall a. Read a => String -> a
read String
rank) (String -> Suit
forall a. Read a => String -> a
read String
suit)