今更Haskellでブラックジャックを実装してみた(3番煎じ)

はじめに

プログラミング入門者からの卒業試験は『ブラックジャック』を開発すべし
を読んで、「ならここ半年ほど取り組んでいるHaskellでやってみよう」と思ったわけですが、先駆者がいらっしゃいましたね・・・ しかも確認できただけで二人ほど

まあせっかく書いたので記事にしてみようと思います。

すごいH本を読んでいくつかツールを作った程度のHaskell力しかありませんので、是非ともHaskellマスターの皆様にアドバイスをいただければと思います。

一応ブラックジャックを作ってみた系の記事は、冒頭の記事以外どの記事も読んでいませんが(他言語含む)、実装アイディアが似通っていたらすみません・・・
あとえらそうにHaskell用語を使っていますが、間違っていたらすみません・・・

ちなみに使ったパッケージは

• base
• mtl
• random

です

完成品は一応以下にあります。
https://github.com/IamKeck/blackjack/

プログラムの中身

カード周り

カードの定義、計算周りからいきます

まずカードの数字から

newtype CardNum = CardNum {getNums :: Int} deriving (Eq, Ord)

instance Show CardNum where
  show (CardNum 1) = "A"
  show (CardNum 11) = "J"
  show (CardNum 12) = "Q"
  show (CardNum 13) = "K"
  show (CardNum a) = show a

これだと0とか14のCardNumが作れてしまいますので、ちゃんとやるときはコンストラクタは隠蔽し、スマートコンストラクタを定義したほうが良さそうですが今回は見逃してください・・・

合計値計算用に、CardNum -> Intな関数を定義します。
Aは1だったり11だったりしますので二つ定義します。

toPointOne :: CardNum -> Int
toPointOne (CardNum a) = if a > 10 then 10 else a

toPointEleven :: CardNum -> Int
toPointEleven (CardNum 1) = 11
toPointEleven a = toPointOne a

次はスート（マーク)です

data CardSuit = Spade | Heart | Diamond | Club deriving Eq

instance Show CardSuit where
  show Spade = "♠"
  show Heart = "♥"
  show Diamond = "◆"
  show Club = "♣"

数字とスートが用意できたので、カードそのものを定義します

data Card = Card {getSuit :: CardSuit, getNum :: CardNum} deriving Eq

instance Show Card where
show (Card s n) = show s <> " " <> show n

デッキもついでに定義しておきます。リスト内包表記を使います。

cardDeck :: [Card]
cardDeck = [Card s n|s <- [Spade, Heart, Diamond, Club], n <- map CardNum [1..13]]

カードをシャッフルする関数を定義します。 乱数はrandomパッケージを使いました。(あんまり使わないほうがいいそうですが)　
また、リストのシャッフル方法はこちらを参考にしました。

shuffleDeck :: RandomGen g  => [Card] -> g -> [Card]
shuffleDeck deck gen =
  let
    cardSize = length deck
    orderNums = take cardSize . nub $ randomRs (1, cardSize) gen
  in
    map fst . sortOn snd $ zip deck orderNums

[Card]から得点を計算する関数です。 さっき定義した CardNum -> Intな関数を第一引数にします。
A=1とするか、A=11とするか、第一引数で切り替えられるようにしました。

calcPoint :: (CardNum -> Int) -> [Card] -> Int
calcPoint f = getSum . foldMap (Sum . f . getNum)

しかしわざわざカッコつけてMonoidを使う必要はなかったかもしれません・・・

いらない気もしますが、山札からカードを一枚引く操作を表した関数も定義しておきました。
(後で気づきましたが、山札が空だった場合のエラー処理がないですね・・・ まあブラックジャックでは多分起こり得ないということで見逃してください・・・)

pickCard :: [Card] -> (Card, [Card])
pickCard xs = (head xs, tail xs)

プレイヤー周り

次はプレイヤー周りについて書いていきます。
ここではディーラーとお客側どちらもプレイヤーとします。
プレイヤーは以下のように表すことにしました。

newtype Player = Player {getCards :: [Card]} deriving Show

これだけかよ、って感じですね。 プレイヤー情報 = 今持っているカードのリスト ということになりました。

カードを一枚引く操作を定義します。

addCard :: Player -> Card -> Player
addCard (Player xs) c = Player $ c:xs

得点を計算する関数を定義します。

point :: Player -> Maybe Int
point (Player xs) =
  let
    low = calcPoint toPointOne  xs
    high = calcPoint toPointEleven xs
  in
    if low > 21 && high > 21 then Nothing
    else if high > 21 then Just low
    else Just high

