java-poker 0.1.0.0 → 0.1.1.0

raw patch · 7 files changed

+318/−299 lines, 7 filesnew-component:exe:java-poker-simplePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• app/Main.hs +0/−5
• app/Simple.hs +5/−0
• java-poker.cabal +5/−3
• src/Game/Poker.hs +4/−290
• src/Game/Poker/AI.hs +49/−0
• src/Game/Poker/Hands.hs +108/−1
• src/Game/Poker/Simple.hs +147/−0

@@ -1,5 +0,0 @@-module Main where-import Game.Poker--main :: IO ()-main = simpleGame

@@ -0,0 +1,5 @@+module Main where+import Game.Poker.Simple++main :: IO ()+main = simpleGame

@@ -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

@@ -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

@@ -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]+

@@ -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   

@@ -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)+