Haskell
初心者
初心者向け
Blackjack

初心者卒業試験のブラックジャック作成に挑戦してみました(Haskell編)

はじめに

Qiitaのプログラミング入門者からの卒業試験は『ブラックジャック』を開発すべしを読んで、ふむふむなるほど、ブラックジャックが初心者向け課題として非常に面白いな〜と思いたち、プログラミングに挑戦してみました。一応、ちゃんと動作するようになったと思います。

ブラックジャックのルールなどは、上記リンクを参照ください。Aを1もしくは11として扱います。スピリットやダブルダウンなどは考えていません。

プログラミング言語はHaskellです。まだまだ勉強中で未熟ですが、今の時点での地力を残すという意味でも記事にしてみました。

** 2018/05/06追記 この記事の続編をこちらに書きました。

工夫したところ

なるべく純粋関数で書いて、IOを伴う処理はMonadで、、、と意識していたのですが、なかなか思うように実装出来ずに苦労しました。

カードについて

カードの処理は、最初いろいろやってたのですが、結局のところこちらの記事を参考にさせてもらいました。ほぼ丸写しですが、これが分かりやすかったので、、、
カードは、マークについてはEnumで、数はIntで1,2,3,...,13として扱い、表示時にA,J,Q,Kにしました。

data Suit = Spades | Hearts | Clubs | Diamonds deriving Enum

instance Show Suit where
  show Spades = "スペード"
  show Hearts = "ハート"
  show Clubs = "クラブ"
  show Diamonds = "ダイア"

data Card = Card { suit :: Suit, num :: Int }

instance Show Card where
  show Card { suit = s, num = n } = (show s) ++ "の" ++ rank
    where rank = case n of
                  11 -> "J"
                  12 -> "Q"
                  13 -> "K"
                  1  -> "A"
                  x  -> (show $ x)

デッキを作るのは、内包表記とか使えば分かりやすくて良かったのですが、そういった便利な方法を知らなかったため、foldrmapを組み合わせました。こちらの方が汎用性もあるので、これがいいかなと。

allCards = foldr (++) [] $ map (\x -> map (\y -> Card { suit = x, num = y }) [1..13]) [Hearts ..]

カードのシャッフルについて

カードのシャッフルのみ、乱数を使うため、唯一 main関数以外でIOの処理が入っています。(あ、後述するwhileMもmonad使ってますね、、、)

shuffle :: [a] -> IO [a]
shuffle [] = return []
shuffle list = do
  n <- getStdRandom $ randomR (0, length list - 1) :: IO Int
  list2 <- shuffle $ take n list ++ drop (n+1) list
  return $ (list !! n) : list2

この関数は、こちらで載ってたものをそのまま採用させていただきました。シンプルで分かりやすい!

が、よく考えたら、ランダム関数を外から与えてシャッフルする方が汎用性が高かったかもしれないですね。そうすればこの関数もIOに依存しなくなりますし、、。でも、これはこれでシンプルで良い感じなので、とりあえずこのまま使います。

得点の計算について

これは単純に、Aを1として計算するのと、Aを11として計算するのを両方行い、前者が21を超えていたら後者を採用するということにしました。(元記事に書いてある通りです)

scoreNaive :: [Card] -> Int
scoreNaive cards =
  foldr (+) 0 $ map (\card ->
    let n = num card in if n <= 10 then n else 10
    ) cards

scoreWithAce10 :: [Card] -> Int
scoreWithAce10 cards =
  foldr (+) 0 $ map (\card ->
    let n = num card in case n of
                          1 -> 11
                          x | x <= 10 -> x
                          _ -> 10
    ) cards

score :: [Card] -> Int
score cards =
  let s1 = scoreNaive cards
      s2 = scoreWithAce10 cards
  in if s2 > 21 then s1 else s2

プレイヤーについて

元記事 ではC#なので、プレイヤーを親クラスとして実装し、ユーザープレイヤーとディーラー(コンピュータプレイヤー)をその子クラスとして実装することが提唱されていました。
Haskellは関数型言語なので、クラスを作る代わりに、プレイヤーをレコード型で次のように宣言しました。

data Player = Player { playerName :: String,
                       playerHands :: [Card] }

また、プレイヤーの共通機能である「カードを一枚めくる」機能をplayerDrawCard関数としてくくり出しました。

playerDrawCard :: Bool -> [Card] -> Player -> ([Card], Player, String)
playerDrawCard flagShow deck player =
  let
    name = playerName player
    hands = playerHands player
    (newDeck, newHands) = drawCard deck hands
    message = if flagShow then (messageForDraw name newHands) ++ "\n" ++ (messageForScore name newHands) ++ "\n"
                          else (messageForDrawHide name newHands) ++ "\n" ++ (messageForScoreHide name) ++ "\n"
  in (newDeck, Player { playerName = name, playerHands = newHands}, message )

