module Game.Poker.Hands ( Hand , toHand, fromHand , pokerHand , PokerHand -- hint , straightHint , flushHint , nOfKindHint -- hand , fourOfAKind , fullHouse , flush , straight , threeOfAKind , twoPair , onePair , DiscardList , Deck , drawHand , getHand , getDiscardList , toIntList , selectByIndexes , straightFlush , judgeVictory ) where import Data.List import Data.Char 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) type DiscardList = [Card] -- Sutefuda type Deck = [Card] -- Yamafuda -- | 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 ] -- | Draw cards to make new hand from Deck -- Return a new Hand and Deck if its possible. -- -- >>> drawHand :: Deck -> DiscardList -> Hand -> Maybe (Hand, Deck) drawHand deck dis h = let nl = filter (`notElem` dis) (fromHand h) nr = drop (5 - length nl) deck in (,) <$> toHand (take 5 $ nl ++ deck) <*> Just nr -- in do -- hand <- toHand . take 5 $ nl ++ deck -- return (hand, nr) -- | Get hand from deck(Yamafuda) -- -- >>> let Just (hand, newDeck) = getHand allCards -- >>> hand -- Hand {fromHand = [H2_,H3_,H4_,H5_,H6_]} -- -- >>> let Just (_, newDeck') = getHand newDeck -- >>> take 8 newDeck' -- [HQ_,HK_,HA_,D2_,D3_,D4_,D5_,D6_] -- -- >>> getHand allCards >>= return . snd >>= getHand >>= return . take 8 . snd -- Just [HQ_,HK_,HA_,D2_,D3_,D4_,D5_,D6_] getHand :: Deck -> Maybe (Hand, Deck) getHand deck = do hand <- toHand . take 5 $ deck return (hand, drop 5 deck) -- | Get discardList(Sutefuda) from hand getDiscardList :: Hand -> IO (Maybe DiscardList) getDiscardList h = do input <- getLine return $ do xs <- toIntList input selectByIndexes (fromHand h) xs -- | String to [Int] for parse user inputs -- -- >>> toIntList "1234" -- Just [1,2,3,4] -- -- >>> toIntList "4019" -- Just [4,0,1,9] -- -- >>> toIntList "z4q01" -- Nothing -- -- >>> toIntList "" -- Just [] toIntList :: String -> Maybe [Int] toIntList cs = if isDigits cs then Just $ toInts cs else Nothing where isDigits :: String -> Bool isDigits = all isDigit toInts :: String -> [Int] toInts = map digitToInt -- | Get cards by indexes -- -- >>> selectByIndexes "12345" [1..3] -- Just "123" -- -- >>> selectByIndexes "12345" [10] -- Nothing -- selectByIndexes :: [a] -> [Int] -> Maybe [a] selectByIndexes xs = mapM (atMay xs . subtract 1) where atMay :: [a] -> Int -> Maybe a atMay ys i = if (0 <= i) && (i < length xs) then Just (ys !! i) else Nothing -- | Judge victory you and AI -- -- >>> judgeVictory :: (PokerHand, Card) -> (PokerHand, Card) -> Ordering judgeVictory l r = compare (pullStrength l) (pullStrength r) where pullStrength :: (PokerHand, Card) -> (PokerHand, Int) pullStrength = fmap cardStrength