Brainfuck interpreter in Haskell

Question

Okay, so I just started learning Haskell around a week ago and this is my first real program that I worked on all of yesterday with a lot of help from IRC. I know that using indicies and arrays is not very "Haskellish" but I found constantly manipulating lists and traversing them was extremely slow and sometimes the program took over 10 minutes to execute while this version is instant.

Afterwards I found you can do it with some Zipper package in 10 lines of code trivially but I didn't want to use anything too fancy.

I find that when I'm writing Haskell because there is no state I find myself simulating state with function parameters (saving variables and mutating them in a recursive call). I'm pretty sure I took it too far because most of these functions take four parameters and rarely change them but I'm not sure about many alternatives.

I haven't gotten to monads, functors, or applicatives yet, so while I'm sure they could solve this quite elegantly, they're still just magic to me. Unless the explanation is quite simple, I'd prefer if replies didn't mention them. I'm mostly looking for refactorings, style-advice, and better ways of implementing some things.

import qualified Data.Sequence as S
import Data.Char (chr, ord)
import Data.Array

-- Current Index, Indentation Depth, Program Array -> Bracket Index
prevBracketIndex :: Int -> Int -> Array Int Char -> Int
prevBracketIndex i depth cs
    | cs ! i == '[' = if (depth - 1) == 0 then i else prevBracketIndex (i - 1) (depth - 1) cs
    | cs ! i == ']' = prevBracketIndex (i - 1) (depth + 1) cs
    | otherwise = prevBracketIndex (i - 1) depth cs

nextBracketIndex :: Int -> Int -> Array Int Char -> Int
nextBracketIndex i depth cs
    | cs ! i == '[' = nextBracketIndex (i + 1) (depth + 1) cs
    | cs ! i == ']' = if (depth - 1) == 0 then i else nextBracketIndex (i + 1) (depth - 1) cs
    | otherwise = nextBracketIndex (i + 1) depth cs

execCode :: Int -> S.Seq Int -> Int -> Array Int Char -> IO ()
execCode tapePos ts codePos cs
    | codePos == (snd . bounds $ cs) = return ()
    | cmd == '+' = execCode tapePos (S.update tapePos (value + 1) ts) nextPos cs
    | cmd == '-' = execCode tapePos (S.update tapePos (value - 1) ts) nextPos cs
    | cmd == '>' = execCode (tapePos + 1) ts nextPos cs
    | cmd == '<' = execCode (tapePos - 1) ts nextPos cs
    | cmd == '[' && value == 0 = execCode tapePos ts (nextBracketIndex codePos 0 cs + 1) cs
    | cmd == ']' && value /= 0 = execCode tapePos ts (prevBracketIndex codePos 0 cs + 1) cs
    | cmd == '.' = putStr [chr $ S.index ts tapePos] >> execCode tapePos ts nextPos cs
    | cmd == ',' = do { c <- getChar; let newTape = S.update tapePos (ord c) ts in execCode tapePos newTape nextPos cs }
    | otherwise = execCode tapePos ts nextPos cs
    where value = S.index ts tapePos
          cmd = cs ! codePos
          nextPos = codePos + 1

tape = S.fromList $ replicate 30000 0

main = do
    file <- readFile "example.bf"
    execCode 0 tape 0 (listArray (0, length file - 1) file)

nponeccop · Accepted Answer · 2014-12-04 06:42:58Z

Use case instead of == and guards everywhere:

prevBracketIndex :: Int -> Int -> Array Int Char -> Int
prevBracketIndex i depth cs = case cs ! i of
    '[' -> if (depth - 1) == 0 then i else prevBracketIndex (i - 1) (depth - 1) cs
    ']' -> prevBracketIndex (i - 1) (depth + 1) cs
    _ -> prevBracketIndex (i - 1) depth cs

Use State and lens to carry state around instead of manual threading.

Use monad-loops to spin the loop instead of manual tail calls.

prevBracketIndex should avoid recursion too by using lists of indices.

Initial depth is always 0 in prevBracketIndex so it should be made local to improve readability. Also, cs is not changed across recursive calls so there is no need to pass it across. Applying both ideas:

