module Language.Brainfuck.Eval (
eval
) where
import Data.Array ((//), (!))
import Data.Char (ord, chr)
import Data.List (elemIndices)
import Data.Maybe (listToMaybe)
import Data.Word (Word8)
import Language.Brainfuck.Types
import Language.Brainfuck.Parse
eval :: Tape -> String -> IO Tape
eval storage program =
let instructions = parse program
in go storage instructions instructions 0 (PC 0)
where go :: Tape -> [Term] -> [Term] ->
DataPointer -> ProgramCounter -> IO Tape
go tape [] _ _ _ = return tape
go tape (IncDP:ops) os pos pc = go tape ops os (pos+1) (next pc)
go tape (DecDP:ops) os pos pc = go tape ops os (pos1) (next pc)
go tape (IncByte:ops) os pos pc =
go (modPos tape pos (+1)) ops os pos (next pc)
go tape (DecByte:ops) os pos pc =
go (modPos tape pos (subtract 1)) ops os pos (next pc)
go tape (OutByte:ops) os pos pc =
(showAt tape pos) >> go tape ops os pos (next pc)
go tape (InByte:ops) os pos pc = do
c <- getChar
let b = fromIntegral $ ord c :: Word8
go (tape // [(pos, b)]) ops os pos (next pc)
go tape (JumpForward:ops) os pos pc = if shouldJump Forward tape pos
then jump tape Forward os pos pc
else go tape ops os pos (next pc)
go tape (JumpBackward:ops) os pos pc = if shouldJump Backward tape pos
then jump tape Backward os pos pc
else go tape ops os pos (next pc)
jump tape dir os pos (PC pc) = do
let jumpTo = findFunc dir pc (flipDir dir) os
case jumpTo of
Nothing -> print "jump not found" >> return tape
(Just p) -> go tape (drop p os) os pos (PC p)
dirToJump Forward = JumpForward
dirToJump Backward = JumpBackward
shouldJump Forward tape pos = (tape ! pos) == 0
shouldJump Backward tape pos = (tape ! pos) /= 0
findIx p x = listToMaybe . filter p . elemIndices x
findIxAfter pos = findIx (>pos)
findIxBefore pos = findIx (<pos)
findFunc Forward = findIxAfter
findFunc Backward = findIxBefore
flipDir Forward = dirToJump Backward
flipDir Backward = dirToJump Forward
modPos arr pos f = arr // [(pos, f (arr ! pos))]
showAt arr pos = putChar $ (chr . fromIntegral) $ (arr ! pos)
next (PC n) = PC $ n + 1