Haskell でノベルゲームスクリプトのようなものを作る

Haskell でノベルゲームのスクリプトのようなものを作ることを考えます．



# 素朴に考える

まず，簡単のため `text` と `line` という 2 つの命令を考えます．
`text` は 1 つの文字列を表示する命令で，`line` は発言者と発言の 2 つの文字列を表示する命令とします．

つまり，

```hs
text "今日は月曜日。"

line "Aさん" "今日は月曜日ですね。"
```

のように使われる命令となります．

## 命令をデータ型として定義する

今回のポイントは，命令をデータ型として定義してしまうことです．
次のデータ型を見てください．

```hs
data Script a = Text String (Script a)
              | Line String String (Script a)
              | Return a
```

このデータ型は `text` と `line` に対応する 2 つの値コンストラクタ `Text` と `Line`，それに加えて `Return` という値コンストラクタを持ちます．

値コンストラクタ `Text`, `Line` はおしりに `(Script a)` を持っています．即ち，再帰的な構造になっていることが解ると思います．

再帰的な構造の嬉しい点は，各命令を繋げていくことができるところです．
例えば `Return ()` は `Script ()` 型です．

```hs:ghci
ghci> :t Return ()
Return () :: Script ()
```

さらに，`Text "text" (Return ())` とすると，これも `Script ()` 型になることが解ると思います．

```hs:ghci
ghci> :t Text "text" (Return ())
Text "text" (Return ()) :: Script ()
```

これで `Text` と `Return` の 2 命令を繋ぐことができました．さらに `Line` を繋げてみます．

```hs:ghci
ghci> :t Line "chara" "line" (Text "text" (Return ()))
Line "chara" "line" (Text "text" (Return ())) :: Script ()
```

これもちゃんと `Script ()` 型になりました．
このようにして，各命令を好きな順番に，好きなだけ繋げていくことができます．ただし，`Return` 命令はおしりに `(Script a)` を持っていないので一番末尾の命令になります．

というわけで，これだけで，もう簡単なスクリプトを書くことが出来るようになりました．

```hs
script1 :: Script ()
script1 = 
  Text "ルビーよりも赤くすきとおりリチウムよりもうつくしく酔ったようになってその火は燃えているのでした。"
    (Line "ジョバンニ" "あれは何の火だろう。あんな赤く光る火は何を燃やせばできるんだろう。" 
      (Line "カムパネルラ" "蝎の火だな。"
        (Line "女の子" "あら、蝎の火のことならあたし知ってるわ。" 
          (Return ()))))
```

括弧だらけで見難いので，`$` を使って以下のように書き換えてみました．

```hs
script2 :: Script ()
script2 =
  Text "ルビーよりも赤くすきとおりリチウムよりもうつくしく酔ったようになってその火は燃えているのでした。" $
  Line "ジョバンニ" "あれは何の火だろう。あんな赤く光る火は何を燃やせばできるんだろう。" $
  Line "カムパネルラ" "蝎の火だな。" $
  Line "女の子" "あら、蝎の火のことならあたし知ってるわ。" $
  Return ()
```


## 実行用の函数を用意する

スクリプトを記述できるようになったので，それを実行する函数を用意してみましょう．

```hs
run :: Script a -> IO a
run (Return a) = return a
run (Text str next) = putStrLn str >> run next
run (Line str1 str2 next) = putStrLn (str1 ++ ": " ++ str2) >> run next
```

`next` の部分にはスクリプトの残りが入っているので，再帰的に `run` を作用させています．

スクリプトを実行してみましょう．

```hs:ghci
ghci> run script2
ルビーよりも赤くすきとおりリチウムよりもうつくしく酔ったようになってその火は燃えているのでした。
ジョバンニ: あれは何の火だろう。あんな赤く光る火は何を燃やせばできるんだろう。
カムパネルラ: 蝎の火だな。
女の子: あら、蝎の火のことならあたし知ってるわ。
```

さらにゲームっぽくするために，キーを押すと次の文章がでてくるような実装にしてみましょう．

```hs
-- 指定された文字が入力されるまで待つ
waitChar :: Char -> IO ()
waitChar c = getChar >>= \ipt ->
  if c == ipt then return () else waitChar c

-- 改行が入力されるまで待つ
waitNL :: IO ()
waitNL = waitChar '\n'

run' :: Script a -> IO a
run' (Return a) = return a
run' (Text str next) = putStrLn str >> waitNL >> run' next
run' (Line str1 str2 next) =
  putStrLn (str1 ++ ": " ++ str2) >> waitNL >> run' next
```