この関数は、めくったカードを表示するかどうかのフラグと、デッキ、そしてプレイヤーを引数にとります。そして、工夫した点としては、この関数自体は純粋関数とし、戻り値に、めくった結果表示されるべき文字列を含ませるようにしました。

実際にめくる時は、めくった結果を表示する必要があるため、純粋関数ではなくなってしまいます。(正格に言えば純粋関数ですが、IO monadを扱う関数になってしまう)それらは、main関数内で定義した次を呼ぶようにしました。

  let playerDrawCardWithMessage = \(deck, player) -> do
      let (deck', player', message) = playerDrawCard True deck player
      putStrLn message
      return (deck', player')

  let playerDrawCardWithMessage' = \(deck, player) -> do
      let (deck', player', message) = playerDrawCard False deck player
      putStrLn message
      return (deck', player')

上がめくったカードを表示する関数で、下がめくったカードを表示しない関数(ディーラーの2枚目のカードをめくる時にだけ使用)です。

プレイヤーの追加のカードのめくる処理について

ここが、今回一番工夫した点(!)ですが、ユーザープレイヤー、ディーラーともに、特定の条件を満たすまでカードをめくりつづける処理です。その条件は、

  • ユーザー:バーストするか、「もう一枚引きますか?(y/n)」の問いでnを選択するまで
  • ディーラー:バーストするか、得点が17以上になるまで

となっており、特にユーザーの方は入力を伴うので、IOが必要になります。それで結構悩んだのですが、結局のところ、条件を満たすまで繰り返す次の関数whileMを定義して、条件はユーザー、ディーラーごとに与えることで解決しました。

whileM :: (Monad m) => (a -> m a) -> a -> (a -> (m Bool)) -> m a
whileM f ini checker  = do
  b <- checker ini
  if b
    then f ini >>= \y -> whileM f y checker
    else return ini

引数は、「繰り返す関数」「初期値」「条件」です。いわゆるJavaやRubyなどのwhile文みたい機能が欲しくて実装しました。(すでにありそうなメソッド名ですね、、。)

これを使って、ユーザーがカードを引いていく処理は

  (deck, humanPlayer) <- whileM playerDrawCardWithMessage
      (deck, humanPlayer) $ \(deck, player) -> do
      if checkBust $ score $ playerHands player
        then return False
        else do
          putStr "もう一枚引きますか? (y/n):"
          s <- getLine
          if "Y" == map toUpper s
            then return True
            else putStrLn "" >> return False

となり、ディーラーがカードを引いていく処理は

  (deck, comPlayer) <- whileM playerDrawCardWithMessage
       (deck, comPlayer) $ \(deck, player) -> do
         let s = score $ playerHands player
         if checkBust s
           then return False
           else do
             if s <= 16
               then return True
               else return False

のようにまとめられました。
最初の頃、この辺の処理がすごく長くなってしまい、しかも、ユーザーとディーラーで共通部分をうまくまとめられず同じようなコードが続いてしまっていたのですが、なんども書き直して、ようやくこの形になりました。

プログラム全文

module Card where

import Control.Monad
import System.Random
import Data.Char

data Suit = Spades | Hearts | Clubs | Diamonds deriving Enum

instance Show Suit where
  show Spades = "スペード"
  show Hearts = "ハート"
  show Clubs = "クラブ"
  show Diamonds = "ダイア"

data Card = Card { suit :: Suit, num :: Int }

instance Show Card where
  show Card { suit = s, num = n } = (show s) ++ "の" ++ rank
    where rank = case n of
                  11 -> "J"
                  12 -> "Q"
                  13 -> "K"
                  1  -> "A"
                  x  -> (show $ x)

allCards = foldr (++) [] $ map (\x -> map (\y -> Card { suit = x, num = y }) [1..13]) [Hearts ..]

shuffle :: [a] -> IO [a]
shuffle [] = return []
shuffle list = do
  n <- getStdRandom $ randomR (0, length list - 1) :: IO Int
  list2 <- shuffle $ take n list ++ drop (n+1) list
  return $ (list !! n) : list2

drawCard :: [a] -> [a] -> ([a],[a])
drawCard deck cards =
  let x:xs = deck
    in (xs, cards ++ [x])

scoreNaive :: [Card] -> Int
scoreNaive cards =
  foldr (+) 0 $ map (\card ->
    let n = num card in if n <= 10 then n else 10
    ) cards

scoreWithAce10 :: [Card] -> Int
scoreWithAce10 cards =
  foldr (+) 0 $ map (\card ->
    let n = num card in case n of
                          1 -> 11
                          x | x <= 10 -> x
                          _ -> 10
    ) cards

score :: [Card] -> Int
score cards =
  let s1 = scoreNaive cards
      s2 = scoreWithAce10 cards
  in if s2 > 21 then s1 else s2

data Player = Player { playerName :: String,
                       playerHands :: [Card] }

messageForDraw :: String -> [Card] -> String
messageForDraw name cards =
  name ++ " " ++ (show num) ++ "枚目のカードは" ++ (show newCard) ++ "です。"
    where newCard = last cards
          num = length cards

