Skip to content

Instantly share code, notes, and snippets.

@adzeitor
Created November 20, 2012 16:32
  • Star 0 You must be signed in to star a gist
  • Fork 0 You must be signed in to fork a gist
Star You must be signed in to star a gist
Save adzeitor/4119051 to your computer and use it in GitHub Desktop.
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