さっきのcalcPointやtoPointOne, toPointElevenを使っています。
返り値がMaybeになっていますが、Nothingでバースト(21点を超えてしまい失格)を表すことにします。
あとは、A=11で計算した値がバーストしていたらA=1で計算した方を答えに、バーストしていなければA=11で計算した方を答えにしているだけです。

ゲームコントロール周り

※ここからはプレイヤー＝お客側 とします。
いいサブタイトルが思いつきませんでした。ゲーム進行に使うモナドやモナディックな操作を定義します。
山札、ディーラーの手札、プレイヤーの手札といった情報は状態と考えられるので、Stateモナドを使います。
また、ユーザーにカードを引くか勝負するかの選択をしてもらう必要や、随時メッセージを表示する必要があるので、IOモナドも使います。
バースト時などは残りの計算をスキップしてゲームを終了させたいのでExceptモナドも使います。 ということで、モナド(および状態)の定義は以下のようになりました。

data GameState = GameState {deck :: [Card],
                            dealer :: Player,
                            you :: Player}

newtype GameMonad a = GameMonad (ExceptT Result (StateT GameState IO) a) deriving (
  Functor,
  Applicative,
  Monad,
  MonadState GameState,
  MonadIO,
  MonadError Result
  )

finishGame :: Result -> GameMonad ()
finishGame = throwError

data Result = DealerWin | YouWin | YouBust | DealerBust | Draw deriving Show

エラー(=バーストなどの強制終了)を発生させるthrowErrorの別名として、わかりやすくfinishGameを定義しました。
また、ゲーム結果を表すResultを定義しています。
こちらの記事を参考にして、newtypeでモナドをラップしています。 モナドスタックの変更が容易になるということですが、実際ExceptTは後から付け足したのでとても有用でした。

初期状態を渡してこのモナドを実行し、ゲーム結果と最終状態を受け取る関数を定義します。

runGame :: GameMonad Result -> GameState -> IO (Result, GameState)
runGame (GameMonad m) s = do
    (mr, s) <- runStateT (runExceptT m) s
    case mr of
        Left r -> return (r, s)
        Right r -> return (r, s)

Left(finishGameした際)もRight(正常に実行された際)も得られる値はResultなんですよね。

最終結果を受け取ることが目的なので、GameMonad Resultな値しか実行できませんが・・・
テストのことを考えるとGameMonad aな値も実行できるような関数が必要かもしれません。

あとはゲーム中必要になるであろう操作を定義していきます。

自分の点数を取得します。(ソース中、プレイヤーのことをYouと表していますが、I/My/Meの方が適切だったかもしれません。)
バーストしている可能性があるのでやはりMaybe Intな値を返します。

yourPoint :: GameMonad (Maybe Int)
yourPoint = point . you <$> get

ディーラーの点数を取得します。

dealersPoint :: GameMonad (Maybe Int)
dealersPoint = point . dealer <$> get

カードを引きます。 プレイヤーとディーラーがそれぞれカードを引く操作も併せて定義します。
カード操作周りで定義した関数と名前が被ってしまいましたので、モジュール名をつけて対処することにします。
※カード操作周りはCardモジュール、このGameMonad周りはGameモジュールに定義されています。

pickCard :: GameMonad Card
pickCard = do
  (newCard, remainingCard) <- Cards.pickCard . deck <$> get
  modify (\s -> s {deck = remainingCard})
  return newCard

youPick :: GameMonad Card
youPick = do
  newCard <- Game.pickCard
  modify (\s -> s {you = addCard (you s) newCard})
  return newCard

dealerPicks :: GameMonad Card
dealerPicks = do
  newCard <- Game.pickCard
  modify (\s -> s {dealer = addCard (dealer s) newCard})
  return newCard

最後、勝敗判定を行います。

judge :: GameMonad Result
judge = do
  yp <-  yourPoint
  dp <- dealersPoint
  case (yp, dp) of
    (Nothing, _) -> return YouBust
    (_, Nothing) -> return DealerBust
    (Just yp, Just dp)
      | yp == dp -> return Draw
      | yp > dp -> return YouWin
      | otherwise -> return DealerWin

ゲーム本体

ゲーム本体を定義していきます。といっても前項との区別はあいまいです。

まずディーラーとプレイヤーにカードを2枚ずつ配るフェーズを定義します。

