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

# はじめに

[前回](https://qiita.com/KNaito/items/385fb1701f70ffb8ffd4)のコードを載せてから、いくつか気になる点や不具合が見つかったので、改良・修正してみました。以前よりはだいぶすっきりした作りになったと思います。

## 不具合 ... スコアの計算

前回のコードでは、A(エース) を 1 として計算する `scoreNaive`と、A(エース)を 11 として計算する `scoreWithAce10` を比較して、後者が21以下なら後者を、そうでなければ 前者をスコアとすることで対応していました。

でもよく考えたら、A,5,A といったカードの時、二枚のエースのうち片方を1、もう片方を11として計算しなくてはらない訳で、これには対応出来ていませんでした。すみません。

そこで、次のような実装に変更しました。
まずはAを1としてナイーブな得点を計算します。次に、カードの中に1枚でもAがあれば、そのナイーブな得点より10足したものを仮の得点とします。
仮の得点が21以下なら、仮の得点を本当の得点とします。そうでなければ、最初に計算したナイーブな得点を本当の得点とするようにしました。

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

countAce :: [Card] -> Int
countAce cards =
  foldr (+) 0 $ map (\card@(Card suit num) -> if num == 1 then 1 else 0) cards

score :: [Card] -> Int
score cards =
  let s = scoreNaive cards
      c = countAce cards
  in if c > 0 && s + 10 <= 21 then s + 10 else s
```

## ゲームの状況を管理するデータ構造を導入

前回のコードでは、ゲームの処理をmain関数の中で逐次実行していました。また、メッセージも各関数の中で処理していました。これだと、あまり汎用性がなくて、例えば処理GUIアプリにしようとしても、再利用できない形式になっていたので、これをやめました。

### Phase
 まず、Phaseというデータを用意しました。

```haskell
data Phase = Phase1 | Phase2 Int | Phase3 Int | Phase4 | Phase5 Int | PhaseFinal deriving (Show, Eq)
```
Phase1〜Phase5とPhaseFinalの6段階でゲームを管理します。また、Phase 2, Phase 3, Phase5 では、さらに細かく段階を分けるために、Intが導入されています。

- Phase1 ゲーム開始
- Phase2 i 最初のカード配布処理(i=1,2はプレイヤーへのカードの配布、i=3,4はディー ラーへのカード配布)
- Phase3 i プレイヤーへの追加カード配布 (1枚ひくごとに、iが追加されていく)
- Phase4 ディーラーの2枚目のカードのopen。
- Phase5 i ディーラーへの追加カード配布 (1枚ひくごとに、iが追加されていく）
- PhaseFinal 勝敗決定。ゲーム終了

### Scene
また、デッキ、プレイヤーの手、ディーラーの手の状態をまとめて表すデータ構造として、Sceneを導入しました。

```haskell
data Scene = Scene { sceneDeck :: [Card], sceneHumanPlayer :: Player ,
                                              sceneComPlayer :: Player } deriving Show
```

### GameCondition

上記のPhaseとSceneをまとめたものとして、GameConditionを導入しました。

```haskell
data GameCondition = GameCondition { gamePhase :: Phase, gameScene :: Scene } deriving Show
```

ゲームのループ処理は、このGameConditionを次々と変化させていくことで実現しました。

## ゲームの具体的処理

### アクションの導入

ゲームを進めるために、ユーザープレイヤーおよびディーラーが追加カードを「ひく」「ひかない」がありますが、これをGameActionというデータで表現することにしました。

```haskell
data GameAction = GameActionDummy | GameActionDraw | GameActionHold deriving (Show,Eq)
```

- GameActionDraw カードを引く（ヒットする）ことを意味します
- GameActionHold カードを引かない（スタンドする）ことを意味します

また、GameActionDummyは、Phase3とPhase5以外で呼ばれる便宜上のActionです。これは何もしません。

### アクションを決定するロジックの導入

ユーザープレイヤーの場合はコマンドからの入力により、また、ディーラーの場合は現在のディーラーの手札の計算により、次のアクションをどうするかを決定します。この決定処理をgameLogic関数として実装しました

```haskell
gameLogic :: GameCondition -> IO GameAction
gameLogic condition@(GameCondition phase scene@(Scene deck humanPlayer@(Player humanName humanHands) comPlayer@(Player comName comHands))) = case phase of
    Phase3 step -> do -- human logic
      if (score humanHands) <= 21 -- バーストするまでカードをひける
        then do
              putStr "もう一枚引きますか？ (y/n):"
              i <- getLine
              if i == "y"
                then return GameActionDraw
                else return GameActionHold
        else return GameActionHold
    Phase5 step -> do -- com logic
      if (score humanHands) <= 21  -- 人間がバーストしていない時のみカードをひく
        then do
          if (score comHands) <= 16　-- 得点が16以下のときのみ、カードをひく
            then return GameActionDraw
            else return GameActionHold
        else return GameActionHold
    _ -> return GameActionDummy
```


### コントローラーの導入

現在のゲームの状態(GameCondition)と、上記のActionにより、次の状態(GameCondition)が決定します。この処理をgameController関数で処理することにしました。

```haskell
gameController :: GameCondition -> GameAction -> GameCondition
gameController condition@(GameCondition phase scene@(Scene deck humanPlayer comPlayer)) act = case phase of
    Phase1 -> GameCondition (Phase2 1) scene
    Phase2 step -> case step of
        1 -> GameCondition (Phase2 2) (Scene deck' humanPlayer' comPlayer)
              where (deck',humanPlayer') = playerDrawCard deck humanPlayer
        2 -> GameCondition (Phase2 3) (Scene deck' humanPlayer' comPlayer)
              where (deck',humanPlayer') = playerDrawCard deck humanPlayer
        3 -> GameCondition (Phase2 4) (Scene deck' humanPlayer comPlayer')
              where (deck',comPlayer') = playerDrawCard deck comPlayer
        x -> GameCondition (Phase3 1) (Scene deck' humanPlayer comPlayer')
              where (deck',comPlayer') = playerDrawCard deck comPlayer
    Phase3 step -> case act of
        GameActionDraw -> GameCondition (Phase3 (step + 1)) (Scene deck' humanPlayer' comPlayer)
              where (deck',humanPlayer') = playerDrawCard deck humanPlayer
        GameActionHold -> GameCondition Phase4 scene
    Phase4 -> GameCondition (Phase5 1) scene
    Phase5 step -> case act of
        GameActionDraw -> GameCondition (Phase5 (step + 1)) (Scene deck' humanPlayer comPlayer')
              where (deck',comPlayer') = playerDrawCard deck comPlayer
        GameActionHold -> GameCondition PhaseFinal scene
    _ -> condition
```

### ゲームのループ処理

アクションとコントローラーにより、ゲームを進めていくのは、次のように比較的汎用的に実装したgameLoop関数で行うようにしました。

```haskell
gameLoop :: (Monad m) => (gs->Bool) -> (gs -> m (gs)) -> gs -> m gs
gameLoop checker process gs = do
                          gs' <- process gs
                          let ch' = checker gs'
                          if ch'
                            then gameLoop checker process gs'
                            else return $ gs'
```

このgameLoop関数を用いて、main関数内で次のように処理しています。

```haskell
  condition' <- gameLoop gameChecker gameProcess condition
```

## ゲーム内で表示されるメッセージ

 gameLoopにより、ゲームが進められますが、その都度、前回のGameCondition、今回選んだAction、それにより変更された新しいGameConditionを引数として、ゲーム内のメッセージを管理しているgameMessage関数でメッセージを決定し、表示するようにしました。

```haskell
gameMessage :: GameAction -> GameCondition -> GameCondition -> String
gameMessage act condition@(GameCondition phase scene)
                condition'@(GameCondition phase' scene'@(Scene deck humanPlayer@(Player humanName humanHands) comPlayer@(Player comName comHands))) = case phase of
  Phase1 -> "★☆★☆★☆★☆★☆ ようこそブラックジャックへ ★☆★☆★☆★☆★☆\n"
  Phase2 step -> case step of
      1 -> messageForDraw humanName humanHands
      2 -> (messageForDraw humanName humanHands) ++ (messageForScore humanName humanHands) ++ "\n"
      3 -> messageForDraw comName comHands
      4 -> (messageForDrawHide comName comHands) ++ (messageForScoreHide comName) ++ "\n"
      _ -> ""
  Phase3 step -> if act == GameActionDraw
                        then (messageForDraw humanName humanHands) ++ (messageForScore humanName humanHands)
                        else ""
  Phase4 -> (messageForDraw' comName comHands) ++ (messageForScore comName comHands)

  Phase5 step -> if act == GameActionDraw
                        then (messageForDraw comName comHands) ++ (messageForScore comName comHands)
                        else ""
  PhaseFinal -> (let humanScore = score humanHands
                     comScore = score comHands
                   in (messageForFinalScore humanName humanHands) ++ "\n" ++
                      (messageForFinalScore comName comHands) ++ "\n" ++
                   case (humanScore,comScore) of
                                    (x,y) | x <= 21 && (y > 21 || x > y ) -> "あなたの勝ちです"
                                    (x,y) | x > 21 || y > x -> "あなたの負けです"
                                    _ -> "引き分けです"
                     ++ "\n")
```

ゲームをGUIにしたいといった場合は、おおまかに、このgameMessageと、この結果を実際に表示している処理を置き換えて（例えばアニメーション処理をするなど）やれば、改修出来るようになったのではないかと思っています。

## コード全文

以上の修正・追加を行い、コード全文は次のようになりました。

```haskell
module BlackJack 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

countAce :: [Card] -> Int
countAce cards =
  foldr (+) 0 $ map (\card@(Card suit num) -> if num == 1 then 1 else 0) cards

score :: [Card] -> Int
score cards =
  let s = scoreNaive cards
      c = countAce cards
  in if c > 0 && s + 10 <= 21 then s + 10 else s

data Phase = Phase1 | Phase2 Int | Phase3 Int | Phase4 | Phase5 Int | PhaseFinal deriving (Show, Eq)

data Scene = Scene { sceneDeck :: [Card], sceneHumanPlayer :: Player ,
                                              sceneComPlayer :: Player } deriving Show

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

data GameCondition = GameCondition { gamePhase :: Phase, gameScene :: Scene } deriving Show

data GameAction = GameActionDummy | GameActionDraw | GameActionHold deriving (Show,Eq)


playerDrawCard :: [Card] -> Player -> ([Card],Player)
playerDrawCard deck player@(Player name hands) = (deck', Player name hands')
                    where (deck',hands') = drawCard deck hands

gameController :: GameCondition -> GameAction -> GameCondition
gameController condition@(GameCondition phase scene@(Scene deck humanPlayer comPlayer)) act = case phase of
    Phase1 -> GameCondition (Phase2 1) scene
    Phase2 step -> case step of
        1 -> GameCondition (Phase2 2) (Scene deck' humanPlayer' comPlayer)
              where (deck',humanPlayer') = playerDrawCard deck humanPlayer
        2 -> GameCondition (Phase2 3) (Scene deck' humanPlayer' comPlayer)
              where (deck',humanPlayer') = playerDrawCard deck humanPlayer
        3 -> GameCondition (Phase2 4) (Scene deck' humanPlayer comPlayer')
              where (deck',comPlayer') = playerDrawCard deck comPlayer
        x -> GameCondition (Phase3 1) (Scene deck' humanPlayer comPlayer')
              where (deck',comPlayer') = playerDrawCard deck comPlayer
    Phase3 step -> case act of
        GameActionDraw -> GameCondition (Phase3 (step + 1)) (Scene deck' humanPlayer' comPlayer)
              where (deck',humanPlayer') = playerDrawCard deck humanPlayer
        GameActionHold -> GameCondition Phase4 scene
    Phase4 -> GameCondition (Phase5 1) scene
    Phase5 step -> case act of
        GameActionDraw -> GameCondition (Phase5 (step + 1)) (Scene deck' humanPlayer comPlayer')
              where (deck',comPlayer') = playerDrawCard deck comPlayer
        GameActionHold -> GameCondition PhaseFinal scene
    _ -> condition

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 ""

gameLoop :: (Monad m) => (gs->Bool) -> (gs -> m (gs)) -> gs -> m gs
gameLoop checker process gs = do
                          gs' <- process gs
                          let ch' = checker gs'
                          if ch'
                            then gameLoop checker process gs'
                            else return $ gs'

gameChecker :: GameCondition -> Bool
gameChecker condition = (stg /= PhaseFinal)
              where stg = gamePhase condition

gameMessage :: GameAction -> GameCondition -> GameCondition -> String
gameMessage act condition@(GameCondition phase scene)
                condition'@(GameCondition phase' scene'@(Scene deck humanPlayer@(Player humanName humanHands) comPlayer@(Player comName comHands))) = case phase of
  Phase1 -> "★☆★☆★☆★☆★☆ ようこそブラックジャックへ ★☆★☆★☆★☆★☆\n"
  Phase2 step -> case step of
      1 -> messageForDraw humanName humanHands
      2 -> (messageForDraw humanName humanHands) ++ (messageForScore humanName humanHands) ++ "\n"
      3 -> messageForDraw comName comHands
      4 -> (messageForDrawHide comName comHands) ++ (messageForScoreHide comName) ++ "\n"
      _ -> ""
  Phase3 step -> if act == GameActionDraw
                        then (messageForDraw humanName humanHands) ++ (messageForScore humanName humanHands)
                        else ""
  Phase4 -> (messageForDraw' comName comHands) ++ (messageForScore comName comHands)

  Phase5 step -> if act == GameActionDraw
                        then (messageForDraw comName comHands) ++ (messageForScore comName comHands)
                        else ""
  PhaseFinal -> (let humanScore = score humanHands
                     comScore = score comHands
                   in (messageForFinalScore humanName humanHands) ++ "\n" ++
                      (messageForFinalScore comName comHands) ++ "\n" ++
                   case (humanScore,comScore) of
                                    (x,y) | x <= 21 && (y > 21 || x > y ) -> "あなたの勝ちです"
                                    (x,y) | x > 21 || y > x -> "あなたの負けです"
                                    _ -> "引き分けです"
                     ++ "\n")

gameLogic :: GameCondition -> IO GameAction
gameLogic condition@(GameCondition phase scene@(Scene deck humanPlayer@(Player humanName humanHands) comPlayer@(Player comName comHands))) = case phase of
    Phase3 step -> do -- human logic
      if (score humanHands) <= 21 -- バーストするまでカードをひける
        then do
              putStr "もう一枚引きますか？ (y/n):"
              i <- getLine
              if i == "y"
                then return GameActionDraw
                else return GameActionHold
        else return GameActionHold
    Phase5 step -> do -- com logic
      if (score humanHands) <= 21  -- 人間がバーストしていない時のみカードをひく
        then do
          if (score comHands) <= 16　-- 得点が16以下のときのみ、カードをひく
            then return GameActionDraw
            else return GameActionHold
        else return GameActionHold
    _ -> return GameActionDummy

main :: IO ()
main = do
  deck <- shuffle allCards
  let humanPlayer = Player { playerName = "あなた", playerHands = [] }
  let comPlayer = Player { playerName = "ディーラー", playerHands = [] }
  let scene = Scene deck humanPlayer comPlayer
  let condition = GameCondition Phase1 scene

  let putGameMessage act condition condition' = putStrLn $ gameMessage act condition condition'

  let gameProcess = \condition ->
        do
          act <- gameLogic condition
          let condition' = gameController condition act
          putGameMessage act condition condition'
          return condition'

  condition' <- gameLoop gameChecker gameProcess condition

  putGameMessage GameActionDummy condition' condition'

  putStrLn "ブラックジャック終了！また遊んでね★"
```