prevBracketIndex :: Int -> Array Int Char -> Int
prevBracketIndex i cs = pbi i 0 where
    pbi i depth = case cs ! i of
        '[' -> if (depth - 1) == 0 then i else pbi (i - 1) (depth - 1)
        ']' -> pbi (i - 1) (depth + 1)
        _ -> pbi (i - 1) depth

For execCode we can do the same transformation: cs is invariant across loops, and initial positions are always 0.

Note also that prevBracketIndex can be completely precalculated (replaced by a single array lookup), as cs doesn't change.

Applying everything above but case we get:

import qualified Data.Sequence as S
import Data.Char (chr, ord)
import Data.Array
import Data.List


cachePrev cs = listArray (bounds cs) $ snd $ mapAccumL f [] $ assocs cs where
    f l (i, c) = case c of
        '[' -> (i : l, Nothing)
        ']' -> (tail l, Just $ head l)
        _ -> (l, Nothing)

cacheNext cs = listArray (bounds cs) $ snd $ mapAccumR f [] $ assocs cs where
    f l (i, c) = case c of
        ']' -> (i : l, Nothing)
        '[' -> (tail l, Just $ head l)
        _ -> (l, Just i)

cache arr i = case arr ! i of
    Nothing -> error "oops!"
    Just idx -> idx

execCode' :: S.Seq Int -> Array Int Char -> IO ()
execCode' ts cs = execCode 0 ts 0 where
    prev = cachePrev cs
    next = cacheNext cs

    execCode tapePos ts codePos
        | codePos == (snd . bounds $ cs) = return ()
        | cmd == '+' = execCode tapePos (S.update tapePos (value + 1) ts) nextPos
        | cmd == '-' = execCode tapePos (S.update tapePos (value - 1) ts) nextPos
        | cmd == '>' = execCode (tapePos + 1) ts nextPos
        | cmd == '<' = execCode (tapePos - 1) ts nextPos
        | cmd == '[' && value == 0 = execCode tapePos ts (cache next codePos + 1)
        | cmd == ']' && value /= 0 = execCode tapePos ts (cache prev codePos + 1)
        | cmd == '.' = putStr [chr $ S.index ts tapePos] >> execCode tapePos ts nextPos
        | cmd == ',' = do { c <- getChar; let newTape = S.update tapePos (ord c) ts in execCode tapePos newTape nextPos }
        | otherwise = execCode tapePos ts nextPos
        where
            value = S.index ts tapePos
            cmd = cs ! codePos
            nextPos = codePos + 1

For tests I found csFromString to be a convenient helper:

csFromString file = listArray (0, length file - 1) file

And it helps to write main in a more compact way:

main = readFile "example.bf" >>= execCode' tape . csFromString

Now let's apply the case proposal:

execCode _ _ codePos | codePos == (snd . bounds $ cs) = return ()
execCode tapePos ts codePos = case cs ! codePos of
    '+' -> execCode tapePos (S.update tapePos (value + 1) ts) nextPos
    '-' -> execCode tapePos (S.update tapePos (value - 1) ts) nextPos
    '>' -> execCode (tapePos + 1) ts nextPos
    '<' -> execCode (tapePos - 1) ts nextPos
    '[' -> if value == 0 then execCode tapePos ts (cache next codePos + 1) else execNext 
    ']' -> if value /= 0 then execCode tapePos ts (cache prev codePos + 1) else execNext
    '.' -> putStr [chr $ S.index ts tapePos] >> execNext
    ',' -> do { c <- getChar; let newTape = S.update tapePos (ord c) ts in execCode tapePos newTape nextPos }
    _ -> execNext
    where
        value = S.index ts tapePos
        nextPos = codePos + 1
        execNext = execCode tapePos ts nextPos

Now cmd is not needed anymore, and [ and ] required some additional plumbing.

Now let's remove duplication in 3 symmetrical pairs of instructions - updatePos, updateVal and branch:

