Hands.hs

module Game.Poker.Hands
    ( Hand
    , toHand, fromHand
    , pokerHand
    , PokerHand
    
    -- hint
    , straightHint
    , flushHint
    , nOfKindHint

    -- hand
    , straightFlush
    , fourOfAKind
    , fullHouse
    , flush
    , straight
    , threeOfAKind
    , twoPair
    , onePair
    ) where


import Data.List
import Data.Function
import Data.Maybe
import Control.Applicative
import Control.Monad
import Game.Poker.Cards

-- | Constrained cards in hand
--
-- >>> :type fromHand
-- fromHand :: Hand -> [Card]
--
newtype Hand = Hand { fromHand :: [Card] }
    deriving (Show, Eq, Ord)

-- | Cards to Hard
--
-- >>> toHand allCards
-- Nothing
--
-- >>> fmap (length . fromHand) (toHand $ take 5 allCards)
-- Just 5
--
toHand :: [Card] -> Maybe Hand
toHand xs = 
    if length xs == 5
    then Just $ Hand (sort xs)
    else Nothing


-- 
data PokerHand
    = HighCards         -- Buta
    | OnePair           --  ^
    | TwoPair           --  |
    | ThreeOfAKind
    | Straight
    | Flush
    | FullHouse         --  |
    | FourOfAKind       --  V
    | StraightFlush     -- Sugoi
    deriving (Show, Read, Eq, Ord, Enum)


-- | Detect poker hand and return strength Card
-- 
-- >>> let sameNum = filter ((==14) . cardNumber) allCards
-- >>> let sameSuit = filter ((==Hearts) . cardSuit) allCards
--
-- >>> pokerHand (Hand $ take 5 sameSuit)
-- (StraightFlush,H6_)
--
-- >>> let buta = take 2 allCards ++ (take 2 $ drop 17 allCards) ++ [last allCards]
-- >>> pokerHand (Hand buta)
-- (HighCards,SA_)
--
pokerHand :: Hand -> (PokerHand, Card)
pokerHand h@(Hand xs) = 
    fromMaybe (HighCards, last xs)
        (foldl mplus Nothing $ fmap ($h) hands)
    
    where
        hands :: [Hand -> Maybe (PokerHand, Card)]
        hands = 
            [ straightFlush
            , fourOfAKind
            , fullHouse
            , flush
            , straight
            , threeOfAKind
            , twoPair
            , onePair
            ]


-- Implement every Hand!!!!

-- | Detect onePair and return strongest Card
--
-- >>> let sameNum = filter ((==9) . cardNumber) allCards
-- >>> let sameSuit = filter ((==Spades) . cardSuit) allCards
-- >>> onePair $ Hand (take 2 sameNum ++ take 3 sameSuit)
-- Just (OnePair,D9_)
-- 
-- >>> onePair $ Hand (take 5 sameSuit)
-- Nothing
onePair :: Hand -> Maybe (PokerHand, Card)
onePair  x = do
    cs <- nOfKindHint 2 x
    return (OnePair, last . concat $ cs)

    -- same as
    -- fmap (((,) OnePair) . last . join) . nOfKindHint 2

