何番煎じだよって感じのネタですが,久々に Brainf*ck のコードを見かけたので,久々に書いてみたくなりました.

いきさつ

先日,builderscon in tokyo 2017 というイベントに行ってきた. そこのフリードリンクコーナーにこんな紙コップが…

一流のプログラマであれば,Brainf*ck 程度の単純な処理系ぐらい目実行しろってことだろうが,ボクは3流程度のプログラマなので,ASCIIコード表が片手にないと実行できなかった…orz

まぁ内容はわかったのだが,せっかくだから久々にサクッと書いてみようと思ったわけです.

Brainf*ck

Brainf*ck の処理系は,コードの見た目こそ気持ち悪いが非常に単純.

  • コードは8文字 ><+-.,[] だけで構成される(それ以外は無視)
  • コードを頭から一文字ずつ読んで実行していく
  • 一本の無限に長いテープ(メモリ)を考える
  • テープは全て 0 で初期化されてる
  • プログラムはテープの数値の変更や読み取りができる

といった感じ. 具体的には以下の通り(Wikipediaより).

  1. > ポインタをインクリメント,ポインタを ptr とすると,C言語の ptr++ に相当
  2. < ポインタをデクリメント,C言語の ptr-- に相当
  3. + ポインタが指す値をインクリメント,C言語の (*ptr)++ に相当
  4. - ポインタが指す値をデクリメント,C言語の (*ptr)-- に相当
  5. . ポインタが指す値を出力に書き出す,C言語の putchar(*ptr) に相当
  6. , 入力から1バイト読み込んでポインタが指す先に代入,C言語の *ptr=getchar() に相当
  7. [ ポインタが指す値が0なら対応する ] の直後にジャンプ,C言語の while(*ptr){ に相当
  8. ] ポインタが指す値が0でないなら対応する [ にジャンプ,C言語の } に相当

作る

最終的なコードはココにある.

実行機の型を考える

関数型プログラミングは,まず型から考える(自論).

前述したとおり,Brainf*ck の実行機は,プログラム列と無限に長いテープ(メモリ)があればよい. 組込みのリスト(単方向リスト)でも良いが,テープの上を前後(か左右)に移動するので双方向リストの方が良いだろう.

Haskell で双方向リストを実装するやり方はいろいろあるが,今回は便宜上以下のようにする.

data Tape a = Tape { front :: [a]
                   , current :: a
                   , back :: [a]
                   } deriving (Show)

mapCrr :: (a -> a) -> Tape a -> Tape a
mapCrr f tape = tape { current = f (current tape) }

moveFront :: Tape a -> Tape a
moveFront (Tape [] _ _) = error "front is empty."
moveFront (Tape f c b) = Tape (tail f) (head f) (c : b)

moveBack :: a -> Tape a -> Tape a
moveBack a (Tape f c []) = Tape (c : f) a []
moveBack _ (Tape f c b) = Tape (c : f) (head b) (tail b)

用意した関数は以下の3つだけ(これだけで十分だから).

  • mapCrr は現在の値にのみ,第一引数の関数 f を適用する
  • moveFront はテープのヘッダを前進させる
  • moveBack はテープのヘッダを後進させる
    • ただし,後ろへ無限に長いとするので,初期化値 a を引数で与えている

テープには数値を印字しているので,テープ(メモリ)の型は Tape Int でいいでしょう.

あと必要なのはプログラムの型. プログラムも前から順に読んでいき,[] で前後にジャンプする. つまり,Tape a 型をそのまま使えそうだ. Tape Char でも良いが,終端文字が欲しいので(冗長だが) Tape (Maybe Char) とする.

type Program = Tape (Maybe Char)

結果として実行機の型は以下のようになる.

data Machine = Machine { programOf :: Program
                       , memOf :: Tape Int
                       } deriving (Show)

初期化関数

テストするために,String -> Machine の初期化関数を先に作っておく.

initMachine :: String -> Machine
initMachine = initMachine' . flip mappend [fin] . fmap Just
  where
    initMachine' s = Machine (Tape [] (head s) (tail s)) (Tape [] 0 [])

fin :: Maybe Char
fin = Nothing

