diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,21 @@ +The MIT License (MIT) + +Copyright (c) 2016 tobynet + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,23 @@ +# Syakyo of Poker in Haskell + +* For `Syakyo`, refer to https://en.wikipedia.org/wiki/Sutra_copying +* For `Poker in Haskell`, refer to http://tune.hateblo.jp/entry/2015/05/12/023112 + +## Requirements + +* Haskell compiler(ghc 7.8.3 or lator) +* `random-shuffle` package + + ex. + + ```shell + $ cabal install random-shuffle + ``` + +## Todos + +* todo: module化 +* todo: Web App化 +* todo: Deploy to PaaS +* todo: 出力 using IO + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,5 @@ +module Main where +import Game.Poker + +main :: IO () +main = simpleGame diff --git a/java-poker.cabal b/java-poker.cabal new file mode 100644 --- /dev/null +++ b/java-poker.cabal @@ -0,0 +1,32 @@ +name: java-poker +version: 0.1.0.0 +synopsis: The etude of the Haskell programming +description: poker like a JAVA +-- description: +homepage: https://github.com/tobynet/java-poker#readme +license: MIT +license-file: LICENSE +author: tobynet +maintainer: toby.net.info+git@gmail.com +-- copyright: +category: Game +build-type: Simple +extra-source-files: README.md +cabal-version: >=1.10 + +library + hs-source-dirs: src + exposed-modules: Game.Poker + , Game.Poker.Hands + , Game.Poker.Cards + build-depends: base >=4.7 && <5 + , random-shuffle >=0.0 && <0.1 + default-language: Haskell2010 + +executable java-poker + hs-source-dirs: app + main-is: Main.hs + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: base + , java-poker + default-language: Haskell2010 diff --git a/src/Game/Poker.hs b/src/Game/Poker.hs new file mode 100644 --- /dev/null +++ b/src/Game/Poker.hs @@ -0,0 +1,291 @@ +module Game.Poker + ( module Game.Poker.Hands + , module Game.Poker.Cards + , simpleGame + ) where + +import System.Random.Shuffle +import Control.Monad +import Control.Applicative +import Data.List +import Data.Char +import Data.Maybe +import Game.Poker.Cards -- Fuda +import Game.Poker.Hands -- Tefuda + +type DiscardList = [Card] -- Sutefuda +type Deck = [Card] -- Yamafuda + + +-- | 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 + + +simpleGame :: IO () +simpleGame = do + -- Ogre font + putStrLn " __ ___ _ " + putStrLn " \\ \\ __ ___ ____ _ / _ \\___ | | _____ _ __ " + putStrLn " \\ \\/ _` \\ \\ / / _` |/ /_)/ _ \\| |/ / _ \\ '__|" + putStrLn " /\\_/ / (_| |\\ V / (_| / ___/ (_) | < __/ | " + putStrLn " \\___/ \\__,_| \\_/ \\__,_\\/ \\___/|_|\\_\\___|_| " + putStrLn " " + + deck <- shuffleM allCards + case getHand deck of + Nothing -> error "Unexpected error" + Just res -> matchPoker res + ynQuestion "-- replay?" simpleGame (putStrLn "-- bye.") + + +data Player = Player | Enemy deriving Eq + +showPlayerName :: Player -> String +showPlayerName Player = "You" +showPlayerName Enemy = "Java" + +matchPoker :: (Hand, Deck) -> IO () +matchPoker (mhand, deck) = do + (mres, ndeck, nmhand) <- playPoker mhand deck Player + case getHand ndeck of + Nothing -> error "Unexpected error" + Just (ehand, odeck) -> do + (eres, _,nehand) <- playPoker ehand odeck Enemy + printResult nmhand nehand mres eres + + +-- | Play poker +playPoker :: Hand -> Deck -> Player -> IO ((PokerHand, Card), Deck, Hand) +playPoker hand deck player = do + discards <- if player == Player + then inputDisuse hand + else aiDisuse hand + + case drawHand deck discards hand of + Nothing -> error "Unexpected error" + Just (nhand, ndeck) -> do + let res = pokerHand nhand + return (res, ndeck, nhand) + + +-- | Input suteru cards +inputDisuse :: Hand -> IO DiscardList +inputDisuse hand = do + printHand [] hand Player + putStrLn "-- Select discardable cards" + gotDisuse <- getDiscardList hand + case gotDisuse of + Nothing -> do + putStrLn "-- Input 1 or .. 5" + inputDisuse hand + Just disuses -> do + printHand disuses hand Player + ynQuestion "-- You: OK?" (return disuses) (inputDisuse hand) + + +-- | aiDisuse :: Hand -> IO DiscardList +aiDisuse :: Hand -> IO DiscardList +aiDisuse hand = do + let res = aiSelectDiscards hand + printHand res hand Enemy + putStrLn "-- Java: OK!" + return res + + +-- | print Yaku +printResult :: Hand -> Hand -> (PokerHand, Card) -> (PokerHand, Card) -> IO() +printResult mhand ehand mres@(mph, mcard) eres@(eph, ecard) = do + putStrLn "***** Result *****" + printHand [] mhand Player + printHand [] ehand Enemy + + putStrLn $ concat ["Your hand is ", show mph, ", greatest card is ", show mcard] + putStrLn $ concat ["Java's hand is ", show eph, ", greatest card is ", show ecard] + + putStrLn $ concat + [ "\n" + , " +----------------------------+\n" + , " || ||\n" + , " || " , winLossMessage, " ||\n" + , " || ||\n" + , " +----------------------------+\n" + ] + where + winLossMessage = case judgeVictory mres eres of + LT -> " Java win! " + EQ -> "It's a tie!" + GT -> " You win!! " + + +-- | print Tefuda +printHand :: DiscardList -> Hand -> Player -> IO () +printHand dis hand player = do + putStrLn $ "-- " ++ showPlayerName player ++ "'s Hand : " + forM_ [0..4] $ \x -> + putStrLn $ " " ++ showChangeHand dis hand x + + +-- | Repeat y/n question +ynQuestion :: String -> IO a -> IO a -> IO a +ynQuestion s yes no = do + putStrLn $ s ++ "(y/n)" + input <- getLine + case input of + "y" -> yes + "n" -> no + _ -> do + putStrLn "-- Input `y` or `n`" + ynQuestion s yes no + + +-- | Hand with Sutefuda to String +showChangeHand :: DiscardList -> Hand -> Int -> String +showChangeHand dis hand row = let + judge x = if x `elem` dis + then + [ " " + , " " + , " " ++ show x ++ " " + , " " + , " "] !! row + + else + [ " -----+ " + , "| | " + , "| " ++ show x ++ " | " + , "| | " + , "+----- "] !! row + + in concatMap judge (fromHand hand) + + +-- | Sutefuda = Hand - allYaku +-- +-- >>> let Just (x) = toHand $ take 5 $ (filter (\x -> (cardNumber x == 10)) $ allCards) ++ allCards +-- >>> fromHand x +-- [H2_,H10,D10,C10,S10] +-- >>> nOfKindDiscards x +-- [H2_] +nOfKindDiscards :: Hand -> DiscardList +nOfKindDiscards hand = fromHand hand \\ allNOfKinds hand + where + -- | all Yaku + -- + -- >>> let Just (x) = toHand $ take 5 $ (filter (\x -> (cardNumber x == 10)) $ allCards) ++ allCards + -- >>> allNOfKinds x + -- [H10,D10,C10,S10] + allNOfKinds :: Hand -> [Card] + allNOfKinds h = concat . concat $ catMaybes [nOfKindHint 2 h, nOfKindHint 3 h, nOfKindHint 4 h] + + +-- | Sutefuda by AI +-- +-- >>> let Just straightFlush = toHand $ take 5 $ allCards +-- >>> aiSelectDiscards straightFlush +-- [] +-- +-- >>> let Just fourCard = toHand $ take 5 $ (filter ((==10) . cardNumber) allCards) ++ allCards +-- >>> aiSelectDiscards fourCard +-- [H2_] +-- +-- >>> let Just buta = toHand $ take 5 $ (take 2 allCards) ++ (take 2 $ drop (13+5) allCards) ++ (drop (13*2+9) allCards) +-- >>> aiSelectDiscards buta +-- [H2_,H3_,D7_,D8_,CJ_] +-- +aiSelectDiscards :: Hand -> DiscardList +aiSelectDiscards hand = + fromMaybe (nOfKindDiscards hand) + ((straightHint hand <|> flushHint hand) *> Just []) + + +-- | 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 + + diff --git a/src/Game/Poker/Cards.hs b/src/Game/Poker/Cards.hs new file mode 100644 --- /dev/null +++ b/src/Game/Poker/Cards.hs @@ -0,0 +1,119 @@ +module Game.Poker.Cards + ( Suit(..) + , Card + , allCards + , cardSuit + , cardNumber + , cardStrength + ) where + +-- | 4 types of card +-- +-- >>> Hearts -- Show +-- Hearts +-- +-- >>> read "Hearts" :: Suit -- Read +-- Hearts +-- +-- >>> Hearts == Hearts -- Eq +-- True +-- +-- >>> Hearts == Spades -- Eq +-- False +-- +-- >>> Hearts < Diamonds -- Ord +-- True +-- +-- >>> succ Hearts -- Enum +-- Diamonds +-- +data Suit = Hearts | Diamonds | Clubs | Spades + deriving (Show, Read, Eq, Ord, Enum) + + +-- | One playing card +-- +-- >>> Card 1 Hearts == Card 2 Hearts -- Eq +-- False +-- +-- >>> Card 1 Hearts < Card 2 Hearts -- Ord +-- True +data Card = Card Int Suit + deriving (Eq, Ord) + + +-- | For instance of show typeclass +-- +-- In order that "K < A" equals True, +-- consider 14 as the ace +-- +-- >>> showCardNumber 14 +-- "A_" +-- +-- >>> showCardNumber 4 +-- "4_" +showCardNumber :: Int -> String +showCardNumber 14 = "A_" +showCardNumber 13 = "K_" +showCardNumber 12 = "Q_" +showCardNumber 11 = "J_" +showCardNumber 10 = "10" +showCardNumber x = show x ++ "_" + + +-- | Show typeclass of Card +-- +-- >>> show $ Card 1 Hearts +-- "H1_" +-- +-- >>> show $ Card 14 Diamonds +-- "DA_" +-- +-- >>> show $ Card 11 Clubs +-- "CJ_" +-- +-- >>> show $ Card 10 Spades +-- "S10" +instance Show Card where + show (Card i Hearts) = "H" ++ showCardNumber i + show (Card i Diamonds) = "D" ++ showCardNumber i + show (Card i Clubs) = "C" ++ showCardNumber i + show (Card i Spades) = "S" ++ showCardNumber i + + +-- | All cards +-- +-- >>> length allCards +-- 52 +-- +-- >>> take 13 $ allCards +-- [H2_,H3_,H4_,H5_,H6_,H7_,H8_,H9_,H10,HJ_,HQ_,HK_,HA_] +-- +-- >>> reverse $ take 13 $ reverse allCards +-- [S2_,S3_,S4_,S5_,S6_,S7_,S8_,S9_,S10,SJ_,SQ_,SK_,SA_] +-- +allCards :: [Card] +allCards = [ Card num suit | suit <- [Hearts ..], num <- [2..14] ] + + +-- | Get Suit from card +-- +-- >>> cardSuit $ Card 10 Hearts +-- Hearts +cardSuit :: Card -> Suit +cardSuit (Card _ card) = card + +-- | Get Suit from card +-- +-- >>> cardNumber $ Card 10 Hearts +-- 10 +cardNumber :: Card -> Int +cardNumber (Card num _) = num + +-- | Stregnth of card +-- +-- >>> cardStrength . head $ allCards +-- 2 +cardStrength :: Card -> Int +cardStrength (Card n _) = n + diff --git a/src/Game/Poker/Hands.hs b/src/Game/Poker/Hands.hs new file mode 100644 --- /dev/null +++ b/src/Game/Poker/Hands.hs @@ -0,0 +1,347 @@ +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 ] + + +