-- | Detect TwoPair and return strongest Card
--
-- >>> let sameNum = filter ((==9) . cardNumber) allCards
-- >>> let sameNum' = filter ((==10) . cardNumber) allCards
-- >>> let sameSuit = filter ((==Spades) . cardSuit) allCards
-- >>> twoPair $ Hand (take 2 sameNum ++ take 2 sameNum' ++ take 1 sameSuit)
-- Just (TwoPair,D10)
--
-- >>> twoPair $ Hand (take 2 sameNum ++ take 3 sameSuit)
-- Nothing
-- 
-- >>> twoPair $ Hand (take 5 sameSuit)
-- Nothing
twoPair :: Hand -> Maybe (PokerHand, Card)
twoPair x = do
    cs <- nOfKindHint 2 x
    guard (length cs == 2)
    return (TwoPair, last . concat $ cs)

-- | Detect ThreeOfAKind and return strongest Card
--
-- >>> let sameNum = filter ((==4) . cardNumber) allCards
-- >>> let sameSuit = filter ((==Spades) . cardSuit) allCards
-- >>> threeOfAKind $ Hand (take 3 sameNum ++ take 2 sameSuit)
-- Just (ThreeOfAKind,C4_)
-- 
-- >>> threeOfAKind $ Hand (take 5 sameSuit)
-- Nothing
threeOfAKind :: Hand -> Maybe (PokerHand, Card)
threeOfAKind  x = do
    cs <- nOfKindHint 3 x
    return (ThreeOfAKind, maximum . concat $ cs)


-- | Detect Straight and return strongest Card
--
-- >>> straight $ Hand (take 5 $ filter ((==Hearts) . cardSuit) allCards)
-- Just (Straight,H6_)
--
-- >>> straight $ Hand (take 5 $ filter (even . cardNumber) allCards)
-- Nothing
straight :: Hand -> Maybe (PokerHand, Card)
straight x = do
    c <- straightHint x
    return (Straight, c)
    
    -- Same as followings
    -- straightHint x >>= (\y -> return (Straight, y))
    -- fmap (\y -> (Straight, y)) (straightHint x)


-- | Detect Flush and return strongest Card
--
-- >>> flush $ Hand (take 5 $ filter ((==Hearts) . cardSuit ) allCards)
-- Just (Flush,H6_)
--
-- >>> flush $ Hand (take 5 $ filter ((<= 3) . cardNumber) allCards)
-- Nothing
flush :: Hand -> Maybe (PokerHand, Card)
flush x = do
    c <- flushHint x
    return (Flush, c)

    -- Same as followings
    -- flushHint x >>= (\y -> return (Straight, y))
    -- fmap (\y -> (Flush, y)) (flushHint x)


-- | Detect fullHouse and return strongest Card
--
-- >>> let sameNum = filter ((==9) . cardNumber) allCards
-- >>> let sameNum' = filter ((==10) . cardNumber) allCards
-- >>> let sameSuit = filter ((==Spades) . cardSuit) allCards
-- >>> fullHouse $ Hand (take 2 sameNum ++ take 3 sameNum')
-- Just (FullHouse,C10)
--
-- >>> fullHouse $ Hand (take 3 sameNum ++ take 2 sameNum')
-- Just (FullHouse,C9_)
--
-- >>> fullHouse $ Hand (take 2 sameNum ++ take 3 sameSuit)
-- Nothing
-- 
-- >>> fullHouse $ Hand (take 5 sameSuit)
-- Nothing
fullHouse :: Hand -> Maybe (PokerHand, Card)
fullHouse x = do
    cs <- nOfKindHint 3 x
    ds <- nOfKindHint 2 x
    guard (length cs == 1 && length ds == 1)
    return (FullHouse, last $ concat cs )

-- | Detect FourOfAKind and return strongest Card
--
-- >>> let sameNum = filter ((==4) . cardNumber) allCards
-- >>> let sameSuit = filter ((==Spades) . cardSuit) allCards
-- >>> fourOfAKind $ Hand (take 4 sameNum ++ take 1 sameSuit)
-- Just (FourOfAKind,S4_)
-- 
-- >>> fourOfAKind $ Hand (take 5 sameSuit)
-- Nothing
fourOfAKind :: Hand -> Maybe (PokerHand, Card)
fourOfAKind x = do
    cs <- nOfKindHint 4 x
    return (FourOfAKind, maximum . concat $ cs)


-- | Detect StraightFlush and return strongest Card
--
-- >>> straightFlush $ Hand (take 5 $ filter ((==Hearts) . cardSuit) allCards)
-- Just (StraightFlush,H6_)
--
-- >>> straightFlush $ Hand (take 5 $ filter (\x -> cardSuit x == Hearts && even (cardNumber x)) allCards)
-- Nothing
--
-- >>> let sameSuit = filter ((==Hearts) . cardSuit) allCards
-- >>> let sameSuit' = filter ((==Spades) . cardSuit) allCards
-- >>> straightFlush $ Hand (take 3 sameSuit ++ take 2 (drop 3 sameSuit'))
-- Nothing
--
-- >>> straightFlush $ Hand (take 5 $ filter (even . cardNumber) allCards)
-- Nothing
straightFlush :: Hand -> Maybe (PokerHand, Card)
straightFlush x = do
    c <- flushHint x
    d <- straightHint x
    return (StraightFlush, max c d)


-- | Check straight in Hand
--
-- >>> straightHint $ Hand (take 5 allCards)
-- Just H6_
--
-- >>> straightHint $ Hand (take 5 $ drop 8 allCards)
-- Just HA_
--
-- >>> straightHint $ Hand (take 2 $ allCards)
-- Nothing
straightHint :: Hand -> Maybe Card
straightHint (Hand xs) = 
    (judgeStraight . extract cardStrength $ xs)
    <|> (judgeStraight . sort . extract cardNumber $ xs)
    where
        -- | Check Straight with Numbers
        --
        -- >>> isStraight [1..5]
        -- True
        --
        -- >>> isStraight [1,3,4,5,6]
        -- False
        --
        -- >>> isStraight [1]
        -- False
        --
        -- >>> isStraight []
        -- False
        isStraight :: [Int] -> Bool
        isStraight [] = False
        isStraight ys@(y:_) = ys == [y..y+4]

        -- | Check Straight and return strongest card
        --
        -- >>> judgeStraight . extract cardNumber . sort . take 5 $ allCards
        -- Just H6_
        --
        -- >>> judgeStraight []
        -- Nothing
        judgeStraight :: [(Int, Card)] -> Maybe Card
        judgeStraight ys = 
            if isStraight $ map fst ys
            then Just . snd . last $ ys
            else Nothing


-- | Check flush in Hand
--
-- >>> flushHint $ Hand (take 5 $ filter (\x -> cardSuit x == Hearts) allCards )
-- Just H6_
--
-- >>> flushHint $ Hand (take 5 $ filter (\x -> cardNumber x == 2) allCards )
-- Nothing
flushHint :: Hand -> Maybe Card
flushHint (Hand (x:xs)) =
    if all (== suit) suits
    then Just (last xs)
    else Nothing
    where
        suit = cardSuit x
        suits = map cardSuit xs

flushHint (Hand []) = Nothing


-- | n of Kind in Hand
--
-- >>> let treeCards = take 3 $ filter ((==2) . cardNumber) $ allCards
-- >>> let twoCards = take 2 $ filter ((==10) . cardNumber) $ allCards
-- >>> let fullhouse = toHand $ treeCards ++ twoCards
--
-- >>> fullhouse >>= nOfKindHint 2
-- Just [[H10,D10]]
--
-- >>> fullhouse >>= nOfKindHint 3
-- Just [[H2_,D2_,C2_]]
--
-- >>> fullhouse >>= nOfKindHint 4
-- Nothing
--
nOfKindHint :: Int -> Hand -> Maybe [[Card]]
nOfKindHint n (Hand xs) = 
    if cards /= [] then Just cards else Nothing
    where
        cards :: [[Card]]
        cards = filter ((==n) . length) $
            groupBy ((==) `on` cardNumber) xs
        -- cards = groupBy (\x y -> cardNumber x == cardNumber y) xs


-- | 
--
-- >>> extract cardNumber $ take 5 $ allCards
-- [(2,H2_),(3,H3_),(4,H4_),(5,H5_),(6,H6_)]
--
-- >>> extract cardStrength $ take 5 $ allCards
-- [(2,H2_),(3,H3_),(4,H4_),(5,H5_),(6,H6_)]
extract :: (a -> b) -> [a] -> [(b, a)]
extract f cs = [ (f c, c) | c <- cs ]