execCode _ _ codePos | codePos == (snd . bounds $ cs) = return ()
execCode tapePos ts codePos = case cs ! codePos of
    '+' -> updatePos succ
    '-' -> updatePos pred
    '>' -> updateVal succ
    '<' -> updateVal pred
    '[' -> branch (== 0) next 
    ']' -> branch (/= 0) prev
    '.' -> putStr [chr $ S.index ts tapePos] >> execNext
    ',' -> do { c <- getChar; let newTape = S.update tapePos (ord c) ts in execCode tapePos newTape nextPos }
    _ -> execNext
    where
        value = S.index ts tapePos
        nextPos = codePos + 1
        execNext = execCode tapePos ts nextPos

        updatePos f = execCode tapePos (S.update tapePos (f value) ts) nextPos
        updateVal f = execCode (f tapePos) ts nextPos
        branch cond dir = if cond value then execCode tapePos ts (cache dir codePos + 1) else execNext

Now it's time to remove duplication between cachePrev and cacheNext:

mkCache cs mapAccumX bracketPush bracketPop = listArray (bounds cs) $ snd $ mapAccumX f [] $ assocs cs where
    f l (i, c) 
        | c == bracketPush = (i : l, Nothing)
        | c == bracketPop = (tail l, Just $ head l)
        | otherwise = (l, Nothing)

cache arr i = case arr ! i of
    Nothing -> error "oops!"
    Just idx -> idx

execCode' :: S.Seq Int -> Array Int Char -> IO ()
execCode' ts cs = execCode 0 ts 0 where
    prev = mkCache cs mapAccumL '[' ']'
    next = mkCache cs mapAccumR ']' '['

    execCode _ _ codePos | codePos == (snd . bounds $ cs) = return ()
    execCode tapePos ts codePos = case cs ! codePos of
        '+' -> updatePos succ
        '-' -> updatePos pred
        '>' -> updateVal succ
        '<' -> updateVal pred
        '[' -> branch (== 0) next 
        ']' -> branch (/= 0) prev
        '.' -> putStr [chr $ S.index ts tapePos] >> execNext
        ',' -> do { c <- getChar; let newTape = S.update tapePos (ord c) ts in execCode tapePos newTape nextPos }
        _ -> execNext
        where
            value = S.index ts tapePos
            nextPos = codePos + 1
            execNext = execCode tapePos ts nextPos

            updatePos f = execCode tapePos (S.update tapePos (f value) ts) nextPos
            updateVal f = execCode (f tapePos) ts nextPos
            branch cond dir = if cond value then execCode tapePos ts (cache dir codePos + 1) else execNext

Here is complete final source:

import qualified Data.Sequence as S
import Data.Char (chr, ord)
import Data.Array
import Data.List

mkCache cs mapAccumX bracketPush bracketPop = listArray (bounds cs) $ snd $ mapAccumX f [] $ assocs cs where
    f l (i, c) 
        | c == bracketPush = (i : l, Nothing)
        | c == bracketPop = (tail l, Just $ head l)
        | otherwise = (l, Nothing)

cache arr i = case arr ! i of
    Nothing -> error "oops!"
    Just idx -> idx

execCode' :: S.Seq Int -> Array Int Char -> IO ()
execCode' ts cs = execCode 0 ts 0 where
    prev = mkCache cs mapAccumL '[' ']'
    next = mkCache cs mapAccumR ']' '['

    execCode _ _ codePos | codePos == (snd . bounds $ cs) = return ()
    execCode tapePos ts codePos = case cs ! codePos of
        '+' -> updatePos succ
        '-' -> updatePos pred
        '>' -> updateVal succ
        '<' -> updateVal pred
        '[' -> branch (== 0) next 
        ']' -> branch (/= 0) prev
        '.' -> putStr [chr $ S.index ts tapePos] >> execNext
        ',' -> do { c <- getChar; let newTape = S.update tapePos (ord c) ts in execCode tapePos newTape nextPos }
        _ -> execNext
        where
            value = S.index ts tapePos
            nextPos = codePos + 1
            execNext = execCode tapePos ts nextPos

            updatePos f = execCode tapePos (S.update tapePos (f value) ts) nextPos
            updateVal f = execCode (f tapePos) ts nextPos
            branch cond dir = if cond value then execCode tapePos ts (cache dir codePos + 1) else execNext


