Haskellで書くBrainfuckインタープリタ







注意: Haskellerの方は, 私のコードを見る前に自分で実装したほうが, 気持ちがよく分かると思います. 頑張って下さい. 自分で実装したのと, 私のコードを比べてみてください!!!













HaskellBrainfuckインタープリタ書きました.

-- Brainfuck interpreter in Haskell
import Data.Char (chr, ord)
import Control.Monad (void)
import Control.Arrow (first, app, (***), (>>>))

data BF = Incr | Decr | Next | Prev | Put | Get | While [BF]
type State = ([Int], Int, [Int])

(<>>) :: a -> ([a], b) -> ([a], b)
(<>>) = first . (:)

parse :: String -> [BF]
parse = fst . parse'
  where
    parse' :: String -> ([BF], String)
    parse' ('+':bs) = Incr <>> parse' bs
    parse' ('-':bs) = Decr <>> parse' bs
    parse' ('>':bs) = Next <>> parse' bs
    parse' ('<':bs) = Prev <>> parse' bs
    parse' ('.':bs) = Put <>> parse' bs
    parse' (',':bs) = Get <>> parse' bs
    parse' ('[':bs) = app $ ((<>>) . While *** parse') (parse' bs)
    parse' (']':bs) = ([], bs)
    parse' (_:bs)   = parse' bs
    parse' []       = ([], [])

run :: [BF] -> IO ()
run = void . flip run' ([], 0, [])
  where
    run' :: [BF] -> State -> IO State
    run' (Incr:bs) (xs, x, ys)    = run' bs (xs, x + 1, ys)
    run' (Decr:bs) (xs, x, ys)    = run' bs (xs, x - 1, ys)
    run' (Next:bs) (xs, x, [])    = run' bs (x:xs, 0, [])
    run' (Next:bs) (xs, x, y:ys)  = run' bs (x:xs, y, ys)
    run' (Prev:bs) s@([] , _, _)  = run' bs s
    run' (Prev:bs) (x:xs, y, ys)  = run' bs (xs, x, y:ys)
    run' (While _:bs) s@(_, 0, _) = run' bs s
    run' bbs@(While bs:_) s       = run' bs s >>= run' bbs
    run' (Put:bs) s@(_, x, _)     = putChar (chr x) >> run' bs s
    run' (Get:bs) (xs, _, ys)     = getChar >>= \x -> run' bs (xs, ord x, ys)
    run' [] s                     = return s

main :: IO ()
main = readFile "hello.bf" >>= (parse >>> run)
~$ echo "+++++++++[>++++++++>+++++++++++>+++++<<<-]>.>++.+++++++..+++.>-.------------.<++++++++.--------.+++.------.--------.>+." > hello.bf 
~$ runhaskell bf.hs 
Hello, world!%  
~$ 

(%記号は改行なしのアレ)



自分で言うのもなんだけど, コードが美しい...

「ifなしletなしswitchなし」は基本ですね.

これ以上に美しいコードが書けた人は, 勉強したいので教えてほしいです.

解説

main :: IO ()
main = readFile "hello.bf" >>= (parse >>> run)

これは, 次のコードと同じです.

main :: IO ()
main = do
  code <- readFile "hello.bf"
  run (parse code)

(>>>)は, (<<<)の逆で, (<<<)は(.)と同じです.
Control.Categoryの中で定義されていますが, Control.Arrowで再エクスポートされています.
上のコードのように, (>>=)と親和性がいいと思います.

data BF = Incr | Decr | Next | Prev | Put | Get | While [BF]
--         +     -     >      <      .     ,     [  ]

Brainfuckのコードの「素」を定義します.

data BF = Incr | Decr | Next | Prev | Put | Get | WhileStart | WhileEnd
--         +     -     >      <      .     ,     [            ]

という方法もあります.
こちらはコードに近くてパースはしやすいのですが, 実行しにくい形です.

type State = ([Int], Int, [Int])

ポインターの状態を表します.
(左, 今, 右)としました.
ポインター全体は, (reverse 左 ++ [今] ++ 右)となります.

data State = State { tape :: [Word8], pos :: Int }

みたいにすることもできますが, リストだとアクセスが遅い→Arrayにするか→めんどくさ...
的な, いつものあれなので.

