6
\$\begingroup\$

I wrote a BrainF*** interpretter in Haskell. A general review would be helpful and especially, a suggestion with a better way to deal with the IO (IO Memory, IO ()) would be helpful.

import Data.Either
import Data.List
import Data.Char
import System.Environment
import System.IO

type Program = [Instruction]

data Instruction = Lft
            | Rgt
            | Inc
            | Dec
            | Nop
            | Loop Program
            | Out
            | Inp
            deriving Eq

data Memory = Memory [Int] [Int]

emptyMem :: Memory
emptyMem = Memory [] [0]

parse :: String -> Program
parse xs = go xs []
   where
      go :: String -> [Either Char Instruction] -> Program
      go "" is      = reverse $ rights is
      go ('[':xs) is   = go xs ((Left '['):is)
      go (']':xs) is   = go xs ((Right l):l2)
         where
            (l1, (_:l2)) =  span (/= Left '[') is
            l = Loop $ (rights.reverse) l1
      go ('>':xs) is   = go xs (Right Rgt:is)
      go ('<':xs) is   = go xs (Right Lft:is)
      go ('+':xs) is   = go xs (Right Inc:is)
      go ('-':xs) is   = go xs (Right Dec:is)
      go ('.':xs) is   = go xs (Right Out:is)
      go (',':xs) is   = go xs (Right Inp:is)

