Haskellで大富豪を作ろう (5)勝敗の判定をしよう
前回までの記事
- Haskellで大富豪を作ろう (1)トランプを用意しカードを配ろう - Just $ A sandbox
- Haskellで大富豪を作ろう (2)ターンを進めよう - Just $ A sandbox
- Haskellで大富豪を作ろう (3)カードの組を判定しよう - Just $ A sandbox
- Haskellで大富豪を作ろう (4)基本のルールと場の流れを作ろう - Just $ A sandbox
第五回 勝敗の判定をしよう
今回で1通りゲームとして遊べるようになる.
最後に, ゲームの勝敗の判定をしよう. 手札がなくなった人から抜けていき, 4位まで決定したら(3人が上がったら)ゲームを終了して結果を表示する.
game :: StateT Game IO () game = do ... (略) ds <- use (decks . ix t) ws <- use winner when (length ds == 0 && t `notElem` ws) $ do winner %= (t :) case t == 0 of True -> lift $ putStrLn $ "あなたの勝ち抜けです." False -> lift $ putStrLn $ "CPU" ++ show t ++ "さんが勝ち抜けました." ... (略) ws <- use winner when (length ws < p) $ game main = do putStrLn "Let's play 大富豪!" let pl = 4 d <- deal pl g <- execStateT game $ Game (IM.fromList $ zip [0..pl-1] d) 0 pl Nothing 0 [] let ws = zip [1..] (g^.winner) putStrLn $ "\n==========" putStrLn $ "勝敗" forM_ (reverse ws) $ \(i,k) -> do putStrLn $ show i ++ "位: " ++ (if k == 0 then "あなた" else ("CPU" ++ show k))
実行例
6人でやってみた実行例.
Let's play 大富豪! あなたの番です. 手札: [[♦7,♥7],[♥9,♣9],[♥J],[♥Q,♦Q,♣Q],[♥2]] 出すカードの数字を入力してください. (J: ジョーカー, P: パス) > 12 0:[♥Q] 1:[♦Q] 2:[♥Q,♦Q] 3:[♣Q] 4:[♥Q,♣Q] 5:[♦Q,♣Q] 6:[♥Q,♦Q,♣Q] どのカードを出しますか? > 6 場札:[♥Q,♦Q,♣Q] CPU1さんの番です. パス CPU2さんの番です. パス CPU3さんの番です. パス CPU4さんの番です. パス CPU5さんの番です. パス あなたの番です. 手札: [[♦7,♥7],[♥9,♣9],[♥J],[♥2]] 候補: [] パス 場が流れました. あなたの番です. 手札: [[♦7,♥7],[♥9,♣9],[♥J],[♥2]] 出すカードの数字を入力してください. (J: ジョーカー, P: パス) > 7 0:[♦7] 1:[♥7] 2:[♦7,♥7] どのカードを出しますか? > 2 場札:[♦7,♥7] CPU1さんの番です. 場札:[♥K,♣K] CPU2さんの番です. パス CPU3さんの番です. パス CPU4さんの番です. 場札:[♣A,♦A] CPU5さんの番です. パス あなたの番です. 手札: [[♥9,♣9],[♥J],[♥2]] 候補: [] パス CPU1さんの番です. パス CPU2さんの番です. パス CPU3さんの番です. パス CPU4さんの番です. パス 場が流れました. CPU4さんの番です. 場札:[♠3] CPU5さんの番です. 場札:[♠4] あなたの番です. 手札: [[♥9,♣9],[♥J],[♥2]] 候補: [[♥9],[♣9],[♥J],[♥2]] 出すカードの数字を入力してください. (J: ジョーカー, P: パス) > 11 場札:[♥J] CPU1さんの番です. 場札:[♠Q] CPU2さんの番です. 場札:[♦K] CPU3さんの番です. 場札:[♠A] CPU4さんの番です. 場札:[Joker 0] CPU5さんの番です. パス あなたの番です. 手札: [[♥9,♣9],[♥2]] 候補: [] パス CPU1さんの番です. パス CPU2さんの番です. 場札:[Joker 1] CPU3さんの番です. パス CPU4さんの番です. パス CPU5さんの番です. パス あなたの番です. 手札: [[♥9,♣9],[♥2]] 候補: [] パス CPU1さんの番です. パス CPU2さんの番です. パス 場が流れました. CPU2さんの番です. 場札:[♦3] CPU3さんの番です. 場札:[♣4] CPU4さんの番です. 場札:[♥6] CPU5さんの番です. 場札:[♠7] あなたの番です. 手札: [[♥9,♣9],[♥2]] 候補: [[♥9],[♣9],[♥2]] 出すカードの数字を入力してください. (J: ジョーカー, P: パス) > 2 場札:[♥2] CPU1さんの番です. パス CPU2さんの番です. パス CPU3さんの番です. パス CPU4さんの番です. パス CPU5さんの番です. パス あなたの番です. 手札: [[♥9,♣9]] 候補: [] パス 場が流れました. あなたの番です. 手札: [[♥9,♣9]] 出すカードの数字を入力してください. (J: ジョーカー, P: パス) > 9 0:[♥9] 1:[♣9] 2:[♥9,♣9] どのカードを出しますか? > 2 場札:[♥9,♣9] あなたの勝ち抜けです. CPU1さんの番です. パス CPU2さんの番です. パス CPU3さんの番です. 場札:[♠10,♥10] CPU4さんの番です. 場札:[♠J,♦J] CPU5さんの番です. パス CPU1さんの番です. パス CPU2さんの番です. パス CPU3さんの番です. パス CPU4さんの番です. パス 場が流れました. CPU4さんの番です. 場札:[♣7] CPU5さんの番です. 場札:[♣8] CPU1さんの番です. 場札:[♠9] CPU2さんの番です. 場札:[♣J] CPU3さんの番です. 場札:[♣2] CPU4さんの番です. パス CPU5さんの番です. パス CPU1さんの番です. パス CPU2さんの番です. パス CPU3さんの番です. パス 場が流れました. CPU3さんの番です. 場札:[♥3] CPU4さんの番です. 場札:[♠K] CPU4さんが勝ち抜けました. CPU5さんの番です. 場札:[♥A] CPU1さんの番です. 場札:[♠2] CPU2さんの番です. パス CPU3さんの番です. パス CPU5さんの番です. パス CPU1さんの番です. パス 場が流れました. CPU1さんの番です. 場札:[♣3] CPU2さんの番です. 場札:[♣5] CPU3さんの番です. 場札:[♦8] CPU5さんの番です. 場札:[♦10] CPU1さんの番です. パス CPU2さんの番です. 場札:[♦2] CPU3さんの番です. パス CPU5さんの番です. パス CPU1さんの番です. パス CPU2さんの番です. パス 場が流れました. CPU2さんの番です. 場札:[♦6] CPU3さんの番です. 場札:[♠8] CPU5さんの番です. パス CPU1さんの番です. 場札:[♣10] CPU2さんの番です. パス CPU3さんの番です. パス CPU5さんの番です. パス CPU1さんの番です. パス 場が流れました. CPU1さんの番です. 場札:[♥4,♦4] CPU1さんが勝ち抜けました. CPU2さんの番です. パス CPU3さんの番です. パス CPU5さんの番です. 場札:[♥5,♠5] CPU2さんの番です. パス CPU3さんの番です. パス CPU5さんの番です. 場札:[♠6,♣6] CPU5さんが勝ち抜けました. CPU2さんの番です. パス CPU3さんの番です. パス 場が流れました. CPU3さんの番です. 場札:[♦5] CPU3さんが勝ち抜けました. CPU2さんの番です. 場札:[♥8] CPU2さんの番です. 場札:[♦9] CPU2さんが勝ち抜けました. ========== 勝敗 1位: あなた 2位: CPU4 3位: CPU1 4位: CPU5 5位: CPU3 6位: CPU2
ソースコード
{-# LANGUAGE TemplateHaskell #-} module Main where import Control.Lens import Control.Monad.State import Control.Monad.Except import Data.Char import Data.List import qualified Data.IntMap as IM import Data.List.Split (chunksOf) import System.Random.Shuffle (shuffleM) -- (5'') 勝敗の判定をしよう data Suit = Spade | Club | Diamond | Heart deriving (Eq, Enum) data Number = N3 | N4 | N5 | N6 | N7 | N8 | N9 | N10 | N11 | N12 | N13 | N1 | N2 deriving (Eq, Ord, Enum) data JokerNumber = J1 | J2 deriving (Eq, Ord, Enum, Show) data Card = Card Suit Number | Joker JokerNumber deriving Eq allCards :: [Card] allCards = [Card s n | s <- [Spade .. Heart], n <- [N3 .. N2]] ++ [Joker j | j <- [J1,J2]] isNormalCard :: Card -> Bool isNormalCard (Card _ _) = True isNormalCard _ = False isJoker :: Card -> Bool isJoker (Card _ _) = False isJoker _ = True sameNumber :: Card -> Card -> Bool sameNumber (Card _ k) (Card _ l) = k == l sameNumber (Joker k) (Joker l) = k == l sameNumber _ _ = False toNumber :: Int -> Number toNumber n | 3 <= n && n <= 13 = toEnum $ n - 3 | n == 1 || n == 2 = toEnum $ n + 10 | otherwise = toNumber (n `mod` 13) fromNumber :: Number -> Int fromNumber n | n <= N13 = fromEnum n + 3 | otherwise = fromEnum n - 10 instance Show Suit where show Spade = "♠" show Club = "♣" show Diamond = "♦" show Heart = "♥" instance Show Number where show N1 = "A" show N11 = "J" show N12 = "Q" show N13 = "K" show k = show $ fromNumber k instance Show Card where show (Card s n) = show s ++ show n show (Joker k) = "Joker " ++ show (fromEnum k) instance Ord Card where Joker _ <= Joker _ = False Card _ _ <= Joker _ = True Joker _ <= Card _ _ = False Card _ k <= Card _ k' = k <= k' deal :: Int -> IO [[Card]] deal n = fmap (fmap sort . take n . chunksOf (length allCards `div` n)) $ shuffleM allCards data Game = Game { _decks :: IM.IntMap [Card], _turn :: Int, _players :: Int, _layout :: Maybe [Card], _passtimes :: Int, _winner :: [Int] } makeLenses ''Game strongPairs :: [Card] -> [Card] -> [[Card]] strongPairs lay hands = concat $ fmap combi $ filter (\h -> h !! 0 > lay !! 0) $ filter (\h -> length h >= length lay) hands' where hands' = groupBy sameNumber hands combi us = filter (\h -> length h == length lay) $ subsequences us game :: StateT Game IO () game = do t <- use turn ws <- use winner when (t `notElem` ws) $ do k <- case t == 0 of True -> (lift $ putStrLn $ "あなたの番です.") >> runExceptT player False -> (lift $ putStrLn $ "CPU" ++ show t ++ "さんの番です.") >> runExceptT auto case k of Left () -> do lift $ putStrLn $ "パス" passtimes += 1 Right l -> do lift $ putStrLn $ "場札:" ++ show l layout .= Just l passtimes .= 0 p <- use players ws <- use winner pt <- use passtimes when (pt >= p - length ws) $ do lift $ putStrLn $ "場が流れました." layout .= Nothing turn -= 1 ds <- use (decks . ix t) ws <- use winner when (length ds == 0 && t `notElem` ws) $ do winner %= (t :) case t == 0 of True -> lift $ putStrLn $ "あなたの勝ち抜けです." False -> lift $ putStrLn $ "CPU" ++ show t ++ "さんが勝ち抜けました." p <- use players turn %= nextTurn p ws <- use winner when (length ws < p) $ game where nextTurn p t | t == p-1 = 0 | otherwise = t+1 player :: ExceptT () (StateT Game IO) [Card] player = do ds <- use (decks . ix 0) ls <- use layout lift $ lift $ putStrLn $ "手札: " ++ show (groupBy sameNumber ds) ps <- case (\l -> strongPairs l ds) <$> ls of Just ps -> (lift $ lift $ putStrLn $ "候補: " ++ show ps) >> return ps Nothing -> return $ concat $ fmap subsequences $ groupBy sameNumber ds when (length ps == 0) $ throwError () lift $ lift $ putStrLn "出すカードの数字を入力してください. (J: ジョーカー, P: パス)" str <- lift $ lift getLine when (str == "P") $ throwError () case contains str ps of Just ps' -> lift $ process ds ps' Nothing -> do lift $ lift $ putStrLn "正しい数字を入力してください." player where process :: [Card] -> [[Card]] -> StateT Game IO [Card] process ds ps = do case length ps == 1 of True -> do decks %= IM.insert 0 (ds \\ ps !! 0) return $ ps !! 0 False -> whichToDiscard ds ps whichToDiscard :: [Card] -> [[Card]] -> StateT Game IO [Card] whichToDiscard ds ps = do let psi = zip [0..] ps lift $ putStrLn $ unwords $ fmap (\(i,c) -> show i ++ ":" ++ show c) psi lift $ putStrLn "どのカードを出しますか?" str <- lift getLine case pick str ps of Just cs -> do decks %= IM.insert 0 (ds \\ cs) return cs Nothing -> whichToDiscard ds ps contains :: String -> [[Card]] -> Maybe [[Card]] contains "J" ds = Just $ filter (any isJoker) ds contains str ds = isEmpty $ filter (any (isSameNumber (read str))) <$> check where check = if all isDigit str && 1 <= read str && read str <= 13 then Just ds else Nothing isEmpty p = if p == Just [] then Nothing else p pick :: String -> [[Card]] -> Maybe [Card] pick ss ps = (!! read ss) <$> check where check = if (all isDigit) ss && (0 <= read ss && read ss <= length ps - 1) then Just ps else Nothing isSameNumber :: Int -> Card -> Bool isSameNumber n x = isNormalCard x && cardNumber x == n where cardNumber (Card _ n) = fromNumber n cardNumber _ = -1 auto :: ExceptT () (StateT Game IO) [Card] auto = do t <- use turn ls <- use layout ds <- use (decks . ix t) case (\l -> strongPairs l ds) <$> ls of Just [] -> throwError () Just ps -> do let ps' = ps !! 0 decks %= IM.insert t (ds \\ ps') return ps' Nothing -> do let ps' = (groupBy sameNumber ds) !! 0 decks %= IM.insert t (ds \\ ps') return ps' main = do putStrLn "Let's play 大富豪!" let pl = 6 d <- deal pl g <- execStateT game $ Game (IM.fromList $ zip [0..pl-1] d) 0 pl Nothing 0 [] let ws = zip [1..] (reverse $ g^.winner) putStrLn $ "\n==========" putStrLn $ "勝敗" forM_ ws $ \(i,k) -> do putStrLn $ show i ++ "位: " ++ (if k == 0 then "あなた" else ("CPU" ++ show k))