15
\$\begingroup\$

Last week I started learning Haskell, and since I have some experience with Brainfuck already, I decided it would be a great idea to implement an interactive Brainfuck interpreter in Haskell. I'll first list the code and then add some remarks on it.

Main.hs

module Main where

import Lib
import System.Environment

main :: IO ()
main = do
    args <- getArgs
    case args of
        [program]       -> interpret' program
        ["-f", file]    -> do
            contents <- readFile file
            interpret' contents
        _               -> putStrLn "Usage: brainfuck-interpreter-exe <program> or brainfuck-interpret-exe -f <file>"

interpret' :: String -> IO ()
interpret' program = do
    memory <- interpret program
    putChar '\n'
    putStrLn ("Memory: " ++ show memory)

Lib.hs

module Lib
    ( interpret
    ) where

import Data.Char
import Data.Maybe
import System.IO

data BFInstruction = MemoryRight | MemoryLeft | Increment | Decrement | Output | Input | LoopBegin | LoopEnd | Stop deriving (Enum, Eq, Show)
data BFProgram = BFProgram [BFInstruction] BFInstruction [BFInstruction] deriving Show

newtype BFMemoryCell = BFMemoryCell Int deriving Show
data BFMemory = BFMemory [BFMemoryCell] BFMemoryCell [BFMemoryCell] deriving Show

startProgram :: [BFInstruction] -> BFProgram
startProgram instructions = BFProgram [] (head instructions) (tail instructions ++ [Stop])

advance :: BFProgram -> BFProgram
advance (BFProgram past current next) = BFProgram (past ++ [current]) (head next) (tail next)

decrease :: BFProgram -> BFProgram
decrease (BFProgram past current next) = BFProgram (init past) (last past) (current:next)

jumpAfterMatchingLoopEnd :: BFProgram -> BFProgram
jumpAfterMatchingLoopEnd program = jumpAfterMatchingLoopEnd' 0 (advance program)

jumpAfterMatchingLoopEnd' :: Int -> BFProgram -> BFProgram
jumpAfterMatchingLoopEnd' 0 program@(BFProgram _ LoopEnd _) = advance program
jumpAfterMatchingLoopEnd' nesting program@(BFProgram _ instruction _) = case instruction of
    LoopEnd     -> jumpAfterMatchingLoopEnd' (nesting - 1) (advance program)
    LoopBegin   -> jumpAfterMatchingLoopEnd' (nesting + 1) (advance program)
    _           -> jumpAfterMatchingLoopEnd' nesting (advance program)

jumpToMatchingLoopBegin :: BFProgram -> BFProgram
jumpToMatchingLoopBegin program = jumpToMatchingLoopBegin' 0 (decrease program)

jumpToMatchingLoopBegin' :: Int -> BFProgram -> BFProgram
jumpToMatchingLoopBegin' 0 program@(BFProgram _ LoopBegin _) = program
jumpToMatchingLoopBegin' nesting program@(BFProgram _ instruction _) = case instruction of
    LoopBegin   -> jumpToMatchingLoopBegin' (nesting - 1) (decrease program)
    LoopEnd     -> jumpToMatchingLoopBegin' (nesting + 1) (decrease program)
    _           -> jumpToMatchingLoopBegin' nesting (decrease program)

makeCell :: Int -> BFMemoryCell
makeCell = BFMemoryCell . wrap

incrementCell :: BFMemoryCell -> BFMemoryCell
incrementCell = makeCell . (+1) . getCell

decrementCell :: BFMemoryCell -> BFMemoryCell
decrementCell = makeCell . subtract 1 . getCell

getCell :: BFMemoryCell -> Int
getCell (BFMemoryCell value) = value

wrap :: Int -> Int
wrap input = mod input 256

moveMemoryRight :: BFMemory -> BFMemory
moveMemoryRight (BFMemory previous current []) = BFMemory (previous ++ [current]) (makeCell 0) []
moveMemoryRight (BFMemory previous current next) = BFMemory (previous ++ [current]) (head next) (tail next)