```hs:ghci
ghci> run' script2
ルビーよりも赤くすきとおりリチウムよりもうつくしく酔ったようになってその火は燃えているのでした。

ジョバンニ: あれは何の火だろう。あんな赤く光る火は何を燃やせばできるんだろう。

カムパネルラ: 蝎の火だな。

女の子: あら、蝎の火のことならあたし知ってるわ。

```

今回は標準出力用の函数を考えましたが，例えば GUI で画面に出力したい等の場合も `runGUI` のような専用の出力函数を作ってあげれば済みます．
このように，出力先が変わってもスクリプトに変更を加える必要はないため，入出力とゲームのロジックの分離が可能になります．



## 命令を追加する

`Text` と `Line` だけではつまらないので，もうひとつ `Choice` 命令を追加してみます．
`Choice` は選択肢を表示させ，どれが選択されたかを何らかの方法で返します．

`Choice` 命令が今までの `Text`, `Line` と異なるのは，ユーザからの入力を受け付ける点です．これはどうしたらいいでしょうか．

例えば，`Choice` で 2 つの選択肢 `["Hello!", "Hi!"]` を表示させ，そこでユーザがキーボードから入力した文字を返すだけのスクリプトを考えてみます．
すると，そのスクリプトは以下のようになってほしいわけです．

```hs
script3 :: Script Char
script3 = Choice ["Hello!", "Hi!"] (\c -> Return c)
```

ユーザからの入力をとりあえずラムダ式の引数 `c` として受け取っています．このようなことができれば，ユーザからの入力により分岐させることができるようになります．

```hs
script4 :: Script ()
script4 = 
  Line "John" "Hello!" $
  Choice ["Hello!", "Hi!"] $ \c -> case c of
    '1' -> Text "Hello!" $ Return ()
    '2' -> Text "Hi!"    $ Return ()
    _   -> Text "..."    $ Return ()
```

このときの `Choice` の型は 

```hs
Choice :: [String] -> (Char -> Script a)
```

であることがわかります．よって

```hs
data Script a = Text String (Script a)
              | Line String String (Script a)
              | Choice [String] (Char -> Script a)
              | Return a
```

となりました．これで本当にうまくいくのか試してみましょう．まずは `run` 函数に `Choice` に対する実装を与えます．

```hs
run :: Script a -> IO a
run (Return a) = return a
run (Text str next) = putStrLn str >> run next
run (Line str1 str2 next) = putStrLn (str1 ++ ": " ++ str2) >> run next
run (Choice strs g) = do
  print strs
  ch <- getChar
  putChar '\n'
  run (g ch)
```

`Choice strs g` の `g` は `Char -> Script a` という型を持つので，`Char` を与えると残りのスクリプトを返す函数になっています．
即ち `next = g ch` です．

実行してみましょう．

```hs:ghci
ghci> run script4
John: Hello!
["Hello!","Hi!"]
1
Hello!

ghci> run script4
John: Hello!
["Hello!","Hi!"]
2
Hi!

ghci> run script4
John: Hello!
["Hello!","Hi!"]
a
...
```

`run'` の方も似たような実装でいいでしょう．

```hs
run' :: Script a -> IO a
run' (Return a) = return a
run' (Text str next) = putStrLn str >> waitNL >> run' next
run' (Line str1 str2 next) =
  putStrLn (str1 ++ ": " ++ str2) >> waitNL >> run' next
run' (Choice strs g) = do
  print strs
  ch <- getChar
  putChar '\n'
  run' (g ch)
```

今回は `Choice [String] (Char -> Script a)` としましたが，`Char` ではなく `Int` で処理したい，等のときは `Choice [String] (Int -> Script a)` としてもよいでしょう．

また，`Choice` は実際に分岐を行っているわけではなく，選択肢の表示とユーザ入力の値を返すことしかやっていないことに注意してください．
スクリプト上で分岐やループ，変数への束縛などを行う場合，それらの機能を実装する必要はなく，Haskell の機能を使えばよいということです．


# モナドを使って書き直す

さて，これで `Text`, `Line`, `Choice` の 3 命令を使えるスクリプトを書けるようになりましたが，モナドを使うとより簡単にスクリプトが書けるようになります．

いままで使ってきた

```hs
data Script a = Text String (Script a)
              | Line String String (Script a)
              | Choice [String] (Char -> Script a)
              | Return a
```

というデータ型ですが，実はこれはモナドのインスタンスになることができます．

ということで，実際にモナドのインスタンスにしてみました．

```hs
instance Monad Script where
  return = Return
  Text str next >>= f = Text str $ next >>= f
  Line str1 str2 next >>= f = Line str1 str2 $ next >>= f
  Choice strs g >>= f = Choice strs $ \c -> (g c >>= f)
  Return a >>= f = f a
```

`(>>=)` の実装は，基本的に `next` の部分に再帰的に `(>>=)` を適用していっているだけになっています．


