summaryrefslogtreecommitdiff
path: root/src/Brainfuck
diff options
context:
space:
mode:
authorJed Barber <jjbarber@y7mail.com>2014-04-10 05:25:03 +1000
committerJed Barber <jjbarber@y7mail.com>2014-04-10 05:25:03 +1000
commit281425310c5db21f87981eeb9601a71d1974d98d (patch)
treebef4643d906c93622c311fef2cf758fe94f1f651 /src/Brainfuck
parente8695600977769008f285f9958eb043cca1b9b29 (diff)
Rearranging files
Diffstat (limited to 'src/Brainfuck')
-rw-r--r--src/Brainfuck/Interpreter.hs70
-rw-r--r--src/Brainfuck/Parser.hs62
-rw-r--r--src/Brainfuck/Tape.hs46
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)
+