flip mappend [fin] . fmap Just は,Char 型の値を Just にラップし,空文字 "" 対策として終端文字を末尾に足している.

> prog = "+[-]"
> initMachine prog
Machine {programOf = Tape {front = [], current = Just '+', back = [Just '[',Just '-',Just ']',Nothing]}, memOf = Tape {front = [], current = 0, back = []}}

実行する関数

基本の動作は

  1. 一文字分を読み込んで
  2. 対応する処理をし
  3. 次の文字へ移動

を終端文字(Nothing)まで繰り返す.

2 の部分に IO が含まれる可能性があるので,1-3 の処理は Machine -> IO Machine となる. 特別意味はないがループ部分と処理部分を分けてみた.

run :: Machine -> IO Machine
run = loopM run' ((/=) fin . current . programOf)

loopM :: Monad m => (a -> m a) -> (a -> Bool) -> a -> m a
loopM f p a = if p a then f a >>= loopM f p else return a

run' :: Machine -> IO Machine
run' = undefined

(/=) fin . current . programOf の部分は Machine 型の値から現在見てるコードの文字が終端文字(Nothing)かどうかを判定している. loopM f p ap aFalse になるまで,f a を繰り返し適用している.

処理部分

あとは処理部分を分岐して書くだけ.

import Data.Char (chr, ord)

run' :: Machine -> IO Machine
run' m@(Machine prog mem) =
  (\m' -> m' { programOf = moveBack' $ programOf m' }) <$> cond (current prog)
  where
    cond (Just '>') = return $ Machine prog (moveBack 0 mem)
    cond (Just '<') = return $ Machine prog (moveFront mem)
    cond (Just '+') = return $ Machine prog (mapCrr (+ 1) mem)
    cond (Just '-') = return $ Machine prog (mapCrr (+ (-1)) mem)
    cond (Just '.') = return m <* putChar (chr $ current mem)
    cond (Just ',') =
      (\c -> Machine prog (mapCrr (const $ ord c) mem)) <$> getChar
    cond (Just '[') = return . flip Machine mem $
      (if current mem == 0 then jump ('[', ']') moveBack' else id) prog
    cond (Just ']') = return . flip Machine mem $
      (if current mem /= 0 then jump (']', '[') moveFront else id) prog
    cond _   = return m
    moveBack' = moveBack fin

jump :: (Char, Char) -> (Program -> Program) -> Program -> Program
jump (a, b) f = go 1
  where
    go 0 prog = prog
    go n prog = go (updateCounter (p a) (p b) (current $ f prog) n) (f prog)
    p x = (==) (Just x)

updateCounter :: (a -> Bool) -> (a -> Bool) -> a -> Int -> Int
updateCounter p q a = (+) (if p a then 1 else if q a then -1 else 0)

\m' -> m' { programOf = moveBack' $ programOf m' } が「3. 次の文字へ移動」にあたり,cond (current prog) が「1. 一文字分を読み込んで」にあたる.

cond 補助関数が 2. にあたる. [ (ないしは ])の移動は jump 関数を利用して,単純に一個ずつ前(ないしは後ろ)に移動し,対応する ] (ないしは [)を探している(そのため,対応していないと止まらない). 対応してるかどうかは go nn をカウンターとして保持している. updateCounter 関数は,そのカウンターを更新するための関数である.

Main 関数

別に要らないけど

import System.Environment (getArgs)

main :: IO ()
main = do
  [filepath] <- getArgs
  prog <- readFile filepath
  _ <- run $ initMachine prog
  putStrLn ""

実行

試しに,Wikipedia にある HelloWorld プログラムを実行してみる.

$ cat hw.bf
+++++++++[>++++++++>+++++++++++>+++++<<<-]>.>++.+++++++..+++.>-.
------------.<++++++++.--------.+++.------.--------.>+.
$ stack runghc brainfuck.hs hw.bf
Hello, world!

紙コップのやつは,まぁ,自分でやってみて.

おしまい

もっとコンパクトに書こうと思えば書けるけど,なんか綺麗なので満足. 2,3年前に書いたモノと比べると,成長した気がする(笑)