あと, (左, 今, 右)とできるのは, Brainfuckで突然「絶対位置10の場所にジャンプ」とかが無く, 必ずすぐ左かすぐ右にしか動かないからですね.

(<>>) :: a -> ([a], b) -> ([a], b)
(<>>) = first . (:)

parse :: String -> [BF]
parse = fst . parse'
  where
    parse' :: String -> ([BF], String)
    parse' ('+':bs) = Incr <>> parse' bs
    parse' ('-':bs) = Decr <>> parse' bs
    parse' ('>':bs) = Next <>> parse' bs
    parse' ('<':bs) = Prev <>> parse' bs
    parse' ('.':bs) = Put <>> parse' bs
    parse' (',':bs) = Get <>> parse' bs
    parse' ('[':bs) = app $ ((<>>) . While *** parse') (parse' bs)
    parse' (']':bs) = ([], bs)
    parse' (_:bs)   = parse' bs
    parse' []       = ([], [])

Haskellの特徴である, 演算子を定義できるのを使ってみました.
例えば,

    parse' ('+':bs) = Incr <>> parse' bs

    parse' ('+':bs) = first (Incr:) $ parse' bs

と, さらに,

    parse' ('+':bs) = let (b, s) = parse' bs in (Incr:b, s)

と同じです.

