module Language.Brainfuck.Eval (
eval
) where
import Data.Array ((//), (!))
import Data.Char (ord, chr)
import Data.Tuple (swap)
import Data.Word (Word8)
import Language.Brainfuck.Types
import Language.Brainfuck.Parse
eval :: Tape -> String -> IO Tape
eval storage program =
let instructions = parse program
jumpPairs = matchJumps instructions
in case jumpPairs of
(Right e) -> print e >> return storage
(Left j) -> let jrev = map swap j in
step storage instructions instructions 0 (PC 0) j jrev
where step :: Tape -> [Term] -> [Term] ->
DataPointer -> ProgramCounter -> JumpPairs -> JumpPairs ->
IO Tape
step tape [] _ _ _ _ _ = return tape
step tape (o:ops) os pos pc jp jpr = case o of
IncDP -> step tape ops os (pos+1) (next pc) jp jpr
DecDP -> step tape ops os (pos1) (next pc) jp jpr
IncByte -> step (modAt tape pos (+1)) ops os pos (next pc) jp jpr
DecByte -> step (modAt tape pos (subtract 1)) ops os pos (next pc) jp jpr
OutByte -> showAt tape pos >> step tape ops os pos (next pc) jp jpr
InByte -> do
c <- getChar
let b = fromIntegral $ ord c :: Word8
step (tape // [(pos, b)]) ops os pos (next pc) jp jpr
JumpForward -> doJump Forward tape ops os pos pc jp jpr
JumpBackward -> doJump Backward tape ops os pos pc jp jpr
doJump :: Direction -> Tape -> [Term] -> [Term] ->
DataPointer -> ProgramCounter -> JumpPairs -> JumpPairs ->
IO Tape
doJump dir tape ops os pos pc jp jpr =
if shouldJump dir tape pos
then jump tape dir os pos pc jp jpr
else step tape ops os pos (next pc) jp jpr
jump :: Tape -> Direction -> [Term] ->
DataPointer -> ProgramCounter -> JumpPairs -> JumpPairs ->
IO Tape
jump tape dir os pos (PC pc) jp jpr = do
let jumpTo = lookup pc (if dir == Forward then jp else jpr)
case jumpTo of
Nothing -> return tape
(Just p) -> step tape (drop p os) os pos (PC p) jp jpr
shouldJump Forward tape pos = (tape ! pos) == 0
shouldJump Backward tape pos = (tape ! pos) /= 0
modAt arr pos f = arr // [(pos, f (arr ! pos))]
showAt arr pos = putChar $ (chr . fromIntegral) (arr ! pos)
next (PC n) = PC $ n + 1