dealCard :: GameMonad ()
dealCard = do
  dealerPicks >>= liftIO . putStrLn . ("Dealer's first card is " <>) . show
  youPick >>= liftIO . putStrLn . ("Your first card is " <>) . show
  dealerPicks
  youPick >>= liftIO . putStrLn . ("Your second card is " <>) . show
  yp <- yourPoint
  dp <- dealersPoint
  case (yp, dp) of
    (Just 21, Just 21) -> (liftIO . putStrLn $ "Natural Black Jack!") >>  finishGame Draw
    (Just 21, _) -> (liftIO . putStrLn $ "Natural Black Jack!") >> finishGame YouWin
    (_, Just 21) -> (liftIO . putStrLn $ "Natural Black Jack!") >> finishGame DealerWin
    (Just yp, Just dp) -> void . liftIO . putStrLn . ("Your current point is:" <>) . show $ yp
    (_, _) -> (liftIO . putStrLn $ "Error!") >> finishGame Draw

ディーラ、プレイヤー、ディーラ、プレイヤーの順にカードを引き、２回目のディーラーのカード以外をメッセージとして表示します。
次にまず一旦得点を計算し、ナチュラルブラックジャック（初回カードのみで21点になっていること）になっていないか確認しています。
なっていればfinishGameを使い、強制終了します。
caseの最後のところは、どちらかがバーストしているパターンですが、このフェーズでは起こり得ないのでErrorと表示し引き分けにしておきます。

次に、プレイヤーがカードを引くフェーズを定義します。

yourTurn :: GameMonad ()
yourTurn = do
  liftIO . putStrLn $ "Hit(h) or Stand(s)"
  s <- liftIO  getLine
  case s of
    "h" -> do
      c <- youPick
      liftIO . putStrLn . ("You've picked " <>) . show $ c
      yp <- yourPoint
      case yp of
        Nothing -> finishGame YouBust
        Just yp -> do
          liftIO . putStrLn . ("Your current point is:" <>) . show $ yp
          yourTurn

    "s" -> return ()
     _ -> (liftIO . putStrLn $ "Input h or s") >> yourTurn

ヒット(カードを引く)ならhを、スタンド(今の手札で勝負する)ならsを入力します。
不正な入力だった場合や、ヒットしたあとはまたこのフェーズを繰り返すことになるのですが、
そこは再帰で表現することにしました。
あとバーストしてしまったらやはり強制終了です。
何も考えず再帰にしても計算がうまく合成されるのでモナドはありがたいです。

最後にプレイヤーがスタンドしたあとのディーラーがカードを引くフェーズを定義します。
ディーラーは自分の点数が17点以上になるまでカードを引き続けます。

dealersTurn :: GameMonad ()
dealersTurn = do
  dp <- dealersPoint
  case dp of
    Nothing -> finishGame DealerBust
    Just p
        | p < 17 -> dealerPicks >> dealersTurn
        | otherwise -> return ()

一番最初のフェーズでディーラーの点数を計算しているにも関わらず、また計算してしまっていますがまあそこはご愛嬌ということで・・・
やはりバースト(略)

これらのフェーズ、および勝敗判定をつなぎ合わせ、ゲーム全体を定義します。

mainGame :: GameMonad Result
mainGame = do
    dealCard
    yourTurn
    dealersTurn
    judge

並べただけっていう。
ですがゲームの状態は伝搬されるはずですし、途中でバーストなどが発生してもうまく残りの計算はスキップされるはずです。

main

最後にmain :: IO ()です

main :: IO ()
main = do
  putStrLn "welcome to Black Jack"
  shuffledDeck <- shuffleDeck cardDeck <$> getStdGen
  let initialState = GameState shuffledDeck (Player []) (Player [])
  (result, state) <- runGame mainGame initialState
  putStrLn .  (<> "!") . show $ result
  putStrLn . ("your cards:" <>) . showCards . you $ state
  putStrLn . ("dealer's cards:" <>) . showCards . dealer $ state
  where
    showCards = show . reverse . getCards

デッキをシャッフルして初期状態を構築、ゲームを実行し、勝敗結果と各々の最終手札を表示させているだけです。

感想

長い

すみません・・・
記事が長いという意味だけではなく、コードも全体で220行近くあり、ちょっと長いような気もしました。
こんなもんでしょうか

Monad便利

大域脱出したり状態を持ったりするにも関わらず、各々の小さな操作をとてもうまく合成させられた気がします。
うまく合成させられるから、操作の分割もしやすかったです。
ただ大域脱出とかContTを使ったほうが良かったんだろうか、とも思いました。

迷った

Monadが便利だとは感じつつも。まだまだ全然Haskellに慣れている気も使いこなせている気もしません。
モナドスタックを考えるときもちょっと頭ひねりました。
まあ数をこなすしかないんでしょう。

三番煎じ

本当は三番煎じどころではないのかもしれません。まあとりかかるのが遅かったので自業自得です。
Elmも勉強しているので（そして先駆者がいなさそうなので）やってみようと思います。 気力が持てばですが・・・
→ やりました