'['のコードも, Arrowに慣れていないと意味不明ですよね.

    parse' ('[':bs) = app $ ((<>>) . While *** parse') (parse' bs)

は, 元に戻すと

    parse' ('[':bs) = let (b, s) = parse' bs in While b <>> parse' s

と同じで, 更に

    parse' ('[':bs) = let (b, s) = parse' bs 
                          (b', s') = parse' s
                          in (While b:b', s')

と同じです.

    parse' (_:bs)   = parse' bs

変な文字が入っていたら, それをスキップします.
スペースとか改行とかよく入っているので...

    parse' []       = ([], [])

終了条件. 大事.



次はrunを見てみましょう.

run :: [BF] -> IO ()
run = void . flip run' ([], 0, [])

これは,

run code = run' code ([], 0, []) >> return ()

と同じですね. ただ, ghc-modに怒られてしまうので, voidを使ってみました.

    run' :: [BF] -> State -> IO State
    run' (Incr:bs) (xs, x, ys)    = run' bs (xs, x + 1, ys)
    run' (Decr:bs) (xs, x, ys)    = run' bs (xs, x - 1, ys)

テープの現在の値に, 足したり引いたりします.

    run' (Next:bs) (xs, x, [])    = run' bs (x:xs, 0, [])
    run' (Next:bs) (xs, x, y:ys)  = run' bs (x:xs, y, ys)
    run' (Prev:bs) s@([] , _, _)  = run' bs s
    run' (Prev:bs) (x:xs, y, ys)  = run' bs (xs, x, y:ys)

ポインターを動かします.
ここでは, テープの長さは決め打ちせずに, 必要に応じて長くなるようになっています.
また, 本当なら負の領域にアクセスしたらダメなんですが, そういうことをやりだすとコードが汚くなっていくので, 左端に壁があるものとしました.

    run' (While _:bs) s@(_, 0, _) = run' bs s
    run' bbs@(While bs:_) s       = run' bs s >>= run' bbs

Whileループの実行です.
メモリーの今の位置の値が0なら, Whileをすっぽかして次のコードを実行します.
そうでなければ, Whileループの中を一回実行して, その結果の状態をまた判定します.

    run' (Put:bs) s@(_, x, _)     = putChar (chr x) >> run' bs s
    run' (Get:bs) (xs, _, ys)     = getChar >>= \x -> run' bs (xs, ord x, ys)

Putは出力, Getは入力ですね.
それぞれchr, ordを使ってIntと変換します.

    run' [] s                     = return s

終了条件. 大事.


改めてコードを見てみると, やはりコード全体が引き締まって見えますね.
ああ美しい.

インタープリタならデータ構造作らなくていいんじゃ

という説もありますが, やはりコードの上を行ったり来たりするのはアホらしいです.
特に, [ と ] の間は, いちいち「対応するカッコに(進む|戻る)」関数を書かなくてはならないので...
まぁ実際書いてみたら, 40行を切って, 一番上のコードより短くなったんですけどね.
でも汚いです.

ループのパースをどうやるか

上記のコードにたどり着くまで, ちょっとだけ時間がかかりました.

イメージしてください. Brainfuckのコードから, 再帰的な構造 While [BF] を作るタスクです.

パースする関数は, おそらく

parse :: String -> [BF]

でしょう.
完璧なコードしか入ってこないものとし, parse error, invalid codeとかは無いとします*1.

最初に思いつくのはこんな感じではないでしょうか.

parse ('[':bs) = let s = takeToMatchBracket bs
                     in While (parse s) : opps.....
takeToMatchBracket :: String -> String

対応するカッコまでの文字を持ってくる... あ, 残りも要りますがな...

parse ('[':bs) = let (l, r) = splitToMatchBracket bs
                     in While (parse l) : parse r
splitToMatchBracket :: String -> (String, String)

これに満足して, 実装しだしたら, 泥沼ですね. 最悪です.

何がダメかというと, コードの上を何度も舐めることになるからです.

もし, Brainfuckのコードが

+[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[-]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]

みたいなのだったらどうなるか, 想像付きますね?
splitToMatchBracket関数で最後まで舐めて, splitして, 更に切り出したものをparseに掛けます.
こんなアホらしいことやる人いませんね.



コードの上は一回舐めればいいはずです.
一回舐めたらBFの再帰的構造

data BF = Incr | Decr | Next | Prev | Put | Get | While [BF]

を作れるはずです.

どうすればいいのでしょうか.




ひとつの答えが, (結果, 未処理文字列)です.

    --        コード -> (結果, 未処理)
    parse' :: String -> ([BF], String)

こうしておくと, トップレベルのparse関数は

parse code = let (result, rest) = parse' code
                 in result

で,

parse code = fst (parse' code)

となり,

parse = fst . parse'

となることが分かりますね. (ただし, 入力がすべてvalidなコードとします)


では, parse'関数を書いてみましょう.
やはり, よくある再帰処理になります.

    parse' ('+':bs) = let (result, rest) = parse' bs
                          in (Incr : result, rest)

こんな感じですね.
しかし, 同様に書いていくと

    parse' ('+':bs) = let (result, rest) = parse' bs
                          in (Incr : result, rest)
    parse' ('-':bs) = let (result, rest) = parse' bs
                          in (Decr : result, rest)
    parse' ('>':bs) = let (result, rest) = parse' bs
                          in (Next : result, rest)
    parse' ('<':bs) = let (result, rest) = parse' bs
                          in (Prev : result, rest)
    parse' ('.':bs) = let (result, rest) = parse' bs
                          in (Put : result, rest)
    parse' (',':bs) = let (result, rest) = parse' bs
                          in (Get : result, rest)

とかなって, なんか嫌です.
同じ部分は関数にしましょう.

    parse' ('+':bs) = f Incr bs
    parse' ('-':bs) = f Decr bs
    parse' ('>':bs) = f Next bs
    parse' ('<':bs) = f Prev bs
    parse' ('.':bs) = f Put bs
    parse' (',':bs) = f Get bs
    f b bs = let (result, rest) = parse' bs
                 in (b : result, rest)

ええ, ましになりました.

ただ, Arrowを一度知った身としては, 「, rest)」のあたりが気になってしょうがありません.
まず, fからlet inを取り除きます.

    f b bs = first (b:) $ parse' bs

ここで, 一歩立ち止まります.
「fを演算子にしたらもっとかっこよくなるんじゃ?」
「でもparse'なんてものが入っているのを演算子とかにしたくないなぁ...」
「もっと一般的な部分を取り出して...」


というわけで, 一歩戻ります.

    parse' ('+':bs) = f Incr bs
    f b bs = let (result, rest) = parse' bs
                 in (b : result, rest)

要は, bをfstに入れ込むことがしたいのです.

    parse' ('+':bs) = f Incr bs
    f b bs = (\(l, r) -> (b:l, r)) (parse' bs)

そうか, parse'までfに入れなくていいんだ.

    parse' ('+':bs) = f Incr (parse' bs)
    f b bs = (\(l, r) -> (b:l, r)) bs

fを演算子にして

(<>>) :: a -> ([a], b) -> ([a], b)
(<>>) b (l, r) = (b:l, r)

    parse' ('+':bs) = Incr <>> parse' bs

おお, カッコいい!!!


記号は基本的になんでもいいので, 「右のタプルに入れ込む」みたいな気持ちを込めて(<>>)にしてみました.

ここで, 悪魔がささやきます.
「これ, Arrowで書いたらモテるんじゃね?」

firstを使って

(<>>) b (l, r) = first (b:) (l, r)

η変換して

(<>>) b = first (b:)

或いは

(<>>) b = first $ ((:) b)

($) を (.) に置き換えて

(<>>) b = first . (:) $ (b)

η変換して

(<>>) = first . (:)

完成.

バッチリです.

これで気になるあの娘も落とせそうですね.




さて,

    --        コード -> (結果, 未処理)
    parse' :: String -> ([BF], String)

の形にしたのは, ループのパースのためでした.
取り敢えず, ループの最後は

    parse' (']':bs) = ([], bs)

と書くことができます.
ループの最後に到達したら, 取り敢えずそれまでも[BF]の結果を返してあげて, 残りのコードは未処理とするのです.

ではループの最初はどうするかというと,

    parse' ('[':bs) = let (result, rest) = parse' bs
                          in ...

この段階で, resultには括弧中の結果が, restには未処理のコードが入ります.
従って, restをまたparse'で処理して

    parse' ('[':bs) = let (result, rest) = parse' bs
                          (result', rest') = parse' rest
                          in (While result : result', rest')

が正解ですね.



すぐ分かるように, While result : の部分は, さっきも見た「タプルのfstの要素の最初に追加する系」です.
従って,

    parse' ('[':bs) = let (result, rest) = parse' bs
                          in While result <>> parse' rest

となります.


しかし, Arrow病を発病すると, こんなタプルでさえ耐えられなくなってきます.
とにかく変換します.

    parse' ('[':bs) = let (result, rest) = parse' bs
                          in (((<>>) . While) result) (parse' rest)

(result, rest)が引数となるような関数をArrowで作ります. (f a) (g b) == app $ (f *** g) (a, b)ですね. (app :: (b -> c, b) -> c ですよ!)

    parse' ('[':bs) = let (result, rest) = parse' bs
                          in app $ (((<>>) . While) *** parse') (result, rest)

そうするとlet inを消すことができて

    parse' ('[':bs) = app $ (((<>>) . While) *** parse') (parse' bs)

さらに, (.)の優先度は9, (***)の優先度は3なので, 括弧がひとつ不要です.

    parse' ('[':bs) = app $ ((<>>) . While *** parse') (parse' bs)


こうやって一番最初のコードにたどり着いたのです.


Arrowを知ってたらコードの流れがよく分かりますね.
「appで適用して... *** は上と下に並行して適用して...」


まとめ

言いたいことは, Arrowバンザイではなくて, 妥協して効率の悪いプログラムを書くな, ですね.
Whileのために, 入力のコードの上を何度も行ったり来たりするのなんて馬鹿げてますよね.
そんな効率の悪いコード, C言語じゃ書かないでしょう?
Haskellだから許される, ではありません.
型を考えなさい, それが良い処方箋ですね.


ところで, Brainfuckインタープリタは, なんかいつ書いても飽きないですね.
あと, parse'やrun'をfoldrか何かを使って書こうとしたけど失敗したので, 誰かやっておいてください. できるかどうかしらんけど.

追記(2012/12/24)

最近fmapの有用性に気がついたのですが, 上に書いた(<>>)は, (<$>)で書けることに気が付きました.
Functor ((,) a)なので, タプルを逆にしなきゃいけないんですけどね.

import Data.Functor ((<$>))
import Control.Monad.Instances

parse :: String -> [BF]
parse = snd . parse'
  where
    parse' :: String -> (String, [BF])
    parse' ('+':bs) = (Incr:) <$> parse' bs
    parse' ('-':bs) = (Decr:) <$> parse' bs
    parse' ('>':bs) = (Next:) <$> parse' bs
    parse' ('<':bs) = (Prev:) <$> parse' bs
    parse' ('.':bs) = (Put:) <$> parse' bs
    parse' (',':bs) = (Get:) <$> parse' bs
    parse' ('[':bs) = app $ (flip (<$>) . parse' *** (:) . While) (parse' bs)
    parse' (']':bs) = (bs, [])
    parse' (_:bs)   = parse' bs
    parse' []       = ([], [])

*1:つまりパーサー的な失敗系にする必要がない. [なしの]は, そこで打ち切り, ]なしの[は, 最後にマッチする]を加えたのと同様に動きます.