From ea936cba8ede469a441f9b5c9dff4e959d3e254c Mon Sep 17 00:00:00 2001 From: Ian Adam Naval Date: Mon, 10 Mar 2014 20:21:18 -0400 Subject: [PATCH] Initial commit. --- examples/helloworld.bf | 33 ++++++++ src/brainfuck.hs | 179 +++++++++++++++++++++++++++++++++++++++++ 2 files changed, 212 insertions(+) create mode 100644 examples/helloworld.bf create mode 100644 src/brainfuck.hs diff --git a/examples/helloworld.bf b/examples/helloworld.bf new file mode 100644 index 0000000..7c2ccc9 --- /dev/null +++ b/examples/helloworld.bf @@ -0,0 +1,33 @@ ++++++ +++ Set Cell #0 to 8 +[ + >++++ Add 4 to Cell #1; this will always set Cell #1 to 4 + [ as the cell will be cleared by the loop + >++ Add 4*2 to Cell #2 + >+++ Add 4*3 to Cell #3 + >+++ Add 4*3 to Cell #4 + >+ Add 4 to Cell #5 + <<<<- Decrement the loop counter in Cell #1 + ] Loop till Cell #1 is zero + >+ Add 1 to Cell #2 + >+ Add 1 to Cell #3 + >- Subtract 1 from Cell #4 + >>+ Add 1 to Cell #6 + [<] Move back to the first zero cell you find; this will + be Cell #1 which was cleared by the previous loop + <- Decrement the loop Counter in Cell #0 +] Loop till Cell #0 is zero + +The result of this is: +Cell No : 0 1 2 3 4 5 6 +Contents: 0 0 72 104 88 32 8 +Pointer : ^ + +>>. Cell #2 has value 72 which is 'H' +>---. Subtract 3 from Cell #3 to get 101 which is 'e' ++++++ ++..+++. Likewise for 'llo' from Cell #3 +>>. Cell #5 is 32 for the space +<-. Subtract 1 from Cell #4 for 87 to give a 'W' +<. Cell #3 was set to 'o' from the end of 'Hello' ++++.----- -.----- ---. Cell #3 for 'rl' and 'd' +>>+. Add 1 to Cell #5 gives us an exclamation point +>++. And finally a newline from Cell #6 diff --git a/src/brainfuck.hs b/src/brainfuck.hs new file mode 100644 index 0000000..07deb23 --- /dev/null +++ b/src/brainfuck.hs @@ -0,0 +1,179 @@ +-- Branfuck interpreter in Haskell: beause why not +-- author: ianonavy +-- Based on https://github.com/quchen/articles/blob/master/write_yourself_a_brainfuck.md + +import Data.Maybe +import Data.List +import Data.Char (chr, ord) +import System.IO (hFlush, stdout) +import System.Environment + +data BrainfuckCommand = GoRight -- > + | GoLeft -- < + | Increment -- + + | Decrement -- - + | Print -- . + | Read -- , + | LoopL -- [ + | LoopR -- ] + | Comment Char -- anything else + +data BFSource = BFSource [BrainfuckCommand] + +instance Show BFSource where + show (BFSource bfs) = map bfToChar bfs where + bfToChar GoRight = '>' + bfToChar GoLeft = '<' + bfToChar Increment = '+' + bfToChar Decrement = '-' + bfToChar Print = '.' + bfToChar Read = ',' + bfToChar LoopL = '[' + bfToChar LoopR = ']' + bfToChar (Comment c) = c + +data Tape a = Tape [a] -- Left of the pivot element + a -- Pivot element + [a] -- Right of the pivot element + +instance Functor Tape where + fmap f (Tape l p r) = Tape (fmap f l) (f p) (fmap f r) + +emptyTape :: Tape Int +emptyTape = Tape zeros 0 zeros + where zeros = repeat 0 + +moveRight :: Tape a -> Tape a +moveRight (Tape ls p (r:rs)) = Tape (p:ls) r rs + +moveLeft :: Tape a -> Tape a +moveLeft (Tape (l:ls) p rs) = Tape ls l (p:rs) + +accParens :: (Num a) => a -> BrainfuckCommand -> a +accParens acc LoopL = acc + 1 +accParens acc LoopR = acc - 1 +accParens acc _ = acc + +hasMissingOpen :: BFSource -> Bool +hasMissingOpen bfs = not . null . filter (<0) $ traceParens bfs + +hasMissingClosed :: BFSource -> Bool +hasMissingClosed bfs = last (traceParens bfs) /= 0 + +traceParens :: BFSource -> [Int] +traceParens (BFSource bfs) = scanl accParens 0 bfs + +getMissingOpenError :: BFSource -> String +getMissingOpenError (BFSource bfs) = + "Syntax Error:\n- Close parens without open paren: character " ++ index where + index = (show . fromJust . findIndex (<0) $ scanl accParens 0 bfs) + +getMissingClosedError :: BFSource -> String +getMissingClosedError (BFSource bfs) = "Syntax Error:\n- Missing closed paren." + +checkSyntax :: BFSource -> Either String BFSource +checkSyntax bfs + | hasMissingOpen bfs = Left (getMissingOpenError bfs) + | hasMissingClosed bfs = Left (getMissingClosedError bfs) + | otherwise = Right bfs + +parseBrainfuck :: String -> Either String BFSource +parseBrainfuck = checkSyntax . BFSource . mapMaybe charToBF + where charToBF '>' = Just GoRight + charToBF '<' = Just GoLeft + charToBF '+' = Just Increment + charToBF '-' = Just Decrement + charToBF '.' = Just Print + charToBF ',' = Just Read + charToBF '[' = Just LoopL + charToBF ']' = Just LoopR + charToBF c = Just (Comment c) + +printBrainfuck :: Either String BFSource -> IO () +printBrainfuck (Left bfs) = putStrLn bfs +printBrainfuck (Right bfs) = putStrLn . show $ bfs + +runBrainfuck :: Either String BFSource -> IO () +runBrainfuck (Left bfs) = putStrLn bfs -- errors +runBrainfuck (Right (BFSource bfs)) = run emptyTape . bfSource2Tape $ bfs + where bfSource2Tape (b:bs) = Tape [] b bs + +run :: Tape Int -- Data tape + -> Tape BrainfuckCommand -- Instruction tape + -> IO () +run dataTape source@(Tape _ GoRight _) = + advance (moveRight dataTape) source + +run dataTape source@(Tape _ GoLeft _) = + advance (moveLeft dataTape) source + +run (Tape l p r) source@(Tape _ Increment _) = + advance (Tape l (p+1) r) source + +run (Tape l p r) source@(Tape _ Decrement _) = + advance (Tape l (p-1) r) source + +run dataTape@(Tape _ p _) source@(Tape _ Print _) = do + putChar (chr p) + hFlush stdout + advance dataTape source + +run dataTape@(Tape l _ r) source@(Tape _ Read _) = do + p <- getChar + advance (Tape l (ord p) r) source + +run dataTape@(Tape _ p _) source@(Tape _ LoopL _) + -- If the pivot is zero, jump to the + -- corresponding LoopR instruction + | p == 0 = seekLoopR 0 dataTape source + -- Otherwise just ignore the `[` and continue + | otherwise = advance dataTape source + +run dataTape@(Tape _ p _) source@(Tape _ LoopR _) + | p /= 0 = seekLoopL 0 dataTape source + | otherwise = advance dataTape source + +run dataTape source@(Tape _ (Comment _) _) = advance dataTape source + +-- Move the instruction pointer left until a "[" is found. +-- The first parameter ("b" for balance) retains the current +-- bracket balance to find the matching partner. When b is 1, +-- then the found LoopR would reduce the counter to zero, +-- hence we break even and the search is successful. +seekLoopR :: Int -- Parenthesis balance + -> Tape Int -- Data tape + -> Tape BrainfuckCommand -- Instruction tape + -> IO () +seekLoopR 1 dataTape source@(Tape _ LoopR _) = advance dataTape source +seekLoopR b dataTape source@(Tape _ LoopR _) = + seekLoopR (b-1) dataTape (moveRight source) +seekLoopR b dataTape source@(Tape _ LoopL _) = + seekLoopR (b+1) dataTape (moveRight source) +seekLoopR b dataTape source = + seekLoopR b dataTape (moveRight source) + +seekLoopL :: Int -- Parenthesis balance + -> Tape Int -- Data tape + -> Tape BrainfuckCommand -- Instruction tape + -> IO () +seekLoopL 1 dataTape source@(Tape _ LoopL _) = advance dataTape source +seekLoopL b dataTape source@(Tape _ LoopL _) = + seekLoopL (b-1) dataTape (moveLeft source) +seekLoopL b dataTape source@(Tape _ LoopR _) = + seekLoopL (b+1) dataTape (moveLeft source) +seekLoopL b dataTape source = + seekLoopL b dataTape (moveLeft source) + +advance :: Tape Int -- Data tape + -> Tape BrainfuckCommand -- Instruction tape + -> IO () +advance dataTape (Tape _ _ []) = return () +advance dataTape source = run dataTape (moveRight source) + +runFile :: String -> IO () +runFile filename = readFile filename >>= runBrainfuck . parseBrainfuck + +main = do + args <- getArgs + mapM runFile args + \ No newline at end of file