Initial commit.

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

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
+