Initial commit.
This commit is contained in:
Ian Adam Naval
commit
ea936cba8e
33
examples/helloworld.bf
Normal file
33
examples/helloworld.bf
Normal file
@ -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
|
||||
179
src/brainfuck.hs
Normal file
179
src/brainfuck.hs
Normal file
@ -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
|
||||
|
||||
Loading…
x
Reference in New Issue
Block a user