HaskellによるBrainfuck実装

brainfuck.hs

import Data.Char
import Control.Applicative
import Data.Maybe

data BFChar = Lt | Gt | Plus | Minus | Dot | Comma | LPar | RPar
    deriving (Eq, Show)
type BFCode = [BFChar]
type State = ([Int], Int)

operateAt :: Int -> (a -> a) -> [a] -> [a]
operateAt n f a
    | n == 0    = (f . head $ a):(tail a)
    | otherwise = (head a):(operateAt (n - 1) f (tail a))

influence :: (Int -> Int) -> State -> State
influence f (a, p) = (operateAt p f a, p)

goRight :: State -> State
goRight (a,p) = (a,p+1)

goLeft :: State -> State
goLeft (a,p) = (a,p-1)

increment :: State -> State
increment = influence (+1)

decrement :: State -> State
decrement = influence (\x -> x - 1)

ioIntAInt :: IO (Int -> Int)
ioIntAInt = do
    n <- ord <$> getChar
    return (\_ -> n)

inputChar :: State -> IO State
inputChar s = influence <$> ioIntAInt <*> (pure s)

outputChar :: State -> IO ()
outputChar (a,p) = putChar . chr $ (a !! p)

mapSnd :: (a -> b) -> (c, a) -> (c, b)
mapSnd f (c, a) = (c, f a)

separateHelp :: Int -> BFCode -> BFCode -> (BFCode, BFCode)
separateHelp n cs1 (c:cs2)
    | n == 0 && c == RPar = (cs1, cs2)
    | c == LPar = separateHelp (n + 1) cs1' cs2
    | c == RPar = separateHelp (n - 1) cs1' cs2
    | otherwise = separateHelp n cs1' cs2
    where cs1' = cs1 ++ [c]

separate :: BFCode -> (BFCode, BFCode)
separate cs = separateHelp 0 [] cs

pick :: State -> Int
pick (a, n) = a !! n

interpret :: BFCode -> State -> IO State
interpret [] s = pure s
interpret (c:cs) s
    | c == Lt    = interpret cs (goLeft s)
    | c == Gt    = interpret cs (goRight s)
    | c == Plus  = interpret cs (increment s)
    | c == Minus = interpret cs (decrement s)
    | c == Dot   = do
        outputChar s
        interpret cs s
    | c == Comma = do
        s' <- inputChar s
        interpret cs s'
    | c == LPar = do
        let (bef, aft) = separate cs
        s' <- interpret bef s
        if (pick s') == 0
            then interpret aft s'
            else interpret (LPar:cs) s'

charToBFChar :: Char -> Maybe BFChar
charToBFChar c
    | c == '>' = Just Gt
    | c == '<' = Just Lt
    | c == '+' = Just Plus
    | c == '-' = Just Minus
    | c == '.' = Just Dot
    | c == ',' = Just Comma
    | c == '[' = Just LPar
    | c == ']' = Just RPar
    | otherwise = Nothing

stringToBFCode :: String -> BFCode
stringToBFCode = catMaybes . map charToBFChar

eval :: String -> IO State
eval s = interpret (stringToBFCode s) (take 30000 (repeat 0), 0)