module Data.Poker.Deck
(
HandValue(..),
NumericalHandValue(..),
ConsecutiveHandValue(..),
isNoPair,
isOnePair,
isTwoPair,
isThreeOfAKind,
isStraight,
isFlush,
isFullHouse,
isFourOfAKind,
isStraightFlush,
Card(..),
Rank(..),
Suit(..),
Kicker,
mkCard,
cardRank,
cardSuit,
rankIdentifiers,
suitIdentifiers,
CardSet(..),
toList,
fromList,
singleton,
size,
countRank,
countSuit,
member,
empty,
isEmpty,
union,
intersection,
inverse
) where
import Data.Poker.Definitions
import System.Random
import Foreign.C
import qualified Data.Vector.Unboxed as VU
import qualified Data.Vector as V
import Data.List ( foldl' )
import Data.Int
import Data.Word
import Data.Bits
import Data.Ix
import Data.Char
data Rank = Two | Three | Four | Five | Six | Seven | Eight | Nine | Ten
| Jack | Queen | King | Ace deriving (Show,Eq,Ord,Enum,Bounded)
data Suit = Hearts | Diamonds | Clubs | Spades deriving (Show,Eq,Ord,Enum,Bounded)
type Kicker = Rank
data HandValue =
NoPair Kicker Kicker Kicker Kicker Kicker |
OnePair Rank Kicker Kicker Kicker |
TwoPair Rank Rank Kicker |
ThreeOfAKind Rank Kicker Kicker |
Straight Rank |
Flush Kicker Kicker Kicker Kicker Kicker |
FullHouse Rank Rank |
FourOfAKind Rank Kicker |
StraightFlush Rank
deriving (Show,Eq,Ord)
newtype Card = Card CInt deriving (Eq,Ord)
newtype CardSet = CardSet { unmask :: StdDeck_CardMask } deriving (Eq,Ord,Bounded)
newtype NumericalHandValue = NumericalHandValue { unNumericalHandValue :: Word }
deriving (Eq, Ord)
newtype ConsecutiveHandValue = ConsecutiveHandValue { unConsecutiveHandValue :: Int }
deriving (Eq, Ord)
instance Bounded ConsecutiveHandValue where
minBound = ConsecutiveHandValue 0
maxBound = ConsecutiveHandValue 7461
instance Ix ConsecutiveHandValue where
range (ConsecutiveHandValue a, ConsecutiveHandValue b) = map ConsecutiveHandValue (range (a,b))
index (ConsecutiveHandValue a, ConsecutiveHandValue b) (ConsecutiveHandValue n) = index (a, b) n
inRange (ConsecutiveHandValue a, ConsecutiveHandValue b) (ConsecutiveHandValue n) = inRange (a, b) n
rangeSize (ConsecutiveHandValue a, ConsecutiveHandValue b) = rangeSize (a,b)
isNoPair :: HandValue -> Bool
isNoPair NoPair{} = True
isNoPair _ = False
isOnePair :: HandValue -> Bool
isOnePair OnePair{} = True
isOnePair _ = False
isTwoPair :: HandValue -> Bool
isTwoPair TwoPair{} = True
isTwoPair _ = False
isThreeOfAKind :: HandValue -> Bool
isThreeOfAKind ThreeOfAKind{} = True
isThreeOfAKind _ = False
isStraight :: HandValue -> Bool
isStraight Straight{} = True
isStraight _ = False
isFlush :: HandValue -> Bool
isFlush Flush{} = True
isFlush _ = False
isFullHouse :: HandValue -> Bool
isFullHouse FullHouse{} = True
isFullHouse _ = False
isFourOfAKind :: HandValue -> Bool
isFourOfAKind FourOfAKind{} = True
isFourOfAKind _ = False
isStraightFlush :: HandValue -> Bool
isStraightFlush StraightFlush{} = True
isStraightFlush _ = False
instance Bounded HandValue where
minBound = NoPair Seven Five Four Three Two
maxBound = StraightFlush Ace
instance Show Card where
show = cardToString
instance Read Card where
readsPrec i (c:cs) | isSpace c = readsPrec i cs
readsPrec _ (r:s:rest) =
case stringToCard_ [r,s] of
Nothing -> []
Just card -> [(card,rest)]
readsPrec _ _ = []
instance Bounded Card where
minBound = Card 0
maxBound = Card 51
instance Enum Card where
succ card | card >= maxBound = error "Data.Poker.Deck.Card.succ: bad argument"
succ (Card i) = Card (succ i)
pred card | card <= minBound = error "Data.Poker.Deck.Card.pred: bad argument"
pred (Card i) = Card (pred i)
toEnum i | i < 0 || i > 51 = error "Data.Poker.Deck.Card.toEnum: bad argument"
toEnum i = Card (fromIntegral i)
fromEnum (Card i) = fromIntegral i
enumFrom val = enumFromTo val maxBound
enumFromThen val step = enumFromThenTo val step maxBound
instance Random Card where
randomR (Card low,Card high) g
= let (n, g') = randomR (fromIntegral low,fromIntegral high) g
in (Card (fromIntegral (n :: Int)), g')
random g = let (n, g') = randomR (0,51 :: Int) g
in (Card (fromIntegral n), g')
instance Show CardSet where
show = show . toList
instance Read CardSet where
readsPrec i inp = do
(lst,rest) <- readsPrec i inp
return (fromList lst, rest)
instance Random CardSet where
randomR (CardSet low, CardSet high) g =
let (n, g') = randomR (fromIntegral low, fromIntegral high) g
in (CardSet (fromIntegral (n::Int) .&. 2305596714850918399), g')
random g =
let (n, g') = randomR (0, maxBound) g
in (CardSet (n .&. 2305596714850918399), g')
instance Random ConsecutiveHandValue where
randomR (ConsecutiveHandValue low, ConsecutiveHandValue high) g =
let (n, g') = randomR (low, high) g
in (ConsecutiveHandValue n, g')
random = randomR (minBound, maxBound)
instance Random Rank where
randomR (low, high) g =
let (n, g') = randomR (fromEnum low, fromEnum high) g
in (toEnum n, g')
random = randomR (minBound, maxBound)
instance Random Suit where
randomR (low, high) g =
let (n, g') = randomR (fromEnum low, fromEnum high) g
in (toEnum n, g')
random = randomR (minBound, maxBound)
mkCard :: Rank -> Suit -> Card
mkCard rank suit =
Card $ fromIntegral $ fromEnum rank + fromEnum suit * 13
cardRank :: Card -> Rank
cardRank (Card idx) = toEnum (fromIntegral idx `mod` 13)
cardSuit :: Card -> Suit
cardSuit (Card idx) = toEnum (fromIntegral idx `div` 13)
stringToCard_ :: String -> Maybe Card
stringToCard_ [rankChar,suitChar] = do
rank <- lookup (toUpper rankChar) (map swap rankIdentifiers)
suit <- lookup suitChar (map swap suitIdentifiers)
return $ mkCard rank suit
where
swap (a,b) = (b,a)
stringToCard_ _ = Nothing
cardToString :: Card -> String
cardToString card =
[ rank, suit ]
where
Just rank = lookup (cardRank card) rankIdentifiers
Just suit = lookup (cardSuit card) suitIdentifiers
rankIdentifiers :: [(Rank, Char)]
rankIdentifiers =
[ (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') ]
suitIdentifiers :: [(Suit, Char)]
suitIdentifiers =
[ (Hearts, 'h')
, (Diamonds, 'd')
, (Clubs, 'c')
, (Spades, 's')]
foreign import ccall unsafe "hs_StdDeck_MASK" c_getMASK :: CInt -> StdDeck_CardMask
singleton :: Card -> CardSet
singleton (Card idx) =
CardSet (fromIntegral (VU.unsafeIndex cardSetVector (fromIntegral idx)))
cardSetVector :: VU.Vector Int64
cardSetVector =
VU.fromList (map (fromIntegral . c_getMASK) [0 .. 51])
foreign import ccall unsafe "hs_StdDeck_numCards" c_numCards :: StdDeck_CardMask -> CInt
size :: CardSet -> Int
size (CardSet m) = fromIntegral (c_numCards m)
maskOP :: (StdDeck_CardMask -> StdDeck_CardMask -> StdDeck_CardMask) -> CardSet -> CardSet -> CardSet
maskOP op (CardSet m1) (CardSet m2) = CardSet (op m1 m2)
maskUnOP :: (StdDeck_CardMask -> StdDeck_CardMask) -> CardSet -> CardSet
maskUnOP unop (CardSet m) = CardSet (unop m)
union :: CardSet -> CardSet -> CardSet
union = maskOP (.|.)
intersection :: CardSet -> CardSet -> CardSet
intersection = maskOP (.&.)
inverse :: CardSet -> CardSet
inverse = maskUnOP complement
empty :: CardSet
empty = CardSet 0
fromList :: [Card] -> CardSet
fromList = foldl' union empty . map singleton
toList :: CardSet -> [Card]
toList mask = filter (member mask) allCards
allCards :: [Card]
allCards = [ mkCard rank suit | rank <- [Ace, King .. Two], suit <- [minBound .. maxBound]]
countRank :: CardSet -> Rank -> Int
countRank mask rank =
size (mask `intersection` rankMask)
where
rankMask = rankMaskVector V.! fromEnum rank
rankMaskVector :: V.Vector CardSet
rankMaskVector = V.fromList [ fromList (map (mkCard eachRank) [minBound .. ]) | eachRank <- [minBound .. ] ]
countSuit :: CardSet -> Suit -> Int
countSuit mask suit =
size (mask `intersection` suitMask)
where
suitMask = suitMaskVector V.! fromEnum suit
suitMaskVector :: V.Vector CardSet
suitMaskVector = V.fromList [ fromList (map (flip mkCard eachSuit) [minBound .. ]) | eachSuit <- [minBound .. ] ]
member :: CardSet -> Card -> Bool
member mask card
= not (isEmpty (mask `intersection` singleton card))
isEmpty :: CardSet -> Bool
isEmpty (CardSet 0) = True
isEmpty _ = False