3 files changed, 178 insertions, 0 deletions
diff --git a/src/Brainfuck/Interpreter.hs b/src/Brainfuck/Interpreter.hs
new file mode 100644
index 0000000..1085a30
--- /dev/null
+++ b/src/Brainfuck/Interpreter.hs
@@ -0,0 +1,70 @@
+module Brainfuck.Interpreter (
+    brainfuck
+    ) where
+
+
+import Data.Char
+import Data.Maybe
+import Brainfuck.Parser
+import Brainfuck.Tape
+
+
+
+
+brainfuck :: BrainfuckProgram -> IO (Tape Int)
+brainfuck program =
+    let dataTape = (repeat 0, Just 0, repeat 0)
+        commandTape = shiftRight ([], Nothing, program)
+    in process commandTape dataTape
+
+
+
+endLoop :: Tape BrainCom -> Tape BrainCom
+endLoop tape =
+    let f t c = case (currentCell t, c) of
+                    (Just CloseLoop, 0) -> shiftRight t
+                    (Just OpenLoop, x) -> f (shiftRight t) (x + 1)
+                    (Just CloseLoop, x) -> f (shiftRight t) (x - 1)
+                    (Just com, x) -> f (shiftRight t) x
+    in f (shiftRight tape) 0
+
+
+
+doLoop :: Tape BrainCom -> Tape BrainCom
+doLoop tape =
+    let f t c = case (currentCell t, c) of
+                    (Just OpenLoop, 0) -> shiftRight t
+                    (Just OpenLoop, x) -> f (shiftLeft t) (x - 1)
+                    (Just CloseLoop, x) -> f (shiftLeft t) (x + 1)
+                    (Just com, x) -> f (shiftLeft t) x
+    in f (shiftLeft tape) 0
+
+
+
+process :: Tape BrainCom -> Tape Int -> IO (Tape Int)
+process commandTape dataTape =
+    case (currentCell commandTape) of
+        Nothing -> return dataTape
+
+        Just R -> process (shiftRight commandTape) (shiftRight dataTape)
+
+        Just L -> process (shiftRight commandTape) (shiftLeft dataTape)
+
+        Just Inc -> process (shiftRight commandTape) (applyToCurrentCell ((`mod` 256) . (+1)) dataTape)
+
+        Just Dec -> process (shiftRight commandTape) (applyToCurrentCell ((`mod` 256) . (subtract 1)) dataTape)
+
+        Just Out -> (putChar . chr . fromJust . currentCell $ dataTape) >> process (shiftRight commandTape) dataTape
+
+        Just In -> do { c <- getChar; process (shiftRight commandTape) (applyToCurrentCell (\_ -> ord c) dataTape) }
+
+        Just OpenLoop ->
+                if (currentCell dataTape == Just 0)
+                then process (endLoop commandTape) dataTape
+                else process (shiftRight commandTape) dataTape
+
+        Just CloseLoop ->
+                if (currentCell dataTape /= Just 0)
+                then process (doLoop commandTape) dataTape
+                else process (shiftRight commandTape) dataTape
+
diff --git a/src/Brainfuck/Parser.hs b/src/Brainfuck/Parser.hs
new file mode 100644
index 0000000..1ea046a
--- /dev/null
+++ b/src/Brainfuck/Parser.hs
@@ -0,0 +1,62 @@
+module Brainfuck.Parser (
+    BrainfuckProgram,
+    BrainCom(..),
+
+	parseBrainfuck
+    ) where
+
+import Control.Applicative( some )
+import Text.ParserCombinators.Parsec
+
+
+
+type BrainfuckProgram = [BrainCom]
+
+
+data BrainCom = R | L | Inc | Dec | Out | In | OpenLoop | CloseLoop
+    deriving (Show, Eq)
+
+
+
+
+parseBrainfuck :: String -> Either ParseError BrainfuckProgram
+parseBrainfuck = parse brainfuck "error"
+
+
+
+
+brainfuck = do
+	many commentChar
+	bs <- many fuck
+	eof
+	return . concat $ bs
+
+
+fuck =  (brainCommand >>= return . (:[]))
+    <|> loop
+    <?> "brainfuck command"
+
+
+loop = do
+	char '['
+	many commentChar
+	bs <- many brainCommand
+	char ']'
+	many commentChar
+	return . concat $ [[OpenLoop],bs,[CloseLoop]]
+
+
+brainCommand = do { b <- brainCom; many commentChar; return b }
+
+
+brainCom =  (char '>' >> return R)
+        <|> (char '<' >> return L)
+        <|> (char '+' >> return Inc)
+        <|> (char '-' >> return Dec)
+        <|> (char '.' >> return Out)
+        <|> (char ',' >> return In)
+        <?> "brainfuck command"
+
+
+commentChar = noneOf "><+-.,[]"
+
diff --git a/src/Brainfuck/Tape.hs b/src/Brainfuck/Tape.hs
new file mode 100644
index 0000000..8da4352
--- /dev/null
+++ b/src/Brainfuck/Tape.hs
@@ -0,0 +1,46 @@
+module Brainfuck.Tape (
+    Tape,
+
+    shiftLeft,
+    shiftRight,
+    currentCell,
+    applyToCurrentCell
+    ) where
+
+
+import Control.Monad
+import Data.Maybe
+
+
+
+type Tape a = ([a], Maybe a, [a])
+
+
+
+
+shiftLeft :: Eq a => Tape a -> Tape a
+shiftLeft (x,y,z) = 
+	let x' = if (x /= []) then tail x else x
+	    y' = if (x /= []) then Just (head x) else Nothing
+	    z' = if (isJust y) then (fromJust y):z else z
+	in (x', y', z')
+
+
+
+shiftRight :: Eq a => Tape a -> Tape a
+shiftRight (x,y,z) =
+	let x' = if (isJust y) then (fromJust y):x else x
+	    y' = if (z /= []) then Just (head z) else Nothing
+	    z' = if (z /= []) then tail z else z
+	in (x', y', z')
+
+
+
+currentCell :: Tape a -> Maybe a
+currentCell (_,c,_) = c
+
+
+
+applyToCurrentCell :: (a -> a) -> Tape a -> Tape a
+applyToCurrentCell f (x,y,z) = (x, (liftM f) y, z)
+