diff --git a/app/Main.hs b/app/Main.hs deleted file mode 100644 --- a/app/Main.hs +++ /dev/null @@ -1,5 +0,0 @@ -module Main where -import Game.Poker - -main :: IO () -main = simpleGame diff --git a/app/Simple.hs b/app/Simple.hs new file mode 100644 --- /dev/null +++ b/app/Simple.hs @@ -0,0 +1,5 @@ +module Main where +import Game.Poker.Simple + +main :: IO () +main = simpleGame diff --git a/java-poker.cabal b/java-poker.cabal --- a/java-poker.cabal +++ b/java-poker.cabal @@ -1,5 +1,5 @@ name: java-poker -version: 0.1.0.0 +version: 0.1.1.0 synopsis: The etude of the Haskell programming description: poker like a JAVA -- description: @@ -19,13 +19,15 @@ exposed-modules: Game.Poker , Game.Poker.Hands , Game.Poker.Cards + , Game.Poker.AI + , Game.Poker.Simple build-depends: base >=4.7 && <5 , random-shuffle >=0.0 && <0.1 default-language: Haskell2010 -executable java-poker +executable java-poker-simple hs-source-dirs: app - main-is: Main.hs + main-is: Simple.hs ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: base , java-poker diff --git a/src/Game/Poker.hs b/src/Game/Poker.hs --- a/src/Game/Poker.hs +++ b/src/Game/Poker.hs @@ -1,291 +1,5 @@ -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 - +module Game.Poker ( module X) where +import Game.Poker.Cards as X -- Fuda +import Game.Poker.Hands as X -- Tefuda +import Game.Poker.AI as X -- core AI of CPU diff --git a/src/Game/Poker/AI.hs b/src/Game/Poker/AI.hs new file mode 100644 --- /dev/null +++ b/src/Game/Poker/AI.hs @@ -0,0 +1,49 @@ +module Game.Poker.AI + ( aiSelectDiscards + , nOfKindDiscards + ) where + +import Data.List +import Data.Maybe +import Control.Applicative +import Game.Poker.Cards +import Game.Poker.Hands + +-- | 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 []) + + +-- | 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] + diff --git a/src/Game/Poker/Hands.hs b/src/Game/Poker/Hands.hs --- a/src/Game/Poker/Hands.hs +++ b/src/Game/Poker/Hands.hs @@ -10,7 +10,6 @@ , nOfKindHint -- hand - , straightFlush , fourOfAKind , fullHouse , flush @@ -18,10 +17,21 @@ , 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 @@ -64,6 +74,8 @@ | StraightFlush -- Sugoi deriving (Show, Read, Eq, Ord, Enum) +type DiscardList = [Card] -- Sutefuda +type Deck = [Card] -- Yamafuda -- | Detect poker hand and return strength Card -- @@ -342,6 +354,101 @@ -- [(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 diff --git a/src/Game/Poker/Simple.hs b/src/Game/Poker/Simple.hs new file mode 100644 --- /dev/null +++ b/src/Game/Poker/Simple.hs @@ -0,0 +1,147 @@ +module Game.Poker.Simple + (simpleGame + ) where + +import Control.Monad +import System.Random.Shuffle +import Game.Poker.Cards -- Fuda +import Game.Poker.Hands -- Tefuda +import Game.Poker.AI -- core AI of CPU + +data Player = Player | Enemy deriving Eq + +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.") + + +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) +