BrainF*ckインタプリタを作る（４）

今日で最後だ。のこりの命令「[」と「]」を実装した。

「[」と「]」を実装するには命令の列を行ったり来たりできなきゃいけない。はじめに考えたのは BrainF_ck と同じように，命令のリストと現在位置を示すポインタを持ったデータ型を定義することだった。
けど，考え直して文字列のペアで代用することにした。これを次のように操作する。

• 初期状態では，１番目の文字列は空。全て２番目に入っている。
• １つ命令を実行するごとに，２番目の文字列から１番目の文字列へ１文字移動する。スキップするには必要な数だけ移動。
• ２番目の文字列が空になったらプログラム終了。
• ループで戻るときには，２番目から１番目へ文字を移動する。

で，実装はこのとおり。

type Program = ([Char], [Char])

progNew :: String -> Program
progNew str = ([], str)

progFetch :: Program -> [Char]
progFetch prog = snd prog

progShift :: Program -> Program
progShift (l, (r:rs)) = (l ++ [r], rs)

progUnshift :: Program -> Program
progUnshift (l, r) = (take ((length l) -1) l, (last l):r)

progSkip :: BrainF_ck -> Program -> Program
progSkip bf prog = if bfValue bf == 0 then skip prog else progShift prog
  where skip p = if (head $ progFetch next) == ']' then next else skip next
          where next = progShift p

progBack :: BrainF_ck -> Program -> Program
progBack bf prog = if bfValue bf == 0 then progShift prog else back prog
  where back p = if (head $ progFetch prev) == '[' then prev else back prev
          where prev = progUnshift p

でもって，プログラムを走らせる関数 bfRun を導入（前回までは foldM を使っていた）して，main も書き換えた。

bfRun :: BrainF_ck -> Program -> IO BrainF_ck
bfRun bf prog = run $ progFetch prog
  where run [] = return bf
        run (c:cs) | c == '[' = bfRun bf (progSkip bf prog)
                   | c == ']' = bfRun bf (progBack bf prog)
                   | otherwise = do next <- bfEvaluate bf c
bfRun next (progShift prog)

main :: IO BrainF_ck
main = do filename <- getArgs >>= return . head
          prog <- readFile filename >>= ((return . progNew) . concat) . lines
          bfRun bfInitial prog

さらに。いままで入出力を整数でやっていたけど，これを文字に変更する。まぁ文字<->整数（文字コード）の変換だけだけど。

import Data.Char

bfInput :: BrainF_ck -> IO BrainF_ck
bfInput bf = do let p = bfPointer bf
                let r = bfRegister bf
                putStr "\ninput? ";
                c <- getChar
                return $ BF p ((take p r) ++ [ord c] ++ (tail $ drop p r))

bfPrint :: BrainF_ck -> IO BrainF_ck
bfPrint bf = do putChar $ chr $ bfValue bf
                return bf

これでできあがりのはずだ。さっそく試してみよう。
実行するプログラムは当初の目標，HelloWorld。

>type hello.bf
++++++++++[>+++++++>++++++++++>+++>+<<<<-]>++.>+.+++++++..+++.>++.<<
+++++++++++++++.>.+++.------.--------.>+.>.
>runghc hbf.hs hello.bf
Hello World!

OK!!!!!!!!!!!!!!!!

いろいろと制限もあるけど，とにかく目標は達成。これ以上はまた気が向いたらってことで。
以下，全体を示しておく。

module Main where

import System
import Monad
import Data.Char

data BrainF_ck = BF { bfPointer :: Int, bfRegister :: [Int] } deriving (Show)

type Program = ([Char], [Char])

bfInitial :: BrainF_ck
bfInitial = BF { bfPointer = 0, bfRegister = [0,0,0,0,0,0,0,0,0,0] }

bfValue :: BrainF_ck -> Int
bfValue bf = (bfRegister bf) !! (bfPointer bf)

bfIncrement :: BrainF_ck -> BrainF_ck
bfIncrement (BF p v) = BF p ((take p v) ++ [(v !! p) + 1] ++ (tail $ drop p v))

bfDecrement :: BrainF_ck -> BrainF_ck
bfDecrement (BF p v) = BF p ((take p v) ++ [(v !! p) - 1] ++ (tail $ drop p v))

bfShift :: BrainF_ck -> BrainF_ck
bfShift (BF p v) = BF (p+1) v

bfUnshift :: BrainF_ck -> BrainF_ck
bfUnshift (BF p v) = BF (p-1) v

bfInput :: BrainF_ck -> IO BrainF_ck
bfInput bf = do let p = bfPointer bf
                let r = bfRegister bf
                putStr "\ninput? "
                c <- getChar
                return $ BF p ((take p r) ++ [ord c] ++ (tail $ drop p r))

bfPrint :: BrainF_ck -> IO BrainF_ck
bfPrint bf = do putChar $ chr $ bfValue bf
                return bf

bfEvaluate :: BrainF_ck -> Char -> IO BrainF_ck
bfEvaluate bf '+' = return $ bfIncrement bf
bfEvaluate bf '-' = return $ bfDecrement bf
bfEvaluate bf '>' = return $ bfShift bf
bfEvaluate bf '<' = return $ bfUnshift bf
bfEvaluate bf '.' = bfPrint bf
bfEvaluate bf ',' = bfInput bf

progNew :: String -> Program
progNew str = ([], str)

progFetch :: Program -> [Char]
progFetch prog = snd prog

progShift :: Program -> Program
progShift (l, (r:rs)) = (l ++ [r], rs)

progUnshift :: Program -> Program
progUnshift (l, r) = (take ((length l) -1) l, (last l):r)

progSkip :: BrainF_ck -> Program -> Program
progSkip bf prog = if bfValue bf == 0 then skip prog else progShift prog
  where skip p = if (head $ progFetch next) == ']' then next else skip next
          where next = progShift p

progBack :: BrainF_ck -> Program -> Program
progBack bf prog = if bfValue bf == 0 then progShift prog else back prog
  where back p = if (head $ progFetch prev) == '[' then prev else back prev
          where prev = progUnshift p

bfRun :: BrainF_ck -> Program -> IO BrainF_ck
bfRun bf prog = run $ progFetch prog
  where run [] = return bf
        run (c:cs) | c == '[' = bfRun bf (progSkip bf prog)
                   | c == ']' = bfRun bf (progBack bf prog)
                   | otherwise = do next <- bfEvaluate bf c
                                    bfRun next (progShift prog)

main :: IO BrainF_ck
main = do filename <- getArgs >>= return . head
          prog <- readFile filename >>= ((return . progNew) . concat) . lines
          bfRun bfInitial prog