moveMemoryLeft :: BFMemory -> BFMemory
moveMemoryLeft (BFMemory [] current next) = BFMemory [] (makeCell 0) (current:next)
moveMemoryLeft (BFMemory previous current next) = BFMemory (init previous) (last previous) (current:next)

onCurrentCell :: (BFMemoryCell -> BFMemoryCell) -> BFMemory -> BFMemory
onCurrentCell func (BFMemory previous current next) = BFMemory previous (func current) next

setCurrentCell :: BFMemoryCell -> BFMemory -> BFMemory
setCurrentCell cell (BFMemory previous _ next) = BFMemory previous cell next

toInstructions :: String -> [BFInstruction]
toInstructions = mapMaybe toInstruction

toInstruction :: Char -> Maybe BFInstruction
toInstruction instruction = case instruction of
    '>' -> Just MemoryRight
    '<' -> Just MemoryLeft
    '+' -> Just Increment
    '-' -> Just Decrement
    '.' -> Just Output
    ',' -> Just Input
    '[' -> Just LoopBegin
    ']' -> Just LoopEnd
    _   -> Nothing

interpret :: String -> IO BFMemory
interpret program = step (startProgram $ toInstructions program) (BFMemory [] (makeCell 0) [])

step :: BFProgram -> BFMemory -> IO BFMemory
step (BFProgram _ Stop []) memory = return memory
step program@(BFProgram _ instruction _) memory@(BFMemory _ currentMemory _) = case instruction of
    MemoryRight -> step (advance program) (moveMemoryRight memory)
    MemoryLeft  -> step (advance program) (moveMemoryLeft memory)
    Increment   -> step (advance program) (onCurrentCell incrementCell memory)
    Decrement   -> step (advance program) (onCurrentCell decrementCell memory)
    Output      -> do
        putChar . chr . getCell $ currentMemory
        hFlush stdout
        step (advance program) memory
    Input       -> do
        newCurrentChar <- getChar
        let newCurrent = makeCell . ord $ newCurrentChar
        step (advance program) (setCurrentCell newCurrent memory)
    LoopBegin   -> case getCell currentMemory of
        0   -> step (jumpAfterMatchingLoopEnd program) memory
        _   -> step (advance program) memory
    LoopEnd     -> case getCell currentMemory of
        0   -> step (advance program) memory
        _   -> step (jumpToMatchingLoopBegin program) memory

Remarks:

  • I am aware that I could have used an Abstract Syntax Tree-based approach, I'll consider that for the next Haskell Brainfuck interpreter I'm going to write.
  • I really don't like the artificial Stop instruction.
  • I'd like to get rid of the IO part, but I wrote this under the assumption that a Haskell interpreter is interactive, so reading from a predefined input stream is not an option in that case. However, I wouldn't mind to get redirected to a means to use some sort of input stream as input, being backed by IO, a predefined input, or anything else.
\$\endgroup\$
16
\$\begingroup\$

Good job on getting it to work! I've used a string reversal program to check your interpreter and it works well. However, it also uses ~36MB of memory, which is too much.

A tape goes both directions equally fast

Forward, rewind. The basic operations for a tape. Whether it's VHS, a cassette, or a LTO-8, they all work the same: accessing the next and previous part of a tape is fast, accessing further away parts is slow.

After all, we're moving the tape below the read/write head to the left and right:

a picture of a tape

A short look at Turing machines

Let's get nostalgic for a while. Turing machines were defined by Alan Turing to work on "an unlimited memory capacity obtained in the form of an infinite tape marked out into squares"1. While Turing didn't knew about SDRAM, processor cache or similar technologies highly available nowadays, he made one central assumption about the memory: it should be fast (read \$\mathcal O(1)\$) to get to the previous and the next memory cell.

BrainFuck machines are less formally described, but their memory us usually described as an array, which fulfills the same property: it's easy to get from the current cell to the next one and the previous one. They are—after all— defined as Turing-like machines. In a C-like language, you would simply change the memory index:

void advance(memory_state * mem) {
    mem->ptr++;
}

void decrease(memory_state * mem) {
    mem->ptr--;
}

char * access(memory_state * mem) {
    return mem->ptr;
}

