今日で最後だ。のこりの命令「[」と「]」を実装した。
「[」と「]」を実装するには命令の列を行ったり来たりできなきゃいけない。はじめに考えたのは 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