Brainfuck Interpreter

Brainfuck.hs

module Brainfuck where

import Memory
import Control.Monad
import Control.Applicative
import Data.Char
import Data.Functor

type Program = String
type Input = String
type State a = (Memory a, Input)

createState i = (newMem, i)

cmdMap = [ ('+', memInc)
         , ('-', memDec)
         , ('>', memNext)
         , ('<', memPrev)
         ]

matchBracket :: String -> (String, String)
matchBracket "" = error "Unmatched brackets"
matchBracket (']':cs) = ("", cs)
matchBracket ('[':cs) = let (start , end ) = matchBracket cs
                            (start', end') = matchBracket end
                         in ("[" ++ start ++ "]" ++ start', end')
matchBracket (c:cs) = let (start, end) = matchBracket cs 
                       in (c:start, end)

-- | Interprets the Brainfuck source code from the first argument, while
-- supplying it with input from the second. May fail on insufficient input.
interpret :: Program -> Input -> Maybe String
interpret p i = fst . interpret' p $ createState i
    where
        interpret' :: Program -> State Int -> (Maybe String, State Int)
        interpret' []       s              = (Just "", s)
        interpret' (']': _) s              = error "Unmatched brackets" --(Nothing, s)
        interpret' (',':cs) s@(_,      "") = (Nothing, s)
        interpret' ('.':cs) s@(m,       i) = (r', s')
            where f = chr . memOut
                  (r, s') = interpret' cs s
                  r' = ((f m):) <$> r
        interpret' (',':cs) s@(m, (ih:it)) = interpret' cs (f ih m, it)
            where f = memIn . ord
        interpret' ('[':cs) s              = while s
            where (start, end) = matchBracket cs
                  while s@(m, i)
                      | memOut m == 0 = interpret' end s
                      | otherwise = ((++) <$> r <*> r', s'')
                      where (r, s') = interpret' start s
                            (r', s'') = while s'
        interpret' ( c :cs) s@(m,       i)
            | Just f <- lookup c cmdMap = interpret' cs (f m, i)
            | otherwise = interpret' cs s

Memory.hs

module Memory where

type Memory a = ([a], a, [a])

type Modifier a = Memory a -> Memory a

newMem :: Memory Int
newMem = (repeat 0, 0, repeat 0)

memModifyC :: (a -> a) -> Modifier a
memModifyC f (l, c, r) = (l, f c, r)

memInc :: Enum a => Modifier a
memInc = memModifyC succ

memDec :: Enum a => Modifier a
memDec = memModifyC pred

memNext :: Enum a => Modifier a
memNext (l, c, n:r) = (c:l, n, r)

memPrev :: Enum a => Modifier a
memPrev (p:l, c, r) = (l, p, c:r)

memIn :: a -> Modifier a
memIn = memModifyC . const

memOut :: Memory a -> a
memOut (_, c, _) = c

Why not use streams for your memory (initialized with repeat 0 in both directions)? That would remove initialisation and provides only one pattern to match, which is much more efficient.

You could also participate in http://www.codewars.com/kata/my-smallest-code-interpreter-aka-brainf-star-star-k.

@muesli4 I hadn't thought of that! I'm new to "thinking lazily" :). Thanks for the Kata link!

another BF interpreter https://gist.github.com/danbst/11111085