runInstruction :: Memory -> Instruction -> IO (IO Memory, IO ())
runInstruction mem Nop = return (return mem, return ())
runInstruction (Memory xs (y:[])) Rgt = return (return (Memory (y:xs) [0]), return ())
runInstruction (Memory xs (y:ys)) Rgt = return (return (Memory (y:xs) ys), return ())
runInstruction (Memory (x:xs) ys) Lft = return (return (Memory xs (x:ys)), return ())
runInstruction (Memory [] ys) Lft = return (return (Memory [] (0:ys)), return ())
runInstruction (Memory xs (y:ys)) Inc = return (return (Memory xs ((y+1):ys)), return ())
runInstruction (Memory xs (y:ys)) Dec = return (return (Memory xs ((y-1):ys)), return ())
runInstruction mem@(Memory _ (x:xs)) Out = return (return mem, putChar (chr x))
runInstruction (Memory xs (y:ys)) Inp = return (mem', return ())
                                          where mem' = getChar >>= \z -> return (Memory xs ((ord z):ys))
runInstruction mem@(Memory xs (0:ys)) (Loop _) = return (return mem, return ())
runInstruction mem (Loop prog) = do
                                    (mem1, act') <- runProgram mem prog
                                    mem' <- mem1
                                    (mem'', act'') <- runInstruction mem' (Loop prog)
                                    return (mem'', act' >> act'')



runProgram :: Memory -> Program -> IO (IO Memory, IO ())
runProgram mem [] = return (return mem, return ())
runProgram mem (i:is) = do
                           (mem1, act1) <- runInstruction mem i
                           mem' <- mem1
                           (mem2, act2) <- runProgram mem' is
                           return (mem2, act1 >> act2)

main :: IO ()
main = do
   hSetBuffering stdin NoBuffering 
   (fileName:_) <- getArgs
   prog <- readFile fileName
   (mem, act) <- runProgram emptyMem (parse (filter (`elem` "[]+-><.,") prog))
   act
\$\endgroup\$
  • \$\begingroup\$ You can substitute return (mem2, act1 >> act2) with (,) <$> mem2 <*> (act1 >> act2) to get IO (Memory, ()). Is this what you wanted? \$\endgroup\$ – arrowd Jun 9 '17 at 6:22
2
\$\begingroup\$

First of all, good job. Now, what can we improve? Let's start with the largest function first, runInstruction:

runInstruction :: Memory -> Instruction -> IO (IO Memory, IO ())
runInstruction mem Nop = return (return mem, return ())
runInstruction (Memory xs (y:[])) Rgt = return (return (Memory (y:xs) [0]), return ())
runInstruction (Memory xs (y:ys)) Rgt = return (return (Memory (y:xs) ys), return ())
runInstruction (Memory (x:xs) ys) Lft = return (return (Memory xs (x:ys)), return ())
runInstruction (Memory [] ys) Lft = return (return (Memory [] (0:ys)), return ())
runInstruction (Memory xs (y:ys)) Inc = return (return (Memory xs ((y+1):ys)), return ())
runInstruction (Memory xs (y:ys)) Dec = return (return (Memory xs ((y-1):ys)), return ())
runInstruction mem@(Memory _ (x:xs)) Out = return (return mem, putChar (chr x))
runInstruction (Memory xs (y:ys)) Inp = return (mem', return ())
                                          where mem' = getChar >>= \z -> return (Memory xs ((ord z):ys))
runInstruction mem@(Memory xs (0:ys)) (Loop _) = return (return mem, return ())
runInstruction mem (Loop prog) = do
                                    (mem1, act') <- runProgram mem prog
                                    mem' <- mem1
                                    (mem'', act'') <- runInstruction mem' (Loop prog)
                                    return (mem'', act' >> act'')

"Memory" handling

Almost all of those functions concern Memory, which isn't obvious. That's because your included all Memory functionality into runInstruction. If you follow that model, you can never use Memory in any other context.

So instead let us write some other functions:

moveRight   :: Memory -> Memory
moveLeft    :: Memory -> Memory
getValue    :: Memory -> Int
setValue    :: Int -> Memory -> Int
modifyValue :: (Int -> Int) -> Memory -> Memory

Instead of data Memory = Memory [Int] [Int], we're going to use

data Memory = Memory [Int] Int [Int]

That way we will always have a current value. The initial empty memory is the same as yours, except for the pivot value

emptyMemory = Memory [] 0 []

and moving left or right stays mostly the same:

moveRight (Memory []     v rs) = Memory [] 0 (v:rs)
moveRight (Memory (l:ls) v rs) = Memory ls l (v:rs)
moveLeft (Memory ls v [])     = Memory (v:ls) 0 []
moveLeft (Memory ls v (r:rs)) = Memory (v:ls) r rs

getValue (Memory _ v _ )       = v
setValue v                     = modifyValue (const v)
modifyValue f (Memory ls v rs) = Memory ls (f v) rs

What's nice about those functions is that we can easily check them with QuickCheck or other testing frameworks, since they are all pure. For example, we can check that

prop_set_get x mem = getValue (setValue x mem)   == x
prop_set_set x mem = setValue (setValue x mem)   == (setValue x mem)
prop_get_set   mem = setValue (getValue mem) mem == mem

This is hard to check with your current variant.

By the way your variant was completely opaque whether the left or the right list would provide the pivot element. Our new Memory makes sure that we cannot do it wrong, and that v in Memory _ v _ always exists.

How does runInstruction look with those changes?

runInstruction :: Memory -> Instruction -> IO (IO Memory, IO ())
runInstruction mem Nop = return (return mem, return ())
runInstruction mem Rgt = return (return (moveRight mem), return ())
runInstruction mem Lft = return (return (moveLeft  mem), return ())
runInstruction mem Inc = return (return (modifyValue succ mem), return ())
runInstruction mem Dec = return (return (modifyValue pred mem), return ())
runInstruction mem Out = return (return mem, putChar (chr (getValue mem)))
runInstruction mem Inp = return (mem'      , return ())
                           where mem' = getChar >>= \z -> return (setValue (const z) mem)
runInstruction mem (Loop prog)
  | getValue mem == 0 = return (return mem, return ())
  | otherwise         = do
                        (mem1, act') <- runProgram mem prog
                        mem' <- mem1
                        (mem'', act'') <- runInstruction mem' (Loop prog)
                        return (mem'', act' >> act'')

Almost readable, right? But something is still off.

Better types

Your result type of runInstruction doesn't really capture what you want to do. You want to run an instruction and get a new Memory, maybe with some output on your console, or some user input taken. But even without that information, we'll notice that you never user the IO () part of your result, except for putChar. That line could also get written as

runInstruction mem Out = putChar (getValue mem) >> return (return mem, return ())

Therefore we don't need it at all. So we could use IO (IO Memory) instead (spoiler: don't):

runInstruction :: Memory -> Instruction -> IO (IO Memory)
runInstruction mem Nop = return (return mem)
runInstruction mem Rgt = return (return (moveRight mem))
runInstruction mem Lft = return (return (moveLeft  mem))
runInstruction mem Inc = return (return (modifyValue succ mem))
... don't use this!

But we're stopping short before the finish line. As I said, you just want to change the memory in your program, and maybe, maybe want to show or take some text. So runInstruction's correct type would be:

runInstruction :: Instruction -> Memory -> IO Memory

It's implementation stays the same, except that we lose several returns:

runInstruction :: Instruction -> Memory -> IO Memory
runInstruction i mem@(Memory _ v _) = case i of
  Lft       -> return (moveLeft mem)
  Rgt       -> return (moveRight mem)
  Inc       -> return (modifyValue succ mem)
  Dec       -> return (modifyValue pred mem)
  Out       -> putChar v >> return mem
  Inp       -> (\z -> setValue (ord z) mem) `fmap` getChar
  Loop _ | v == 0 -> return mem
  Loop p    -> runProgram p mem >>= runInstruction i
  _         -> return mem

I've switched the order of Memory and Instruction so that both occurences of Memory are closer to each other. Of course, this means that we need to change runProgram too, but that change isn't really large:

runProgram :: Program -> Memory -> IO Memory
runProgram []     mem = return mem
runProgram (i:is) mem = runInstruction i mem >>= runProgram is 

I think the last lines in both functions showed why I moved Memory to be the last argument.

You're off course free to change runInstruction back to your pattern matching variant.

Time for some exercises

Now that we have something that's easier to read, it would be time to refactor. So here are some exercises:

  1. Brainfuck only supports integers from 0-255 officially, and it wraps. This should get reflected in our functions. With our new program structure, there is only one single point where you need to change something. Where? And why?
  2. Instead of Nop, use Comment Char. That way, you can still have a look at the code.
  3. Try to make a variant of runProgram that takes a String to simulate user input and produces a String to simulate output.
  4. Try to parse more variants of Brainfuck, for example charmander, whitespace or Ook?!.
\$\endgroup\$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

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