A short look at non-euclidean \$\mathcal O(n^2)\$ tapes

Why did we have a look at Turing machines? Because your tape is \$\mathcal O(n)\$:

moveMemoryRight :: BFMemory -> BFMemory
moveMemoryRight (BFMemory previous current []) = BFMemory (previous ++ [current]) (makeCell 0) []
moveMemoryRight (BFMemory previous current next) = BFMemory (previous ++ [current]) (head next) (tail next)

Appending to a list list ++ [element] is \$\mathcal O(n)\$. This isn't so much of a problem since laziness will somewhat save us if we consume the list afterwards. However, it really gets bad as soon as we use moveMemoryRight or decrease multiple times:

((list ++ [element]) ++ [element2]) ++ [element3]

Append versus cons

We just built an algorithm with square time complexity. Even worse, Haskell's laziness and sharing cannot help us at that point. When we have

list  = "12345"
alist = 'a' : list
blist = 'b' : list

then alist only consists of the character 'a' and the pointer to list. But the same holds for blist! Even though we've used list three times, we only use its memory once. Since every value in Haskell is immutable, we don't need to copy list. That's great! But it doesn't hold for the following:

list  = "12345"
lista = list ++ "a"
listb = list ++ "b"

We cannot simply update list's last pointer to point to "a" or "b". We need to create a new list. Ouch.

Haskell's lists are like stacks. It's easy to push something on top, but if you try to push a value to the bottom, it's going to take some work.

Stacks can build a tape

