Create a gist now

Instantly share code, notes, and snippets.

What would you like to do?
Pure, Lazy brainfuck interpreter in haskell
import Data.Char
import Control.Monad.State.Lazy
import Control.Monad.Loops
import Text.ParserCombinators.Parsec hiding (State)
import System.Environment
data BF = NextPos | PrevPos | Inc |
Dec | Out | In | While [BF]
deriving(Show,Eq)
type BFProg = [BF]
data BFMachine = BFMachine { mem :: ([Int], Int, [Int])
, display :: String
, code :: BFProg
, stack :: [BFProg]
, input :: String
}
deriving (Show,Eq)
cellToChar = chr . fromIntegral
-- Parser from here http://sabbatical-year.blogspot.ru/2008/01/brainfuck-its-last-one-i-promise.html
program :: Parser [BF]
program = many instruction
instruction :: Parser (BF)
instruction = simple <|> loop
loop :: Parser (BF)
loop = between (char '[') (char ']') program >>= \p -> return $ While p
simple :: Parser (BF)
simple = ( (char '+') >> return Inc)
<|> ( (char '-') >> return Dec)
<|> ( (char '>') >> return NextPos)
<|> ( (char '<') >> return PrevPos)
<|> ( (char '.') >> return Out)
<|> ( (char ',') >> return In)
memSet (l,p,r) x = (l,x,r)
memInc (l,p,r) = (l,(p+1),r)
memDec (l,p,r) | p <= 0 = (l,p-1,r)
| otherwise = (l,p-1,r)
memShiftLeft (l,!p,r) = (p:l , head r, drop 1 r)
memShiftRight (l,!p,r) = (drop 1 l, head l, p:r)
memValue (l,p,r) = p
stepBF = do
s@(BFMachine mem display c stack input) <- get
let h = take 1 c
let t = drop 1 c
case h of
[Inc] ->
put (s {mem = memInc mem, code = t})
[Dec] ->
put (s {mem = memDec mem, code = t})
[Out] ->
put (s {display = (cellToChar (memValue mem) : display), code = t})
[In] ->
put (s {mem = memSet mem (ord (head input)), code = t, input = drop 1 input})
[NextPos] ->
put (BFMachine (memShiftLeft mem) display (t) stack input)
[PrevPos] ->
put (BFMachine (memShiftRight mem) display (t) stack input )
-- save loop body and tail after loop on stack
[While body] | memValue mem /= 0 -> do
put (BFMachine mem display body (body:t:stack) input)
-- no code in current block and mem=0 -> end of loop
-- return to tail on stack and drop loop body and tail from stack
[] | stack /= [] && memValue mem == 0 ->
put (BFMachine mem display (stack !! 1) (drop 2 stack) input)
-- no code in current block and mem /= 0 -> repeat loop
-- return to loop body from stack
[] | stack /= [] && memValue mem /= 0 ->
put (BFMachine mem display (head stack) (stack) input)
_ -> put (BFMachine mem display t stack input)
if h == [Out]
then return $ [cellToChar (memValue mem)]
else return ""
showBF :: [BF] -> String
showBF a = showBF' 0 a
where
showBF' d [] = []
showBF' d (x:xs) =
case x of
Inc -> '+': showBF' d xs
In -> ',': showBF' d xs
Out -> '.': showBF' d xs
Dec -> '-': showBF' d xs
NextPos -> '>': showBF' d xs
PrevPos -> '<': showBF' d xs
While body -> ( "\n" ++ replicate d ' ' ++ ('[' : showBF' (d+1) body) ++
"\n" ++ replicate d ' ' ++ "]" ++ showBF' (d) xs)
debugBF (BFMachine (l,p,r) display c stack input) = do
let nMem = 64
putStrLn ""
putStrLn "___________________________________"
putStrLn $ "Code: " ++ showBF c
putStrLn $ "Display: " ++ reverse display
putStrLn "Stack:"
mapM_ (putStrLn . (++"\n") . showBF) (stack)
putStrLn $ "Code+Stack size: " ++ show( length (showBF c ++ concatMap showBF stack))
putStrLn "Memory:"
putStrLn $ ( unwords $ map show $ reverse $ take nMem l)
++ "\n {" ++ show p ++ "} \n"
++ (unwords $ map show $ take nMem r)
putStrLn "___________________________________"
printDisplay (BFMachine (l,p,r) display c stack input) = do
putStrLn $ reverse display
isBFChar '+' = True
isBFChar '-' = True
isBFChar '[' = True
isBFChar ']' = True
isBFChar '>' = True
isBFChar '<' = True
isBFChar ',' = True
isBFChar '.' = True
isBFChar _ = False
isEndProg = do
state <- get
return $ (stack state == []) && (code state == [])
runProg = runState (stepBF `untilM` isEndProg)
runProgSteps steps = runState (replicateM steps stepBF)
loadCode code input = (BFMachine (repeat 0, 0, repeat 0 )
[] code [] input)
interactive s0 | (stack s0 == []) && (code s0 == []) = return ()
interactive s0 = do
let (output, s1) = runState stepBF s0
-- if next command is input then
-- add char to input array
putStr output
if (take 1 ( code s1) == [In])
then do c <- getChar
interactive s1 {input = c:(input s1)}
else interactive s1
parseBF src =
case parse program "" (filter (isBFChar) src) of
Right prog -> prog
Left msg -> error $ show msg
main = do
args <- getArgs
case args of
-- interactive mode
[filename] -> do
file <- readFile filename
let prog = parseBF file
let init = loadCode prog ""
interactive init
-- pure mode (fastest)
[filename,input] -> do
file <- readFile filename
let prog = parseBF file
let init = loadCode prog input
let (output,machine) = runProg init
putStrLn $ concat $ output
-- debug mode (goto to n step)
["-d", filename,steps,input] | all isDigit steps -> do
file <- readFile filename
let prog = parseBF file
let init = loadCode prog input
let nsteps = read steps
let (output,machine) = runProgSteps nsteps init
debugBF machine
_ -> do
putStrLn "use: ./bf prog.bf"
putStrLn " fastest ./bf prog.bf input"
putStrLn " debug ./bf -d prog.bf input n"
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment