public
Last active

Pure, Lazy brainfuck interpreter in haskell

  • Download Gist
bf_adz.hs
Haskell
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204
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"

Please sign in to comment on this gist.

Something went wrong with that request. Please try again.