Imagine a bunch of plates, neatly stacked, to your right, and a single plate in front of you. Leave some space on the left. Now, to advance to the next plate, you simply put your current plate (the one that's in front of you) on top of the left stack and then get the one on the right stack. And to get the previous plate, you simply do the reverse: you put your current plate on the right stack and then take the top of the left stack and put it in front of you.

That's the whole trick.

Building a better tape

Fortunately, you never use BFProgram or BFMemory via their constructors, so we only need to adjust some functions. But why do we need to adjust them to begin with?

We shortly break from the tape discussion to get to another topic. Profiling.

Profiling can show space and time leaks

Let's profile your current code. We use Unihedron's reverse program as a test and the following input:

Hello world,how are you today?,Well,this seems to work.
Newlines are completely ignored, though. But that was
the intend of the original program, right? ^@

The ^@ is a trailing \0. It's necessary in order to exit the program, but it's somewhat hard to input in Windows. Regardless, we can now profile your code. If you use stack, then you have to use

stack build --profile
stack --RTS exec --profile skiwi-bf-exe -- +RTS -s -p -RTS -f unihedron.bf < input.txt

The first --RTS tells stack's runtime not to interpret any runtime options, the +RTS -s -p tells your runtime to print -statistics and to -profile the program.

The included statistics will look like this (sans stdout from your program):

   1,877,933,288 bytes allocated in the heap                                  
     288,094,168 bytes copied during GC                                       
      20,472,904 bytes maximum residency (27 sample(s))                       
         519,096 bytes maximum slop                                           
              50 MB total memory in use (0 MB lost due to fragmentation)      

                                     Tot time (elapsed)  Avg pause  Max pause 
  Gen  0      1781 colls,     0 par    0.172s   0.205s     0.0001s    0.0177s 
  Gen  1        27 colls,     0 par    0.000s   0.002s     0.0001s    0.0003s 

  TASKS: 3 (1 bound, 2 peak workers (2 total), using -N1)                     

  SPARKS: 0 (0 converted, 0 overflowed, 0 dud, 0 GC'd, 0 fizzled)             

  INIT    time    0.000s  (  0.000s elapsed)                                  
  MUT     time    0.422s  (  0.391s elapsed)                                  
  GC      time    0.172s  (  0.207s elapsed)                                  
  RP      time    0.000s  (  0.000s elapsed)                                  
  PROF    time    0.000s  (  0.000s elapsed)                                  
  EXIT    time    0.000s  (  0.001s elapsed)                                  
  Total   time    0.594s  (  0.599s elapsed)                                  

  Alloc rate    4,451,397,423 bytes per MUT second                            

  Productivity  71.1% of total user, 65.4% of total elapsed                   

Also, you will find a .prof file in your current working directory:

   Fri Mar 30 09:30 2018 Time and Allocation Profiling Report  (Final)

       skiwi-bf-exe.EXE +RTS -N -s -p -RTS -f reverse.bf.txt

    total time  =        0.08 secs   (80 ticks @ 1000 us, 1 processor)
    total alloc = 1,194,261,592 bytes  (excludes profiling overheads)

COST CENTRE              MODULE SRC                         %time %alloc

moveMemoryLeft           Lib    src\Lib.hs:(64,1)-(65,105)   41.2   16.1
decrease                 Lib    src\Lib.hs:22:1-89           21.2   31.8
advance                  Lib    src\Lib.hs:19:1-93           15.0   31.8
moveMemoryRight          Lib    src\Lib.hs:(60,1)-(61,107)    8.8   16.0
step                     Lib    src\Lib.hs:(92,1)-(111,60)    7.5    1.9
decrementCell            Lib    src\Lib.hs:51:1-47            2.5    0.2
MAIN                     MAIN                       1.2    0.0
jumpToMatchingLoopBegin' Lib    src\Lib.hs:(38,1)-(42,70)     1.2    1.7
onCurrentCell            Lib    src\Lib.hs:68:1-91            1.2    0.0

As you can see, all your tape handling functions are taking most of the time and allocation. The profile includes more information, like function call hierarchies, individual and ac­cu­mu­lated time and allocation as well as function calls. For example, step gets called 262993 times and uses 1.9% of the total allocated memory as individual function.

A tape still goes both directions equally fast

By now you probably know the improvement I want to show on the tape, given the plate of stacks example above. It's mind mindbogglingly simple:
We just push (better: cons) our current value on top of past or previous if we want to go right or advance, and we just pop (better: uncons) it from past or previous if we want to go left or decrease.

moveMemoryRight :: BFMemory -> BFMemory
moveMemoryRight (BFMemory previous current []) = BFMemory (current : previous) (makeCell 0) []
moveMemoryRight (BFMemory previous current next) = BFMemory (current : previous) (head next) (tail next)

moveMemoryLeft :: BFMemory -> BFMemory
moveMemoryLeft (BFMemory [] current next) = BFMemory [] (makeCell 0) (current:next)
moveMemoryLeft (BFMemory previous current next) = BFMemory (tail previous) (head previous) (current:next)

advance :: BFProgram -> BFProgram
advance (BFProgram past current next) = BFProgram (current : past) (head next) (tail next)

decrease :: BFProgram -> BFProgram
decrease (BFProgram past current next) = BFProgram (tail past) (head past) (current:next)

Note the symmetry between decrease and advance. Sure, past is now in reverse, but that's not important unless we print the program. We can just reverse the list if we want to:

instructions :: BFProgram -> [BFInstruction]
instructions (BFProgram l v r) = reverse l ++ [v] ++ r

This use of ++ is fine, by the way, since it will lead to reverse l ++ ([v] ++ r). reverse l will only get looked at once.

"That's fine and all, but what did I get?" you might ask. Well, here's the statistics and profile:

      91,312,368 bytes allocated in the heap                                  
       3,183,024 bytes copied during GC                                       
         125,704 bytes maximum residency (2 sample(s))                        
          46,120 bytes maximum slop                                           
               3 MB total memory in use (0 MB lost due to fragmentation)      

                                     Tot time (elapsed)  Avg pause  Max pause 
  Gen  0        86 colls,     0 par    0.016s   0.003s     0.0000s    0.0003s 
  Gen  1         2 colls,     0 par    0.000s   0.000s     0.0000s    0.0000s 

  TASKS: 3 (1 bound, 2 peak workers (2 total), using -N1)                     

  SPARKS: 0 (0 converted, 0 overflowed, 0 dud, 0 GC'd, 0 fizzled)             

  INIT    time    0.000s  (  0.001s elapsed)                                  
  MUT     time    0.047s  (  0.055s elapsed)                                  
  GC      time    0.016s  (  0.003s elapsed)                                  
  RP      time    0.000s  (  0.000s elapsed)                                  
  PROF    time    0.000s  (  0.000s elapsed)                                  
  EXIT    time    0.000s  (  0.000s elapsed)                                  
  Total   time    0.062s  (  0.059s elapsed)                                  

  Alloc rate    1,947,997,184 bytes per MUT second                            

  Productivity  75.0% of total user, 93.3% of total elapsed                   

Note the total 3MB usage vs 50MB.

   Fri Mar 30 10:01 2018 Time and Allocation Profiling Report  (Final)

       skiwi-bf-exe.EXE +RTS -N -s -p -RTS -f reverse.bf.txt

    total time  =        0.00 secs   (3 ticks @ 1000 us, 1 processor)
    total alloc =  57,235,776 bytes  (excludes profiling overheads)

COST CENTRE              MODULE SRC                         %time %alloc

step                     Lib    src\Lib.hs:(92,1)-(111,60)   66.7   40.3
advance                  Lib    src\Lib.hs:19:1-90           33.3    0.0
jumpToMatchingLoopBegin  Lib    src\Lib.hs:35:1-79            0.0    5.8
jumpToMatchingLoopBegin' Lib    src\Lib.hs:(38,1)-(42,70)     0.0   35.6
moveMemoryLeft           Lib    src\Lib.hs:(64,1)-(65,105)    0.0    4.3
moveMemoryRight          Lib    src\Lib.hs:(60,1)-(61,104)    0.0    4.3
decrementCell            Lib    src\Lib.hs:51:1-47            0.0    3.4
incrementCell            Lib    src\Lib.hs:48:1-41            0.0    3.0
wrap                     Lib    src\Lib.hs:57:1-26            0.0    2.5

Looks like jumpToMatchingLoopBegin' is a good candidate to look for further optimizations. advance isn't that slow, by the way, it's just getting called by almost every function, e.g. every non-loop instruction in step calls advance.

So the TL;DR of this whole section is: don't append on lists, especially not recursively!

Make wrong states impossible to represent

At the moment, we can write ][ or [ and our program will happily accept it and end up with an error. After all, BFProgram allows that. Nothing in it's type prevents a BFProgram [] LoopBegin []. That's unfortunate, because types can help us to catch those errors before they can occur.

A data BFFragment = Increment | Decrement | .... | Loop BFProgram without LoopBegin and LoopEnd can help tremendously, but you're already aware of that. For other readers I'll point to my previous reviews, but here's an appetizer what one can do with an AST:

possible parser and printer combinations

Remark on Stop: It's not trivial to get rid of Stop at that point. I wouldn't bother, to be honest, since you will use an ST next. It can provide you a halting point for debugging BrainFuck programs, since you now can arbitrarily stop them.

Abstractions, abstractions, abstractions

Now that we have a refreshed look on your BFProgram and BFMemory, we immediately see that both have the same structure and we're essentially duplicating code. This is easy to fix, though:

data Tape a = Tape [a] a [a] deriving (Eq, Show)

type BFMemory  = Tape BFMemoryCell
type BFProgram = Tape BFInstruction

forwardTape :: a -> Tape a -> Tape a
forwardTape def (Tape previous current [])   = Tape (current : previous) def []
forwardTape _   (Tape previous current next) = Tape (current : previous) (head next) (tail next)

rewindTape :: a -> Tape a -> Tape a
rewindTape def (Tape [] current next)       = Tape [] def (current:next)
rewindTape _   (Tape previous current next) = Tape (tail previous) (head previous) (current:next)

advance, decrease :: BFProgram -> BFProgram
advance  = forwardTape Stop
decrease = forwardTape Stop

moveMemoryRight, moveMemoryLeft :: BFMemory -> BFMemory
moveMemoryRight = forwardTape (makeCell 0)
moveMemoryLeft  = rewindTape  (makeCell 0)

The def stands for "default" value in this case and is used if we run out of elements at either end.

If you follow the AST approach, you won't need that flexibility for your BFProgram, though.

Bindings are friends2

Your step function is rather cluttered with step (advance program), which brings me the use of bindings. It's the only function that could profit from one, though, since all your other functions are either pointfree or use pattern matching:

step :: BFProgram -> BFMemory -> IO BFMemory
step (BFProgram _ Stop []) memory = return memory
step program@(BFProgram _ instruction _) memory@(BFMemory _ currentMemory _) = case instruction of
    MemoryRight -> continue (moveMemoryRight memory)
    MemoryLeft  -> continue (moveMemoryLeft memory)
    Increment   -> continue (onCurrentCell incrementCell memory)
    Decrement   -> continue (onCurrentCell decrementCell memory)
    Output      -> do
        putChar . chr . getCell $ currentMemory
        hFlush stdout
        continue memory
    Input       -> do
        newCurrentChar <- getChar
        let newCurrent = makeCell . ord $ newCurrentChar
        continue (setCurrentCell newCurrent memory)
    LoopBegin   -> case getCell currentMemory of
        0   -> step (jumpAfterMatchingLoopEnd program) memory
        _   -> continue memory
    LoopEnd     -> case getCell currentMemory of
        0   -> continue memory
        _   -> step (jumpToMatchingLoopBegin program) memory
    where
        continue = step (advance program)

Slightly easier to read, but that's your call.

Use pattern matching if possible

For a last time, let us revisit our Tape. Our forwardTape and rewindTape where derived by your moveMemoryRight and *Left and therefore use tail and head. However, that's error prone. Sure, we know that next does have a head and a tail, since we handled the empty list first, but what if we accidentally swapped the lines?

forwardTape :: a -> Tape a -> Tape a
forwardTape _   (Tape previous current next) = Tape (current : previous) (head next) (tail next)
forwardTape def (Tape previous current [])   = Tape (current : previous) def []

That's an error if next is empty. So let us use pattern matching instead:

forwardTape :: a -> Tape a -> Tape a
forwardTape _ (Tape ls v (r:rs)) = Tape (v:ls) r rs
forwardTape d (Tape ls v [])     = Tape (v:ls) d []

rewindTape :: a -> Tape a -> Tape a
rewindTape _ (Tape (l:ls) v rs)  = Tape ls l (v:rs)
rewindTape d (Tape []     v rs)  = Tape [] d (v:rs)

This also uses the more common naming scheme in Haskell. ls is the left list, it's first element is l, similarly for r and rs on the right list.

Getting rid of IO

Now that we've come this far, we have a proper tape, local bindings and pattern matching for safety. We can now address your final concern

I'd like to get rid of the IO part, but I wrote this under the assumption that a Haskell interpreter is interactive, so reading from a predefined input stream is not an option in that case. However, I wouldn't mind to get redirected to a means to use some sort of input stream as input, being backed by IO, a predefined input, or anything else.

Well, that's not that hard, to be honest. All you need do to is to get rid of the functions that use IO, right? So let's tackle step a final time:

stepM :: Monad m => m Char -> (Char -> m ()) -> BFProgram -> BFMemory -> m BFMemory
stepM get put = go
 where
   go program@(Tape _ instruction _) memory@(Tape _ currentMemory _) = case instruction of
     Stop        -> return memory
     MemoryRight -> continue (moveMemoryRight memory)
     MemoryLeft  -> continue (moveMemoryLeft memory)
     Increment   -> continue (onCurrentCell incrementCell memory)
     Decrement   -> continue (onCurrentCell decrementCell memory)
     Output      -> do
         put . chr . getCell $ currentMemory
         continue memory
     Input       -> do
         newCurrentChar <- get
         let newCurrent = makeCell . ord $ newCurrentChar
         continue (setCurrentCell newCurrent memory)
     LoopBegin   -> case getCell currentMemory of
         0   -> go (jumpAfterMatchingLoopEnd program) memory
         _   -> continue memory
     LoopEnd     -> case getCell currentMemory of
         0   -> continue memory
         _   -> go (jumpToMatchingLoopBegin program) memory
     where
         continue = go (advance program)

stepIO :: BFProgram -> BFMemory -> IO BFMemory
stepIO = stepM getChar (\c -> putChar c >> hFlush stdout)

Well, that certainly removed IO from stepM, right? All we need is now the right Monad instance. We could use State with (String, String) or StateT with Writer. That's however left as an (intermediate, not easy!) exercise.

By the way, instead of hFlush stdout, you can also disable buffering in main with hSetBuffering stdout hSetBuffering.

The alternative is to build the output and consume the input as we go along:

step :: BFProgram -> BFMemory -> String -> String
step program@(Tape _ instruction _) memory@(Tape _ currentMemory _) input = case instruction of
     Stop        -> ""
     MemoryRight -> continue (moveMemoryRight memory) input
     MemoryLeft  -> continue (moveMemoryLeft memory) input
     Increment   -> continue (onCurrentCell incrementCell memory) input
     Decrement   -> continue (onCurrentCell decrementCell memory) input
     Output      -> chr (getCell currentMemory) : continue memory input
     Input       -> continue (setCurrentCell (makeCell . ord $ i) memory) is
     LoopBegin   -> case getCell currentMemory of
         0   -> step (jumpAfterMatchingLoopEnd program) memory input
         _   -> continue memory input
     LoopEnd     -> case getCell currentMemory of
         0   -> continue memory input
         _   -> step (jumpToMatchingLoopBegin program) memory input
   where
       continue = step (advance program)
       (i:is)   = input

This will of course fail if we try to use Input when there is no input left, but that's also true for your current implementation, so I wouldn't worry too much about it.

Note that all those continue lines look almost the same? Remember bindings are friends? This is yet another exercise, although this one is easier as the custom Monad one.


1: A.M. Turing (1948). "Intelligent Machinery (manuscript)". The Turing Archive. p. 3.
2: Just like fishes.

\$\endgroup\$
3
\$\begingroup\$

Recursion can keep track of the brackets instead of a number.

jumpAfterMatchingLoopEnd :: BFProgram -> BFProgram
jumpAfterMatchingLoopEnd program@(BFProgram _ instruction _) = (case instruction of
    LoopEnd     -> id
    LoopBegin   -> jumpAfterMatchingLoopEnd . jumpAfterMatchingLoopEnd
    _           -> jumpAfterMatchingLoopEnd
    ) advance program

jumpToMatchingLoopBegin :: BFProgram -> BFProgram
jumpToMatchingLoopBegin program@(BFProgram _ LoopBegin _) = program
jumpToMatchingLoopBegin program@(BFProgram _ instruction _) = (case instruction of
    LoopBegin   -> id
    LoopEnd     -> jumpToMatchingLoopBegin . jumpToMatchingLoopBegin 
    _           -> jumpToMatchingLoopBegin
    ) decrease program

interact captures your usage of IO into a simple interface, except you need a way to retrieve the BFMemory, so let's tweak it.

interact' :: (String -> (a, String)) -> IO a
interact' f = do
  sin <- getContents
  let (a, sout) = f sin
  sequence_ [putChar c >> hFlush stdout | c <- sout]
  return a

interpret :: String -> IO BFMemory
interpret program = interact' $ step (startProgram $ toInstructions program) (BFMemory [] (makeCell 0) [])

step :: BFProgram -> BFMemory -> String -> (BFMemory, String)
step (BFProgram _ Stop []) memory input = (memory, [])
step program@(BFProgram _ instruction _) memory@(BFMemory _ currentMemory _) input = let
  memorize f = step (advance program) (f memory) input
  in case instruction of
    MemoryRight -> memorize moveMemoryRight
    MemoryLeft  -> memorize moveMemoryLeft
    Increment   -> memorize $ onCurrentCell incrementCell
    Decrement   -> memorize $ onCurrentCell decrementCell
    Output      -> (currentMemory:) <$> memorize id
    Input       -> let
        newCurrentChar : rest = input
        newCurrent = makeCell $ ord newCurrentChar
        in step (advance program) (setCurrentCell newCurrent memory) rest
    LoopBegin   -> case getCell currentMemory of
        0   -> step (jumpAfterMatchingLoopEnd program) memory input
        _   -> memorize id
    LoopEnd     -> case getCell currentMemory of
        0   -> memorize id
        _   -> step (jumpToMatchingLoopBegin program) memory input
\$\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.