Just $ A sandbox

プログラミングと計算機科学とかわいさ

Haskellで大富豪を作ろう (4)基本のルールと場の流れを作ろう

Haskell

前回までの記事

第四回 基本のルールと場の流れを作ろう

前回は同じ数字で組を作れるようになったので, いよいよちゃんとしたルールを作ろう.

まずは出せるカードは場にあるカードより強い数字で, 場にあるカード以上の枚数のものに限ることにしよう. (ついでに, 自分のターンには出せるカードの候補を表示しておくことにしよう)
自分のターンには, 入力された数に対して, それが正しい数字であって, 出せるカードである時にそれを出すという操作をする.

さらに, パスもできることにする.
出せるカードがない場合かパスを入力した場合はパスとして扱うことにする. このため, player, auto :: StateT Game IO [Card]の2つの函数は, パスかどうかを判断できる型に変更する.

パスかどうかを判断するにはもちろん今までのようにMaybeを使っても良いが, パスが宣言されるタイミングが2ヶ所あるので, パスを宣言するとそこで処理が終了することにすると書きやすい.
要はパスは例外処理として扱うと便利なので, 今回はパスをmtlにあるExceptモナドを使って実装しよう. (単に個人的に使ってみたかっただけともいう)

player :: ExceptT () (StateT Game IO) [Card]に対して, runExceptT player :: StateT Game IO (Either () [Card]) となるので, これを実行した結果がLeftの場合はパス, Rightの場合は[Card]がこのターンに出すカードということになる.
ちなみにplayer, autoの中ではExceptとStateの2つのモナドが重なっているので, Stateに対する処理はliftを使って持ち上げる必要がある.

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

ここで, throwErrorが例外を出す所. throwErrorが実行されるとそこで処理が終わる.

ついでにパスが繰り返されると場が流れ, 最後にカードを出した人からスタートすることにした.

さらについでに, カードを組で出す場合, 出せる組を表示してそこから選ばせるようにした.
例えば"♠2, ♥2"をもっているとき, 2の出し方は"[♠2], [♥2], [♠2, ♥2]"の3通りの出し方があるのでユーザーはこの中から出し方を選択することにした. (こっちの方が入力が簡単なので)

実行例

Let's play 大富豪!
あなたの番です.
手札: [[♦3,♠3],[♠4],[♦6,♠6],[♠7],[♦9],[♦10,♠10],[♠Q],[♦K,♥K],[♣A]]
出すカードの数字を入力してください. (J: ジョーカー, P: パス)
> 3
0:[♦3] 1:[♠3] 2:[♦3,♠3]
どのカードを出しますか?
> 2
場札:[♦3,♠3]
CPU1さんの番です.
場札:[♠5,♣5]
CPU2さんの番です.
場札:[♦7,♣7]
CPU3さんの番です.
場札:[♦Q,♥Q]
あなたの番です.
手札: [[♠4],[♦6,♠6],[♠7],[♦9],[♦10,♠10],[♠Q],[♦K,♥K],[♣A]]
候補: [[♦K,♥K]]
出すカードの数字を入力してください. (J: ジョーカー, P: パス)
> P
パス
CPU1さんの番です.
パス
CPU2さんの番です.
場札:[♣2,♠2]
CPU3さんの番です.
パス
あなたの番です.
手札: [[♠4],[♦6,♠6],[♠7],[♦9],[♦10,♠10],[♠Q],[♦K,♥K],[♣A]]
候補: []
パス
CPU1さんの番です.
パス
CPU2さんの番です.
パス
場が流れました.
CPU2さんの番です.
場札:[♥3]
CPU3さんの番です.
場札:[♣4]
あなたの番です.

ソースコード

{-# 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)
 
-- (4) 基本のルールと場の流れを作ろう
 
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 j <= Joker j' = j <= j'
  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
  }
 
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
 
  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
 
  pt <- use passtimes
  when (pt >= 4) $ do
    lift $ putStrLn $ "場が流れました."
    layout .= Nothing
    turn -= 1
 
  p <- use players
  turn %= nextTurn 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 -> return $ (groupBy sameNumber ds) !! 0
 
main = do
  putStrLn "Let's play 大富豪!"
 
  let pl = 4
  d <- deal pl
  runStateT game $ Game (IM.fromList $ zip [0..pl-1] d) 0 pl Nothing 0