diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2015 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Your name here nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 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/draw-poker.cabal b/draw-poker.cabal new file mode 100644 --- /dev/null +++ b/draw-poker.cabal @@ -0,0 +1,43 @@ +name: draw-poker +version: 0.1.0.0 +synopsis: playing draw poker +description: for http://tune.hateblo.jp/entry/2015/05/12/023112 +homepage: http://github.com/name/project +license: BSD3 +license-file: LICENSE +author: tune +maintainer: its.out.of.tune.this.my.music@gmail.com +category: Game +build-type: Simple +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 + , safe + default-language: Haskell2010 + +executable draw-poker + hs-source-dirs: app + main-is: Main.hs + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: base + , draw-poker + default-language: Haskell2010 + +test-suite draw-poker-test + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Spec.hs + build-depends: base + , draw-poker + ghc-options: -threaded -rtsopts -with-rtsopts=-N + default-language: Haskell2010 + +source-repository head + type: git + location: https://github.com/name/project 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,174 @@ +module Game.Poker + ( module Game.Poker.Hands + , module Game.Poker.Cards + , simpleGame + ) where +import System.Random.Shuffle + +import Game.Poker.Hands +import Game.Poker.Cards + +import Control.Applicative +import Control.Monad +import Data.Char +import Data.Maybe +import Safe + +----------- +-- ハンドの入れ替え + +type DiscardList = [Card] -- 捨て札 +type Deck = [Card] -- 山札 + +getHand :: Deck -> Maybe (Hand, Deck) +getHand deck = do + hand <- toHand . take 5 $ deck + return (hand, drop 5 deck) + +drawHand :: Deck -> DiscardList -> Hand -> Maybe (Hand, Deck) +drawHand deck dis h = let + nl = filter (flip notElem dis) (fromHand h) + nr = drop (5 - length nl) deck + in (,) <$> toHand (take 5 $ nl ++ deck) <*> Just nr + +getDiscardList :: Hand -> IO (Maybe DiscardList) +getDiscardList h = do + input <- getLine + return $ do + intList <- toIntList input + res <- selectByIndexes (fromHand h) intList + return res + +------ +-- helper + +toIntList :: String -> Maybe [Int] +toIntList str = if and $ map isDigit str then Just $ reads str else Nothing + where + reads :: String -> [Int] + reads = map $ read . (:[]) + +selectByIndexes :: [a] -> [Int] -> Maybe [a] +selectByIndexes l = sequence . map ((atMay l).(subtract 1)) + +----------- +-- AIの思考ルーチン(カードの入れ替え) + +aiSelectDiscards :: Hand -> DiscardList +aiSelectDiscards hand = + case straightHint hand `mplus` flushHint hand *> Just [] of + Nothing -> nOfKindDiscards hand + Just xs -> xs + +nOfKindDiscards :: Hand -> DiscardList +nOfKindDiscards hand = filter (flip notElem $ allNOfKinds hand) $ fromHand hand + where + allNOfKinds :: Hand -> [Card] + allNOfKinds hand = concat . concat + $ catMaybes [nOfKindHint 2 hand, nOfKindHint 3 hand, nOfKindHint 4 hand] + +----------- +-- 勝敗判定 + +judgeVictory :: (PokerHand, Card) -> (PokerHand, Card) -> Ordering +judgeVictory l r = compare (pullStrength l) (pullStrength r) + where + pullStrength :: (PokerHand, Card) -> (PokerHand, Int) + pullStrength = fmap cardStrength + +----------- +-- プロトタイプ + +simpleGame :: IO () +simpleGame = do + putStrLn "------------------" + putStrLn "-- simple poker --" + putStrLn "------------------" + deck <- shuffleM allCards + case getHand deck of + Nothing -> error "予期せぬエラー : getHand in simpleGame" + Just res -> matchPoker res + ynQuestion "-- もっかいやる？" simpleGame (putStrLn "-- またねノシノシ") + +-------- + +data Player = Player | Enemy deriving Eq + +showPlayerName :: Player -> String +showPlayerName Player = "あなた" +showPlayerName Enemy = "あいて" + +matchPoker :: (Hand, Deck) -> IO () +matchPoker (mhand, deck) = do + (mres, ndeck, nmhand) <- playPoker mhand deck Player + case getHand ndeck of + Nothing -> error "予期せぬエラー : getHand in matchPoker" + Just (ehand, odeck) -> do + (eres, _, nehand) <- playPoker ehand odeck Enemy + printResult nmhand nehand mres eres + +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 "予期せぬエラー : drawHand" + Just (nhand, ndeck) -> do + let res = pokerHand nhand + return (res, ndeck, nhand) + +inputDisuse :: Hand -> IO DiscardList +inputDisuse hand = do + printHand [] hand Player + putStrLn "-- 捨てるカードを選んでね" + gotDisuse <- getDiscardList hand + case gotDisuse of + Nothing -> do + putStrLn "-- 1~5の数値を並べて入力してね" + inputDisuse hand + Just disuses -> do + printHand disuses hand Player + ynQuestion "-- あなた：これでいい？" (return disuses) (inputDisuse hand) + +aiDisuse :: Hand -> IO DiscardList +aiDisuse hand = do + let res = aiSelectDiscards hand + printHand res hand Enemy + putStrLn "-- あいて：これでいいよ！" + return res + +---- + +printResult :: Hand -> Hand -> (PokerHand, Card) -> (PokerHand, Card) -> IO () +printResult mhand ehand mres@(mph, mcard) eres@(eph, ecard) = do + putStrLn " ***** 結果発表！！ *****" + printHand [] mhand Player + printHand [] ehand Enemy + putStrLn $ concat ["あなたの手札は ", show mph, " で、最強カードは ", show mcard, " でした"] + putStrLn $ concat ["あいての手札は ", show eph, " で、最強カードは ", show ecard, " でした"] + case judgeVictory mres eres of + LT -> putStrLn "あなたの負けです" + EQ -> putStrLn "引き分けです" + GT -> putStrLn "あなたの勝ちです" + +printHand :: DiscardList -> Hand -> Player -> IO () +printHand dis hand player = + putStrLn $ "-- " ++ showPlayerName player ++ "の手札 : " ++ showChangeHand dis hand + +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 "-- `y`か`n`で入力してね" + ynQuestion s yes no + +showChangeHand :: DiscardList -> Hand -> String +showChangeHand dis h = let + judge x = if elem x dis then " " ++ show x ++ " " else "[" ++ show x ++ "]" + in concat $ map judge (fromHand h) + 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,103 @@ +module Game.Poker.Cards + ( Suit(..) + , Card + , allCards + , cardSuit + , cardNumber + , cardStrength + ---- + , h2 , h3 , h4 , h5 , h6 , h7 , h8 , h9 , h10 , hJ , hQ , hK , hA + , d2 , d3 , d4 , d5 , d6 , d7 , d8 , d9 , d10 , dJ , dQ , dK , dA + , c2 , c3 , c4 , c5 , c6 , c7 , c8 , c9 , c10 , cJ , cQ , cK , cA + , s2 , s3 , s4 , s5 , s6 , s7 , s8 , s9 , s10 , sJ , sQ , sK , sA + ) where +--import Control.DeepSeq + +data Suit = Hearts | Diamonds | Clubs | Spades + deriving (Show, Read, Eq, Ord, Enum) +data Card = Card Int Suit + deriving (Eq, Ord) +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 + +showCardNumber :: Int -> String +showCardNumber 14 = "A_" +showCardNumber 13 = "K_" +showCardNumber 12 = "Q_" +showCardNumber 11 = "J_" +showCardNumber 10 = "10" +showCardNumber x = (show $ x) ++ "_" + +allCards :: [Card] +allCards = [ Card num suit | suit <- [Hearts ..], num <- [2..14] ] + +cardSuit :: Card -> Suit +cardSuit (Card _ s) = s + +cardNumber :: Card -> Int +cardNumber (Card 14 _) = 1 -- Aは14なので +cardNumber (Card n _) = n + +cardStrength :: Card -> Int +cardStrength (Card n _) = n + +-------- + +h2 = Card 2 Hearts +h3 = Card 3 Hearts +h4 = Card 4 Hearts +h5 = Card 5 Hearts +h6 = Card 6 Hearts +h7 = Card 7 Hearts +h8 = Card 8 Hearts +h9 = Card 9 Hearts +h10 = Card 10 Hearts +hJ = Card 11 Hearts +hQ = Card 12 Hearts +hK = Card 13 Hearts +hA = Card 14 Hearts + +d2 = Card 2 Diamonds +d3 = Card 3 Diamonds +d4 = Card 4 Diamonds +d5 = Card 5 Diamonds +d6 = Card 6 Diamonds +d7 = Card 7 Diamonds +d8 = Card 8 Diamonds +d9 = Card 9 Diamonds +d10 = Card 10 Diamonds +dJ = Card 11 Diamonds +dQ = Card 12 Diamonds +dK = Card 13 Diamonds +dA = Card 14 Diamonds + +c2 = Card 2 Clubs +c3 = Card 3 Clubs +c4 = Card 4 Clubs +c5 = Card 5 Clubs +c6 = Card 6 Clubs +c7 = Card 7 Clubs +c8 = Card 8 Clubs +c9 = Card 9 Clubs +c10 = Card 10 Clubs +cJ = Card 11 Clubs +cQ = Card 12 Clubs +cK = Card 13 Clubs +cA = Card 14 Clubs + +s2 = Card 2 Spades +s3 = Card 3 Spades +s4 = Card 4 Spades +s5 = Card 5 Spades +s6 = Card 6 Spades +s7 = Card 7 Spades +s8 = Card 8 Spades +s9 = Card 9 Spades +s10 = Card 10 Spades +sJ = Card 11 Spades +sQ = Card 12 Spades +sK = Card 13 Spades +sA = Card 14 Spades 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,148 @@ +module Game.Poker.Hands + ( Hand + , toHand, fromHand + , PokerHand(..) + , pokerHand + ---- + -- hint + , straightHint + , flushHint + , nOfKindHint + ---- + -- hand + , straightFlush + , fourOfAKind + , fullHouse + , flush + , straight + , threeOfAKind + , twoPair + , onePair + ) where +import Game.Poker.Cards +import Data.List +import Control.Monad + +newtype Hand = Hand { fromHand :: [Card] } deriving (Show, Eq, Ord) + +toHand :: [Card] -> Maybe Hand +toHand l = + if length l == 5 + then Just $ Hand (sort l) + else Nothing + +pokerHand :: Hand -> (PokerHand, Card) +pokerHand h@(Hand l) = + case foldl mplus Nothing $ fmap ($h) hands of + Just pc -> pc + Nothing -> (HighCards, last l) + where + hands :: [Hand -> Maybe (PokerHand, Card)] + hands = + [ straightFlush + , fourOfAKind + , fullHouse + , flush + , straight + , threeOfAKind + , twoPair + , onePair + ] + +------- + +-- ポーカー・ハンド +data PokerHand + = HighCards + | OnePair + | TwoPair + | ThreeOfAKind + | Straight + | Flush + | FullHouse + | FourOfAKind + | StraightFlush + deriving (Show, Read, Eq, Ord, Enum) + +------- +-- Hint + +straightHint :: Hand -> Maybe Card +straightHint (Hand l) = + (judgeStright . extract cardStrength $ l) + `mplus` + (judgeStright . sort . extract cardNumber $ l) + where + isStright :: [Int] -> Bool + isStright xs@(x:_) = xs == [x .. x + 4] + isStright _ = False + + judgeStright :: [(Int, Card)] -> Maybe Card + judgeStright l = + if isStright $ map fst l + then Just . snd . last $ l + else Nothing + +flushHint :: Hand -> Maybe Card +flushHint (Hand (x:xs)) = + if all ((cardSuit x==).cardSuit) xs then Just (last xs) else Nothing + +nOfKindHint :: Int -> Hand -> Maybe [[Card]] +nOfKindHint n (Hand h) = if cards /= [] then Just cards else Nothing + where + cards :: [[Card]] + cards = filter ((==n).length) + $ groupBy (\x y -> cardNumber x == cardNumber y) h + +------- +-- PokerHand + +straightFlush :: Hand -> Maybe (PokerHand, Card) +straightFlush h = do + c <- straightHint h + d <- flushHint h + return (StraightFlush, max c d) + +fourOfAKind :: Hand -> Maybe (PokerHand, Card) +fourOfAKind h = do + cs <- nOfKindHint 4 h + return (FourOfAKind, last $ concat cs) + +fullHouse :: Hand -> Maybe (PokerHand, Card) +fullHouse h = do + cs <- nOfKindHint 3 h + nOfKindHint 2 h + return (FullHouse, last $ concat cs) + +flush :: Hand -> Maybe (PokerHand, Card) +flush h = do + c <- flushHint h + return (Flush, c) + +straight :: Hand -> Maybe (PokerHand, Card) +straight h = do + c <- straightHint h + return (Straight, c) + +threeOfAKind :: Hand -> Maybe (PokerHand, Card) +threeOfAKind h = do + cs <- nOfKindHint 3 h + return (ThreeOfAKind, last $ concat cs) + +twoPair :: Hand -> Maybe (PokerHand, Card) +twoPair h = do + cs <- nOfKindHint 2 h + if length cs == 2 + then Just (TwoPair, last $ concat cs) + else Nothing + +onePair :: Hand -> Maybe (PokerHand, Card) +onePair h = do + cs <- nOfKindHint 2 h + return (OnePair, last $ concat cs) + +------- +-- Helper + +extract :: (b -> a) -> [b] -> [(a, b)] +extract f cs = map (\c -> (f c, c)) cs diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,2 @@ +main :: IO () +main = putStrLn "Test suite not yet implemented"