tape = S.fromList $ replicate 30000 0

csFromString file = listArray (0, length file - 1) file

main = readFile "example.bf" >>= execCode' tape . csFromString

Note that my suggestions about monad-loops, lens and State are still to be applied.

The first step is to declare a datatype for our future state.

data M = M
    { _tapePos :: Int
    , _tape :: S.Seq Int 
    , _codePos :: Int
    }

and make inner execCode accept a single parameter.

    execCode :: M -> IO ()      
    execCode (M _ _ codePos) | codePos == (snd . bounds $ cs) = return ()
    execCode (M tapePos ts codePos) = case cs ! codePos of
        '+' -> updatePos succ
        '-' -> updatePos pred
        '>' -> updateVal succ
        '<' -> updateVal pred
        '[' -> branch (== 0) next 
        ']' -> branch (/= 0) prev
        '.' -> putStr [chr $ S.index ts tapePos] >> execNext
        ',' -> do { c <- getChar; let newTape = S.update tapePos (ord c) ts in execCode (M tapePos newTape nextPos) }
        _ -> execNext
        where
            value = S.index ts tapePos
            nextPos = codePos + 1
            execNext = execCode (M tapePos ts nextPos)

            updatePos f = execCode (M tapePos (S.update tapePos (f value) ts) nextPos)
            updateVal f = execCode (M (f tapePos) ts nextPos)
            branch cond dir = if cond value then execCode (M tapePos ts (cache dir codePos + 1)) else execNext

M stands for machine state :) and underscores are signals to Data.Lens.TH template Haskell code we will start using a bit later.

We will need a state monad transformer ran on top of IO monad. Let's declare the type of our monad stack:

type ExecT a = StateT M IO a

Our future execCode'' will be of type ExecT () instead of current M -> IO (). To execute it and discard the state (as we do now) we'll use evalStateT:

execCode' :: S.Seq Int -> Array Int Char -> IO ()
execCode' ts cs = evalStateT execCode'' (M 0 ts 0) where
    prev = mkCache cs mapAccumL '[' ']'
    next = mkCache cs mapAccumR ']' '['

    execCode'' :: ExecT ()
    execCode'' = do
        s <- get 
        lift (execCode s)

    execCode :: M -> IO ()
    execCode = ... -- unchanged

Now execCode'' is just a wrapper around our old inner execCode. And we fix execCode so it can be called directly. Note that we should do the following:

lift all IO
Replace recursive calls execCode (M ...) with put (M ...) >> execCode
move where statements around so M tapePos ts codePos is in scope
replace old termination guard with when

Here is the result:

execCode' :: S.Seq Int -> Array Int Char -> IO ()
execCode' ts cs = evalStateT execCode (M 0 ts 0) where
    prev = mkCache cs mapAccumL '[' ']'
    next = mkCache cs mapAccumR ']' '['

    execCode :: ExecT ()
    execCode = do
        M tapePos ts codePos <- get
        let value = S.index ts tapePos
        let nextPos = codePos + 1
        let execNext = put (M tapePos ts nextPos) >> execCode
        let updatePos f = put (M tapePos (S.update tapePos (f value) ts) nextPos) >> execCode 
        let updateVal f = put (M (f tapePos) ts nextPos) >> execCode
        let branch cond dir = if cond value then put (M tapePos ts (cache dir codePos + 1)) >> execCode else execNext

        when (codePos /= (snd . bounds $ cs)) $ case cs ! codePos of
            '+' -> updatePos succ
            '-' -> updatePos pred
            '>' -> updateVal succ
            '<' -> updateVal pred
            '[' -> branch (== 0) next 
            ']' -> branch (/= 0) prev
            '.' -> lift (putStr [chr $ S.index ts tapePos]) >> execNext
            ',' -> do { c <- lift getChar; let newTape = S.update tapePos (ord c) ts in put (M tapePos newTape nextPos) >> execCode } 
            _ -> execNext