## スクリプトをモナドの記法で書く

さて，モナドにすると何が嬉しいかというと，`(>>)` や `do` 記法を使ってスクリプトが書けるようになります．
今までのスクリプトをモナドを使って書き換えてみましょう．

簡単なものからいきましょう．例えば次のスクリプト

```hs
script5 :: Script ()
script5 = Line "chara" "line" (Text "text" (Return ()))
```

をモナドの記法を使って書いてみましょう．

2 つの命令 `Line` と `Text` を `(>>=)` でつなげることが出来ないか考えてみます．
モナドのインスタンスにした時の実装

```hs
Line str1 str2 next >>= f = Line str1 str2 $ next >>= f
```

の `next` に例えば `Return ()` を入れてみると，

```hs
Line str1 str2 (Return ()) >>= f = Line str1 str2 $ (Return ()) >>= f 
```

となります．ここで，`Return a >>= f = f a` であるので

```hs
Line str1 str2 (Return ()) >>= f = Line str1 str2 $ f ()
```

であることがわかります．ここで，

```hs
f = \_ -> Text "text" (Return ())
```

とおけば

```hs
Line str1 str2 (Return ()) >>= (\_ -> Text "text" (Return ())) 
  = Line str1 str2 $ Text "text" (Return ())
```

となります．ここで，`x >>= \_ -> y` は `x >> y` と書くことができるので

```hs
Line str1 str2 (Return ()) >> Text "text" (Return ()) 
  = Line str1 str2 $ Text "text" (Return ())
```

となりました．即ち

```hs
script5 :: Script ()
script5 = Line "chara" "line" (Text "text" (Return ()))
```

は

```hs
script6 :: Script ()
script6 = Line "chara" "line" (Return ()) >> Text "text" (Return ())
```

と書き換えることができます．
さらに do 記法を使うと

```hs
script7 :: Script ()
script7 = do
  Line "chara" "line" $ Return ()
  Text "text" $ Return ()
```

と書けます．また `return = Return` なので `Return` を `return` に書き換えることも出来ます．
いちいち `return` を書くのは面倒なので，次のような函数を定義してしまいましょう．

```hs
text :: String -> Script ()
text str = Text str $ return ()

line :: String -> String -> Script ()
line str1 str2 = Line str1 str2 $ return ()

choice :: [String] -> Script Char
choice strs = Choice strs $ \c -> return c
```

これらの函数を使うことで

```hs
script8 :: Script ()
script8 = do
  line "chara" "line"
  text "text"
```

のように簡潔に書くことができるようになりました．もはや `Return` も不要なのがわかります．

他の例も見てみましょう．

```hs
script9 :: Script ()
script9 = do
  text "ルビーよりも赤くすきとおりリチウムよりもうつくしく酔ったようになってその火は燃えているのでした。"
  line "ジョバンニ" "あれは何の火だろう。あんな赤く光る火は何を燃やせばできるんだろう。"
  line "カムパネルラ" "蝎の火だな。"
  line "女の子" "あら、蝎の火のことならあたし知ってるわ。"
```



```hs
script10 :: Script ()
script10 = do
  line "John" "Hello!"
  c <- choice ["Hello!", "Hi!"]
  case c of
    '1' -> text "Hello!"
    '2' -> text "Hi!"
    _   -> text "..."
```


これでとりあえず目標は達成できました．

# ソースコード全文

