patternMinor
Brainfuck Interpreter
Viewed 0 times
brainfuckinterpreterstackoverflow
Problem
I want to write an example for a language similar to Haskell called Frege. While the interpreter is conceptually easy, it is lengthy and looks still quite messy. Note that I don't want to use Parsec etc, as it isn't available yet in Frege. Please help me to improve the Haskell version.
``
parseOp :: [Char] -> Maybe (Op, [Char])
parseOp ('+':cs) = Just (Plus, cs)
parseOp ('-':cs) = Just (Minus, cs)
parseOp ('':cs) = Just (GoRight, cs)
parseOp ('.':cs) = Just (Output, cs)
parseOp (',':cs) = Just (Input, cs)
parseOp ('[':cs) = case parseOps cs of
(prog, (']':cs')) -> Just (Loop prog, cs')
_ -> Nothing
parseOp _ = Nothing
parseOps :: [Char] -> ([Op],[Char])
parseOps cs = go cs [] where
go cs acc = case parseOp cs of
Nothing -> (reverse acc, cs)
Just (op, cs') -> go cs' (op:acc)
parse :: String -> [Op]
parse prog = case parseOps $ removeComments $ prog of
(ops, []) -> ops
(ops, rest) -> error $ "Parsed: " ++ show ops ++ ", Rest: " ++ rest
execute :: [Op] -> IO Tape
execute prog = exec prog (Tape [] 0 [])
exec :: [Op] -> Tape -> IO Tape
exec [] tape = return tape
exec (Plus:prog) (Tape ls c rs) = exec prog (Tape ls (c+1) rs)
exec (Minus:prog) (Tape ls c rs) = exec prog (Tape ls (c-1) rs)
exec (GoLeft:prog) (Tape ls c rs) =
let (hd,tl) = uncons ls in exec prog (Tape tl hd (c:rs))
exec (GoRight:prog) (Tape ls c rs) =
let (hd,tl) = uncons rs in exec prog (Tape (c:ls) hd tl)
exec (Output:prog) tape = do
printAsChar (cell tape)
exec prog tape
exec (Input:prog) (Tape ls _ rs) = do
n (Int,[Int])
uncons [] = (0,[])
uncons (x:xs) = (x,xs)
printAsChar :: Int -> IO ()
printAsChar i = putStr $ [chr i]
main = do
t
``
import Data.Char
data Tape = Tape { left :: [Int], cell :: Int, right :: [Int] }
instance Show Tape where
show (Tape ls c rs) = show [reverse ls,[c],rs]
data Op = Plus | Minus | GoLeft | GoRight | Output | Input | Loop [Op] deriving (Eq, Show)
removeComments :: [Char] -> [Char]
removeComments xs = filter (elem` "+-<>.,[]") xsparseOp :: [Char] -> Maybe (Op, [Char])
parseOp ('+':cs) = Just (Plus, cs)
parseOp ('-':cs) = Just (Minus, cs)
parseOp ('':cs) = Just (GoRight, cs)
parseOp ('.':cs) = Just (Output, cs)
parseOp (',':cs) = Just (Input, cs)
parseOp ('[':cs) = case parseOps cs of
(prog, (']':cs')) -> Just (Loop prog, cs')
_ -> Nothing
parseOp _ = Nothing
parseOps :: [Char] -> ([Op],[Char])
parseOps cs = go cs [] where
go cs acc = case parseOp cs of
Nothing -> (reverse acc, cs)
Just (op, cs') -> go cs' (op:acc)
parse :: String -> [Op]
parse prog = case parseOps $ removeComments $ prog of
(ops, []) -> ops
(ops, rest) -> error $ "Parsed: " ++ show ops ++ ", Rest: " ++ rest
execute :: [Op] -> IO Tape
execute prog = exec prog (Tape [] 0 [])
exec :: [Op] -> Tape -> IO Tape
exec [] tape = return tape
exec (Plus:prog) (Tape ls c rs) = exec prog (Tape ls (c+1) rs)
exec (Minus:prog) (Tape ls c rs) = exec prog (Tape ls (c-1) rs)
exec (GoLeft:prog) (Tape ls c rs) =
let (hd,tl) = uncons ls in exec prog (Tape tl hd (c:rs))
exec (GoRight:prog) (Tape ls c rs) =
let (hd,tl) = uncons rs in exec prog (Tape (c:ls) hd tl)
exec (Output:prog) tape = do
printAsChar (cell tape)
exec prog tape
exec (Input:prog) (Tape ls _ rs) = do
n (Int,[Int])
uncons [] = (0,[])
uncons (x:xs) = (x,xs)
printAsChar :: Int -> IO ()
printAsChar i = putStr $ [chr i]
main = do
t
Solution
Disclaimer: I know nothing about Frege, all comments apply to Haskell only.
1)
Running hlint on your code shows places where you can remove
2)
In
3)
hlint will tell you the $ is redundant:
You can use
and finally get:
You have a strange asymmetry - output uses
If you want to output numbers longer than 1 character, use
4)
I would merge
5)
6)
If you remove the requirement to print the tape (is it needed for debugging only?), you can use an infinite list:
and get rid of
1)
Running hlint on your code shows places where you can remove
$ and brackets. Please do it!2)
In
exec, you always do exec prog tape after finishing current instruction. So you are iterating the list in some sense. This is a fold.exec :: [Op] -> Tape -> IO Tape
exec prog tape = foldM f tape prog
where f (Tape ls c rs) Plus = return $ Tape ls (c+1) rs
f (Tape ls c rs) Minus = return $ Tape ls (c-1) rs
f (Tape ls c rs) GoLeft = let (hd, tl) = uncons ls in return $ Tape tl hd (c:rs)
f (Tape ls c rs) GoRight = let (hd, tl) = uncons rs in return $ Tape (c:ls) hd tl
f tape Output = printAsChar (cell tape) >> return tape
f (Tape ls _ rs) Input = do n return tape
| otherwise -> do tape' <- exec loop tape
f tape' again3)
printAsChar i = putStr $ [chr i]hlint will tell you the $ is redundant:
printAsChar i = putStr [chr i]You can use
putChar:printAsChar i = putChar (chr i)and finally get:
printAsChar = putChar . chrYou have a strange asymmetry - output uses
chr, and input digitToInt. These are not inverses! digitToInt '0' is 0, but chr 0 is '\NUL', not '0'.If you want to output numbers longer than 1 character, use
printAsString = putStr . show4)
I would merge
execute and exec:execute :: [Op] -> IO Tape
execute = foldM f (Tape [] 0 [])
where f = ...5)
putStrLn $ "\n" ++ show tape ++ "\n"putStrLn already adds '\n" to the end, you might remove it.6)
If you remove the requirement to print the tape (is it needed for debugging only?), you can use an infinite list:
execute = foldM f (Tape (repeat 0) 0 (repeat 0))and get rid of
uncons:f (Tape (hd:tl) c rs) GoLeft = return $ Tape tl hd (c:rs)
f (Tape ls c (hd:tl)) GoRight = return $ Tape (c:ls) hd tlCode Snippets
exec :: [Op] -> Tape -> IO Tape
exec prog tape = foldM f tape prog
where f (Tape ls c rs) Plus = return $ Tape ls (c+1) rs
f (Tape ls c rs) Minus = return $ Tape ls (c-1) rs
f (Tape ls c rs) GoLeft = let (hd, tl) = uncons ls in return $ Tape tl hd (c:rs)
f (Tape ls c rs) GoRight = let (hd, tl) = uncons rs in return $ Tape (c:ls) hd tl
f tape Output = printAsChar (cell tape) >> return tape
f (Tape ls _ rs) Input = do n <- getChar
return $ Tape ls (digitToInt n) rs
f tape again@(Loop loop) | cell tape == 0 -> return tape
| otherwise -> do tape' <- exec loop tape
f tape' againprintAsChar i = putStr $ [chr i]printAsChar i = putStr [chr i]printAsChar i = putChar (chr i)printAsChar = putChar . chrContext
StackExchange Code Review Q#11525, answer score: 7
Revisions (0)
No revisions yet.