まずは第一回を読んでください。

Stateモナド

Stateモナドは状態sを保持することができます。

newtype StateT s m a = StateT{runStateT :: s -> m (a,s)}

instance Functor m => Functor (StateT s m) where
  fmap f x = StateT $ \s -> fmap (\(a,s') -> (f a,s')) runStateT x s

instance Monad m => Applicative (StateT s m) where
  pure a = StateT $ \s -> return (a,s)
  f <*> x = StateT $ \s -> do
    (g,s1) <- runStateT f s
    (a,s2) <- runStateT x s1
    return (g a,s2)

instance Monad m => Monad (StateT s m) where
  x >>= f = StateT $ \s -> do
    (a,s1) <- runStateT x s
    runStateT (f a) s1

-- 現在の状態を取得する
get :: Monad m => StateT s m s
get = StateT $ \s -> return (s,s)

-- 現在の状態を破棄して、引数を状態で置き換える
put :: Monad m => s -> StateT s m ()
put s = StateT $ \_ -> return ((),s)

-- 現在の状態を変化させる
modify :: Monad m => (s -> s) -> StateT s m ()
modify f = get >>= put.f

プログラムとは

Brainf*ckのプログラムとは、メモリを変化させながらIO処理をおこなうものである。

type BFProgram a = StateT Memory IO a

Stateモナドで書き直し

BFを実行するrunBFを定義する

runBF :: BF -> BFProgram ()
runBF Inc = modify $ \(l,m,r) -> (l,succ m,r)
runBF Dec = modify $ \(l,m,r) -> (l,pred m,r)
runBF RShift  = modify $ \(l,m,r) ->
  if null l
    then ([],toEnum 0,m:r)
    else (tail l,head l,m:r)
runBF LShift  = modify $ \(l,m,r) ->
  if null r
    then (m:l,toEnum 0,[])
    else (m:l,head r,tail r)
runBF PutC = get >>= \(_,m,_) -> liftIO (putChar m)
runBF GetC  = liftIO getChar >>= \c -> modify $ \(l,m,r) -> (l,c,r)
runBF (Loop code) = loop where
  loop = do
    (l,m,r) <- get
    if m == toEnum 0
      then return ()
      else mapM_ runBF code >> loop

インタプリタはmapM_ :: Monad m => (a -> m b) -> [a] -> m ()を使って以下のようになります。

interpreter :: Memory -> [BF] -> IO Memory
interpreter mem xs = execStateT (mapM_ runBF xs) mem

> interpreter initMemory $ parseBF "+++++++++[>++++++++>+++++++++++>+++++<<<-]>.>++.+++++++..+++.>-.------------.<++++++++.--------.+++.------.--------.>+."
< Hello, world!

ついでにWriterモナド

ついでにgetLoopStringをWriterモナドを使って書き直します。
ループ内の文字は保持するための変数が見えなくなってちょっとスッキリ。
引数のStringも状態なので、Stateモナドで引き回しができますが、
逆にコードが煩雑になるので、引数での状態保持のままにしています。

getLoopString :: String -> Writer String String
getLoopString (']':xs) = return xs
getLoopString ('[':xs) = tell ("["++w++"]") >> getLoopString xs' where
  (xs',w) = runWriter (getLoopString xs )
getLoopString (c:xs)   = tell [c] >> getLoopString xs
getLoopString []       = fail "Unexpected end of script"

-- ループの変換処理は以下のようになる
parseBF ('[':s) = Loop (parseBF cLoop) : parseBF s' where (s',cLoop) = runWriter (getLoopString s)

ちなみにStateとWriterの両方が使いたい場合は、RWSモナドがあります。
ReaderWriterStateの頭文字です。

newtype RWST r w s m a = RWST{runRWST :: r -> s -> m (a, s, w)}

get,put,tell,askなどが同じモナド内で使えます。
ReaderT r (WriterT w (StateT s m)) aみたいなlift地獄を回避できます。

次回

parseBF :: String -> [BF]をパーサコンビネータを使って書き直します。