brainfuck.hs

{-# LANGUAGE BangPatterns #-}

module Main where

import qualified Data.IntMap as IM
import Data.Char (chr, ord)
import Data.Array

type State = (Int, IM.IntMap Int)
data Dir =  Up | Down

interpret :: String -> IO ()
interpret inp = fn 0 (0, IM.fromList $ zip [0..] (replicate 100000 0)) where
    fn :: Int -> State -> IO ()
    fn i (pd, dat)
        | i == length inp = return ()
        | x == '>' = fn (succ i) (succ pd, dat)
        | x == '<' = fn (succ i) (pred pd, dat)
        | x == '+' = fn (succ i) (pd, update succ)
        | x == '-' = fn (succ i) (pd, update pred)
        | x == '.' = putChar (chr $ dat IM.! pd) >> fn (succ i) (pd, dat)
        | x == ',' = getChar >>= \c -> fn (succ i) (pd, update (const (ord c)))
        | x == '[' && dat IM.! pd == 0 = fn (succ (matchUp IM.! i)) (pd, dat)
        | x == '[' = fn (succ i) (pd, dat)
        | x == ']' = fn (matchDn IM.! i) (pd, dat)
        | otherwise = fn (succ i) (pd, dat)
        where instrs = listArray (0, length inp - 1) inp
              x = instrs !i
              update fn = IM.update (Just . fn) pd dat
              matchUp = buildTable Up '[' instrs
              matchDn = buildTable Down ']' instrs

buildTable dir start instrs = IM.fromList
    [(p, matchBrackets dir instrs p) | p <- [0 .. snd $ bounds instrs], instrs !p == start]

matchBrackets :: Dir -> Array Int Char -> Int -> Int 
matchBrackets Up instrs p = m (succ p) 0 where
    m p depth
        | instrs !p == '[' = m (succ p) (depth + 1)
        | instrs !p == ']' = if depth == 0 then p else m (succ p) (depth - 1)
        | otherwise = m (succ p) depth
matchBrackets Down instrs p = m (pred p) 0 where
    m p depth
        | instrs !p == ']' = m (pred p) (depth + 1)
        | instrs !p == '[' = if depth == 0 then p else m (pred p) (depth - 1)
        | otherwise = m (pred p) depth
        
main = getContents >>= interpret

This should be useful: Monad Transformers Step by Step.