Now note that all branches of case end in >> execCode. So it can be moved around to form a nice while control structure:

execCode :: ExecT ()
execCode = do
    M tapePos ts codePos <- get
    let value = S.index ts tapePos
    let nextPos = codePos + 1
    let execNext = put (M tapePos ts nextPos)
    let updatePos f = put (M tapePos (S.update tapePos (f value) ts) nextPos) 
    let updateVal f = put (M (f tapePos) ts nextPos)
    let branch cond dir = if cond value then put (M tapePos ts (cache dir codePos + 1)) else execNext

    when (codePos /= (snd . bounds $ cs)) $ do
        case cs ! codePos of
            '+' -> updatePos succ
            '-' -> updatePos pred
            '>' -> updateVal succ
            '<' -> updateVal pred
            '[' -> branch (== 0) next 
            ']' -> branch (/= 0) prev
            '.' -> lift (putStr [chr $ S.index ts tapePos]) >> execNext
            ',' -> do { c <- lift getChar; let newTape = S.update tapePos (ord c) ts in put (M tapePos newTape nextPos) } 
            _ -> execNext
        execCode

Now it's finally time for lens to shine.

{-# LANGUAGE TemplateHaskell  #-}
import Control.Lens.TH
import Control.Lens
import Control.Applicative

...

data M = M
    { _mTapePos :: Int
    , _mTape :: S.Seq Int 
    , _mCodePos :: Int
    }

$(makeLenses ''M)

type ExecT a = StateT M IO a

execCode' :: S.Seq Int -> Array Int Char -> IO ()
execCode' ts cs = evalStateT execCode (M 0 ts 0) where
    prev = mkCache cs mapAccumL '[' ']'
    next = mkCache cs mapAccumR ']' '['

    execCode :: ExecT ()
    execCode = do
        M tapePos ts codePos <- get
        let value = S.index ts tapePos
        let nextPos = codePos + 1
        let execNext = mCodePos += 1
        let updatePos f = mTape %= S.update tapePos (f value) >> execNext 
        let updateVal f = mTapePos %= f >> execNext
        let branch cond dir = if cond value then mCodePos %= succ . cache dir else execNext

        when (codePos /= (snd . bounds $ cs)) $ do
            case cs ! codePos of
                '+' -> updatePos succ
                '-' -> updatePos pred
                '>' -> updateVal succ
                '<' -> updateVal pred
                '[' -> branch (== 0) next 
                ']' -> branch (/= 0) prev
                '.' -> lift (putStr [chr $ S.index ts tapePos]) >> execNext
                ',' -> do { c <- lift getChar; mTape %= S.update tapePos (ord c) >> execNext } 
                _ -> execNext
            execCode

I did the following:

Added imports and TemplateHaskell pragma
Added a template Haskell call to generate definitions for mTapePos from _mTapePos
replaced all put calls with one or many lens-based state modifiers, joined by >>. E.g. if 2 fields of M are modified I chain 2 modifiers. If just 1 - no need to chain. Basically it's just >> execNext instead of nextPos.
removed unused nextPos

Now it turns out that branch has its own hidden execNext (note succ . in the code above):

let branch cond dir = if cond value then mCodePos %= cache dir >> execNext else execNext

So we can transform it to when easily:

let branch cond dir = when (cond value) (mCodePos %= cache dir) >> execNext

And now it turns out that >> execNext is everywhere. We can move it after case and inline:

execCode' :: S.Seq Int -> Array Int Char -> IO ()
execCode' ts cs = evalStateT execCode (M 0 ts 0) where
    prev = mkCache cs mapAccumL '[' ']'
    next = mkCache cs mapAccumR ']' '['

    execCode :: ExecT ()
    execCode = do
        M tapePos ts codePos <- get
        let value = S.index ts tapePos
        let updatePos f = mTape %= S.update tapePos (f value) 
        let updateVal f = mTapePos %= f
        let branch cond dir = when (cond value) (mCodePos %= cache dir)

        when (codePos /= (snd . bounds $ cs)) $ do
            case cs ! codePos of
                '+' -> updatePos succ
                '-' -> updatePos pred
                '>' -> updateVal succ
                '<' -> updateVal pred
                '[' -> branch (== 0) next 
                ']' -> branch (/= 0) prev
                '.' -> lift (putStr [chr $ S.index ts tapePos])
                ',' -> do { c <- lift getChar; mTape %= S.update tapePos (ord c) } 
                _ -> return ()
            mCodePos += 1
            execCode

After some more cleanup we get:

{-# LANGUAGE TemplateHaskell  #-}
import Control.Lens.TH
import Control.Lens
import Control.Applicative

import qualified Data.Sequence as S
import Data.Char (chr, ord)
import Data.Array
import Data.List
import Control.Monad.State

mkCache cs mapAccumX bracketPush bracketPop = listArray (bounds cs) $ snd $ mapAccumX f [] $ assocs cs where
    f l (i, c) 
        | c == bracketPush = (i : l, Nothing)
        | c == bracketPop = (tail l, Just $ head l)
        | otherwise = (l, Nothing)

cache arr i = case arr ! i of
    Nothing -> error "oops!"
    Just idx -> idx

data M = M
    { _mTapePos :: Int
    , _mTape :: S.Seq Int 
    , _mCodePos :: Int
    }

$(makeLenses ''M)

type ExecT a = StateT M IO a

execCode' :: S.Seq Int -> Array Int Char -> IO ()
execCode' ts cs = evalStateT execCode (M 0 ts 0) where
    prev = mkCache cs mapAccumL '[' ']'
    next = mkCache cs mapAccumR ']' '['

    execCode :: ExecT ()
    execCode = do
        M tapePos ts codePos <- get
        let value = S.index ts tapePos
        let tapeAtPos = mTape . ix tapePos
        let branch cond dir = when (cond value) (mCodePos %= cache dir)

        when (codePos /= (snd . bounds $ cs)) $ do
            case cs ! codePos of
                '+' -> tapeAtPos += 1 
                '-' -> tapeAtPos -= 1
                '>' -> mTapePos += 1
                '<' -> mTapePos -= 1
                '[' -> branch (== 0) next 
                ']' -> branch (/= 0) prev
                '.' -> lift (putChar $ chr value)
                ',' -> do { c <- lift getChar; mTape %= S.update tapePos (ord c) } 
                _ -> return ()
            mCodePos += 1
            execCode

tape = S.fromList $ replicate 30000 0

csFromString file = listArray (0, length file - 1) file

main = readFile "example.bf" >>= execCode' tape . csFromString

One more iteration of tuning for execCode' to make code more uniform which is good for readability and maintenance:

tapeAtPos is made a self-contained compound lens, without reliance on tapePos and
tapeAtPos is moved out of execState' body to global scope, and renamed to mTapeAtPos uniformly with other lenses
value is renamed tapeAtPos as it corresponds to mTapeAtPos
mTapeAtPos is used uniformly for both getting and updating the value everywhere including the getChar branch
unsafeUse helper is used to get tapeAtPos uniformly with codePos. It is called unsafe because tapeAtPos may fail if mTapePos is out of range!
lens API is used to read code uniformly with reading tape
extra parenthesis/$ are removed from when condition
M ... <- get is removed as it is not used anymore

The code:

mTapeAtPos f m = (mTape . ix (m ^. mTapePos)) f m

unsafeUse traversal = (^?! traversal) <$> get

execCode' :: S.Seq Int -> Array Int Char -> IO ()
execCode' ts cs = evalStateT execCode (M 0 ts 0) where
    prev = mkCache cs mapAccumL '[' ']'
    next = mkCache cs mapAccumR ']' '['

    execCode :: ExecT ()
    execCode = do
        tapeAtPos <- unsafeUse mTapeAtPos 
        codePos <- use mCodePos
        let branch cond dir = when (cond tapeAtPos) (mCodePos %= cache dir)
        when (codePos /= snd (bounds cs)) $ do
            case cs ^?! ix codePos of
                '+' -> mTapeAtPos += 1 
                '-' -> mTapeAtPos -= 1
                '>' -> mTapePos += 1
                '<' -> mTapePos -= 1
                '[' -> branch (== 0) next 
                ']' -> branch (/= 0) prev
                '.' -> lift (putChar $ chr tapeAtPos)
                ',' -> do { c <- lift getChar; mTapeAtPos .= ord c } 
                _ -> return ()
            mCodePos += 1
            execCode

It can be made even more uniform:

at this point tapePos is used only in branch it can be moved into branch
branch then can be moved outside of execCode as it doesn't a closure any more
it seems inner execCode is better named loop, and ExecT is LoopStateT

The code:

branch cond dir = do 
    tapeAtPos <- unsafeUse mTapeAtPos 
    when (cond tapeAtPos) (mCodePos %= cache dir)

execCode :: S.Seq Int -> Array Int Char -> IO ()
execCode ts cs = evalStateT loop (M 0 ts 0) where
    prev = mkCache cs mapAccumL '[' ']'
    next = mkCache cs mapAccumR ']' '['



    loop :: LoopStateT ()
    loop = do
        codePos <- use mCodePos
        when (codePos /= snd (bounds cs)) $ do
            case cs ^?! ix codePos of
                '+' -> mTapeAtPos += 1 
                '-' -> mTapeAtPos -= 1
                '>' -> mTapePos += 1
                '<' -> mTapePos -= 1
                '[' -> branch (== 0) next 
                ']' -> branch (/= 0) prev
                '.' -> unsafeUse mTapePos >>= lift . putChar . chr
                ',' -> lift (ord <$> getChar) >>= (mTapeAtPos .=)
                _ -> return ()
            mCodePos += 1
            loop

At this point it seems branch and ./, symmetry aren't worth it, so I inlined branch, reverted getChar branch to use do-notation and moved tapeAtPos <- to the top of loop:

    loop :: LoopStateT ()
    loop = do
        tapeAtPos <- unsafeUse mTapeAtPos
        codePos <- use mCodePos
        when (codePos /= snd (bounds cs)) $ do
            case cs ^?! ix codePos of
                '+' -> mTapeAtPos += 1 
                '-' -> mTapeAtPos -= 1
                '>' -> mTapePos += 1
                '<' -> mTapePos -= 1
                '[' -> when (tapeAtPos == 0) (mCodePos %= cache next)
                ']' -> when (tapeAtPos /= 0) (mCodePos %= cache prev)
                '.' -> lift $ putChar (chr tapeAtPos)
                ',' -> do { c <- lift getChar; mTapeAtPos .= ord c }
                _ -> return ()
            mCodePos += 1
            loop

Another improvement is better diagnostics of match failures in cache:

cache arr i = case arr ! i of
    Nothing -> error $ "No matching bracket at offset " ++ show i
    Just idx -> idx

So we get:

{-# LANGUAGE TemplateHaskell  #-}
import Control.Lens.TH
import Control.Lens
import Control.Applicative

import qualified Data.Sequence as S
import Data.Char (chr, ord)
import Data.Array
import Data.List (mapAccumR, mapAccumL)
import Control.Monad.State (lift, get, evalStateT, when, StateT(..))

mkCache cs mapAccumX bracketPush bracketPop = listArray (bounds cs) $ snd $ mapAccumX f [] $ assocs cs where
    f l (i, c) 
        | c == bracketPush = (i : l, Nothing)
        | c == bracketPop = (tail l, Just $ head l)
        | otherwise = (l, Nothing)

cache arr i = case arr ! i of
    Nothing -> error $ "No matching bracket at offset " ++ show i
    Just idx -> idx

data M = M
    { _mTapePos :: Int
    , _mTape :: S.Seq Int 
    , _mCodePos :: Int
    }

$(makeLenses ''M)

type LoopStateT a = StateT M IO a

mTapeAtPos f m = (mTape . ix (m ^. mTapePos)) f m

unsafeUse traversal = (^?! traversal) <$> get

execCode :: S.Seq Int -> Array Int Char -> IO ()
execCode ts cs = evalStateT loop (M 0 ts 0) where
    prev = mkCache cs mapAccumL '[' ']'
    next = mkCache cs mapAccumR ']' '['

    loop :: LoopStateT ()
    loop = do
        tapeAtPos <- unsafeUse mTapeAtPos
        codePos <- use mCodePos
        when (codePos /= snd (bounds cs)) $ do
            case cs ^?! ix codePos of
                '+' -> mTapeAtPos += 1 
                '-' -> mTapeAtPos -= 1
                '>' -> mTapePos += 1
                '<' -> mTapePos -= 1
                '[' -> when (tapeAtPos == 0) (mCodePos %= cache next)
                ']' -> when (tapeAtPos /= 0) (mCodePos %= cache prev)
                '.' -> lift $ putChar $ chr tapeAtPos
                ',' -> do { c <- lift getChar; mTapeAtPos .= ord c }
                _ -> return ()
            mCodePos += 1
            loop

tape = S.fromList $ replicate 30000 0

csFromString file = listArray (0, length file - 1) file

main = readFile "example.bf" >>= execCode tape . csFromString

Hey I just realized you replied to this because I had break from school. I think I lost the original account I posted this under. I just wanted to thank you for such a long and comprehensive reply. A lot of it is over my head but I will continue to reference this for years probably while I learn Haskell further. — John Smith, Commented Jan 31, 2015 at 17:49

Community · Accepted Answer · 2017-04-13 12:40:58Z

2

I'm not convinced that this interpreter works, having tried it on two ASCII table printers and a FizzBuzz, and finding that both failed to loop at all. Hello World! worked, though.

For one thing, it appears that execCode terminates prematurely: it ends before executing the last instruction in the program, not after.

Brainfuck typically has a tape whose values wrap modulo 256 (though there are also dialects with larger cells). Your cell size is just the range of the Haskell Int type, which is guaranteed to hold at least -2²⁹ ≤ Int ≤ 2²⁹ - 1, but may have a larger range. Those bounds don't guarantee to any of the common Brainfuck cell sizes.

edited Apr 13, 2017 at 12:40

CommunityBot

1

answered Nov 24, 2014 at 9:01

200_success

144k22 gold badges188 silver badges473 bronze badges

\$\begingroup\$ Thanks for the reply! Made some changes and those two examples seem to work now. Let me know if there's anything else. Conway's game of life seems to work too after checking. \$\endgroup\$
– John Smith
Commented Nov 24, 2014 at 15:52
\$\begingroup\$ What you may and may not do after receiving answers. I've rolled back your edit. \$\endgroup\$
– 200_success
Commented Nov 24, 2014 at 16:10
\$\begingroup\$ Isn't it a waste of time to have multiple people suggest the same thing and spot the same errors? All I need to change is an == to > to make those two listed programs work. \$\endgroup\$
– John Smith
Commented Nov 24, 2014 at 18:46
\$\begingroup\$ Future reviewers would probably read existing answers before writing an answer. On the other hand, fixing the code in the question in response to an answer invalidates the answer. It's like asking for help, then saying "never mind, I fixed it." \$\endgroup\$
– 200_success
Commented Nov 24, 2014 at 19:32
1

\$\begingroup\$ @nponeccop As noted on the Meta post, in our experience, allowing edits, addenda, and errata in questions leads to confusion about what code is to be reviewed. \$\endgroup\$
– 200_success
Commented Dec 2, 2014 at 1:26

| Show 1 more comment

Stack Exchange Network

Brainfuck interpreter in Haskell

2 Answers 2

Your Answer

Not the answer you're looking for? Browse other questions tagged
beginner
haskell
recursion
interpreter
brainfuck
or ask your own question.

Linked

Hot Network Questions

Brainfuck interpreter in Haskell

2 Answers 2

Your Answer

Sign up or log in

Post as a guest

Not the answer you're looking for? Browse other questions tagged beginnerhaskellrecursioninterpreterbrainfuck or ask your own question.

Linked

Related

Hot Network Questions

Not the answer you're looking for? Browse other questions tagged
beginner
haskell
recursion
interpreter
brainfuck
or ask your own question.