```hs
data Script a = Text String (Script a)
              | Line String String (Script a)
              | Choice [String] (Char -> Script a)
              | Return a

instance Monad Script where
  return = Return
  Text str next >>= f = Text str $ next >>= f
  Line str1 str2 next >>= f = Line str1 str2 $ next >>= f
  Choice strs g >>= f = Choice strs $ \c -> (g c >>= f)
  Return a >>= f = f a

text :: String -> Script ()
text str = Text str $ return ()

line :: String -> String -> Script ()
line str1 str2 = Line str1 str2 $ return ()

choice :: [String] -> Script Char
choice strs = Choice strs $ \c -> return c


run :: Script a -> IO a
run (Return a) = return a
run (Text str next) = putStrLn str >> run next
run (Line str1 str2 next) = putStrLn (str1 ++ ": " ++ str2) >> run next
run (Choice strs f) = do
  print strs
  ch <- getChar
  putChar '\n'
  run (f ch)

waitChar :: Char -> IO ()
waitChar c = getChar >>= \ipt ->
  if c == ipt then return () else waitChar c

waitNL :: IO ()
waitNL = waitChar '\n'

run' :: Script a -> IO a
run' (Return a) = return a
run' (Text str next) = putStrLn str >> waitNL >> run' next
run' (Line str1 str2 next) =
  putStrLn (str1 ++ ": " ++ str2) >> waitNL >> run' next
run' (Choice strs f) = do
  print strs
  ch <- getChar
  putChar '\n'
  run' (f ch)


script1 :: Script ()
script1 = 
  Text "ルビーよりも赤くすきとおりリチウムよりもうつくしく酔ったようになってその火は燃えているのでした。"
    (Line "ジョバンニ" "あれは何の火だろう。あんな赤く光る火は何を燃やせばできるんだろう。" 
      (Line "カムパネルラ" "蝎の火だな。"
        (Line "女の子" "あら、蝎の火のことならあたし知ってるわ。" 
          (Return ()))))

script2 :: Script ()
script2 =
  Text "ルビーよりも赤くすきとおりリチウムよりもうつくしく酔ったようになってその火は燃えているのでした。" $
  Line "ジョバンニ" "あれは何の火だろう。あんな赤く光る火は何を燃やせばできるんだろう。" $
  Line "カムパネルラ" "蝎の火だな。" $
  Line "女の子" "あら、蝎の火のことならあたし知ってるわ。" $
  Return ()

script3 :: Script Char
script3 = Choice ["Hello!", "Hi!"] (\c -> Return c)

script4 :: Script ()
script4 = 
  Line "John" "Hello!" $
  Choice ["Hello!", "Hi!"] $ \c -> case c of
    '1' -> Text "Hello!" $ Return ()
    '2' -> Text "Hi!"    $ Return ()
    _   -> Text "..."    $ Return ()

script5 :: Script ()
script5 = Line "chara" "line" (Text "text" (Return ()))

script6 :: Script ()
script6 = Line "chara" "line" (Return ()) >> Text "text" (Return ())

script7 :: Script ()
script7 = do
  Line "chara" "line" $ Return ()
  Text "text" $ Return ()

script8 :: Script ()
script8 = do
  line "chara" "line"
  text "text"

script9 :: Script ()
script9 = do
  text "ルビーよりも赤くすきとおりリチウムよりもうつくしく酔ったようになってその火は燃えているのでした。"
  line "ジョバンニ" "あれは何の火だろう。あんな赤く光る火は何を燃やせばできるんだろう。"
  line "カムパネルラ" "蝎の火だな。"
  line "女の子" "あら、蝎の火のことならあたし知ってるわ。"

script10 :: Script ()
script10 = do
  line "John" "Hello!"
  c <- choice ["Hello!", "Hi!"]
  case c of
    '1' -> text "Hello!"
    '2' -> text "Hi!"
    _   -> text "..."
```

# あとがき

知っている方は気づいたと思いますが，実はわざわざ `Script` をモナドにせずとも Free モナドや Operational モナドというものを使えば以上のことが簡単に実現できます．

Free モナドは，次のように再帰的な構造をとっています．

```hs
data Free f a = Pure a | Free (f (Free f a))
```

この `f` に例えば今回の `Script` のようなものを突っ込んであげることでデータ型をモナドとして扱うことが出来るようになるわけです．ただし，データ型はファンクターである必要があります．

Free モナドを使った実装は次のようになると思います．

```hs
{-# LANGUAGE DeriveFunctor #-}

data Free f a = Pure a | Free (f (Free f a))

instance Functor f => Monad (Free f) where
  return = Pure
  Pure a >>= f = f a
  Free m >>= f = Free (fmap (>>= f) m)

liftF :: Functor f => f a -> Free f a
liftF = Free . fmap return


data Script a = Text String a
              | Line String String a
              | Choice [String] (Char -> a)
  deriving (Functor)

text :: String -> Free Script ()
text str = liftF $ Text str ()

line :: String -> String -> Free Script ()
line str1 str2 = liftF $ Line str1 str2 ()

choice :: [String] -> Free Script Char
choice strs = liftF $ Choice strs id

run :: Free Script a -> IO a
run (Pure a) = return a
run (Free (Text str next)) = putStrLn str >> run next
run (Free (Line str1 str2 next)) = putStrLn (str1 ++ ": " ++ str2) >> run next
run (Free (Choice strs f)) = do
  print strs
  ch <- getChar
  putChar '\n'
  run (f ch)

script :: Free Script ()
script = do
  line "John" "Hello!"
  c <- choice ["Hello!", "Hi!"]
  case c of
    '1' -> text "Hello!"
    '2' -> text "Hi!"
    _   -> text "..."
```

Free モナドは自分で作らなくても Hackage に [The free package](http://hackage.haskell.org/package/free) などがあります．

本当は Free モナドや更にすごい Operational モナド等についてももう少し詳しく書きたかったのですが，気力がもうありませんでした．

# 参考
[Haskell for all: Why free monads matter](http://www.haskellforall.com/2012/06/you-could-have-invented-free-monads.html)