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 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 accumulated 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:
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.