messageForDraw' :: String -> [Card] -> String
messageForDraw' name cards =
  name ++ " " ++ (show num) ++ "枚目のカードは" ++ (show newCard) ++ "でした"
    where newCard = last cards
          num = length cards

messageForDrawHide :: String -> [Card] -> String
messageForDrawHide name cards =
  name ++ " " ++ (show num) ++ "枚目のカードは秘密です。"
    where num = length cards

messageForScore :: String -> [Card] -> String
messageForScore name cards =
 name ++ "の現在の得点は" ++ (show $ score cards) ++ "です。"

messageForScoreHide :: String -> String
messageForScoreHide name =
 name ++ "の現在の得点は秘密です。"

messageForFinalScore :: String -> [Card] -> String
messageForFinalScore name cards =
  name ++ "の得点は" ++ (show $ score cards) ++ "です。" ++ bust
    where bust = if (score cards) > 21 then (name ++ "はバーストしました") else ""

playerDrawCard :: Bool -> [Card] -> Player -> ([Card], Player, String)
playerDrawCard flagShow deck player =
  let
    name = playerName player
    hands = playerHands player
    (newDeck, newHands) = drawCard deck hands
    message = if flagShow then (messageForDraw name newHands) ++ "\n" ++ (messageForScore name newHands) ++ "\n"
                          else (messageForDrawHide name newHands) ++ "\n" ++ (messageForScoreHide name) ++ "\n"
  in (newDeck, Player { playerName = name, playerHands = newHands}, message )

whileM :: (Monad m) => (a -> m a) -> a -> (a -> (m Bool)) -> m a
whileM f ini checker  = do
  b <- checker ini
  if b
    then f ini >>= \y -> whileM f y checker
    else return ini

data GameStatus = YouWin | YouLose | DrawGame | Playing

main :: IO()
main = do
  putStrLn "★☆★☆★☆★☆★☆ ようこそブラックジャックへ ★☆★☆★☆★☆★☆"
  deck <- shuffle allCards
  let humanPlayer = Player { playerName = "あなた", playerHands = [] }
  let comPlayer = Player { playerName = "ディーラー", playerHands = [] }

  let playerDrawCardWithMessage = \(deck, player) -> do
      let (deck', player', message) = playerDrawCard True deck player
      putStrLn message
      return (deck', player')

  let playerDrawCardWithMessage' = \(deck, player) -> do
      let (deck', player', message) = playerDrawCard False deck player
      putStrLn message
      return (deck', player')

  (deck, humanPlayer) <- playerDrawCardWithMessage (deck, humanPlayer)

  (deck, humanPlayer) <- playerDrawCardWithMessage (deck, humanPlayer)

  (deck, comPlayer) <- playerDrawCardWithMessage (deck, comPlayer)

  (deck, comPlayer) <- playerDrawCardWithMessage' (deck, comPlayer)

  let checkBust = \s -> s > 21

  (deck, humanPlayer) <- whileM playerDrawCardWithMessage
      (deck, humanPlayer) $ \(deck, player) -> do
      if checkBust $ score $ playerHands player
        then return False
        else do
          putStr "もう一枚引きますか? (y/n):"
          s <- getLine
          if "Y" == map toUpper s
            then return True
            else putStrLn "" >> return False

  putStrLn $ (messageForDraw' (playerName comPlayer) (playerHands comPlayer)) ++ "\n"
    ++ (messageForScore (playerName comPlayer) (playerHands comPlayer)) ++ "\n"

  let humanScore = score $ playerHands humanPlayer
  (deck, comPlayer) <-
    if humanScore > 21
      then return $ (deck, comPlayer)
      else whileM playerDrawCardWithMessage
       (deck, comPlayer) $ \(deck, player) -> do
         let s = score $ playerHands player
         if checkBust s
           then return False
           else do
             if s <= 16
               then return True
               else return False

  result <- case humanScore of
              x | 21 < x -> return $ YouLose
              _ -> do
                let comScore = score $ playerHands comPlayer
                case comScore of
                  x | 21 < x -> return $ YouWin
                  x | humanScore < x -> return $ YouLose
                  x | humanScore > x -> return $ YouWin
                  otherwise -> return $ DrawGame
  putStrLn $ messageForFinalScore (playerName humanPlayer) (playerHands humanPlayer)
  putStrLn $ messageForFinalScore (playerName comPlayer) (playerHands comPlayer)
  case result of
    YouWin -> putStrLn "あなたの勝ちです!\n"
    YouLose -> putStrLn "あなたの負けです!\n"
    otherwise -> putStrLn "引き分けです!\n"
  putStrLn "ブラックジャック終了!また遊んでね★"
  return ()

あとがき

ブラックジャックの実装は、単純なFizzBuzzの計算などと違って、ゲーム性がある課題なので、プログラミングが俄然楽しくなりますね。Haskellらしいバインドがあまり使えなかってないので、もっと使えるように精進したいです。