156 lines
5.1 KiB
Haskell
156 lines
5.1 KiB
Haskell
-- vim: set ts=4 sw=4 et tw=80:
|
|
|
|
module Interpreter where
|
|
import Data.Maybe (catMaybes)
|
|
import Control.Monad (liftM, ap)
|
|
import Debug.Trace
|
|
|
|
data Instruction = TapeLeft | TapeRight | Add | Sub | Out | In | LoopStart | LoopEnd
|
|
deriving (Eq, Show)
|
|
|
|
parseInstr :: Char -> Maybe Instruction
|
|
parseInstr '<' = Just TapeLeft
|
|
parseInstr '>' = Just TapeRight
|
|
parseInstr '+' = Just Add
|
|
parseInstr '-' = Just Sub
|
|
parseInstr '.' = Just Out
|
|
parseInstr ',' = Just In
|
|
parseInstr '[' = Just LoopStart
|
|
parseInstr ']' = Just LoopEnd
|
|
parseInstr _ = Nothing
|
|
|
|
newtype Byte = Byte Int deriving (Eq, Ord, Read, Show)
|
|
chr :: Byte -> Char
|
|
chr (Byte i) = toEnum i :: Char
|
|
|
|
updateCell :: Instruction -> Byte -> Byte
|
|
updateCell Add (Byte 255) = Byte 0
|
|
updateCell Sub (Byte 0) = Byte 255
|
|
updateCell Add (Byte i) = Byte (i + 1)
|
|
updateCell Sub (Byte i) = Byte (i - 1)
|
|
|
|
type Tape = [Byte]
|
|
type Program = [Instruction]
|
|
|
|
data State = State {
|
|
tape :: Tape,
|
|
dp :: Int,
|
|
output :: String,
|
|
program :: Program,
|
|
ip :: Int } deriving (Show)
|
|
|
|
data Execution a = Working a | Crash Error | Done String deriving (Show)
|
|
|
|
instance Monad Execution where
|
|
(Crash e) >>= _ = Crash e
|
|
(Done t) >>= _ = Done t
|
|
(Working d) >>= f = f d
|
|
|
|
instance Functor Execution where
|
|
fmap = liftM
|
|
|
|
instance Applicative Execution where
|
|
pure = return
|
|
(<*>) = ap
|
|
|
|
toProgram :: String -> Program
|
|
toProgram s = catMaybes $ fmap parseInstr s
|
|
|
|
tapeHelp :: Tape -> Int -> (Byte -> Byte) -> Tape
|
|
tapeHelp (t:tt) 0 alter = alter t : tt
|
|
tapeHelp (t:tt) dp alter = t : (tapeHelp tt (dp-1) alter)
|
|
|
|
data Error = NegTape | LoopNoMatch deriving (Show)
|
|
|
|
errorDesc :: Error -> String
|
|
errorDesc NegTape = "ERROR: '<' not working. Cannot access negative tape positions."
|
|
errorDesc LoopNoMatch = "ERROR: '[' or ']' not working. Matching parenthesis not found."
|
|
|
|
incrIP :: State -> State
|
|
incrIP p = p { ip = ip p + 1 }
|
|
|
|
execUpdate :: Instruction -> State -> State
|
|
execUpdate i p = p { tape = newTape }
|
|
where newTape = tapeHelp (tape p) (dp p) (updateCell i)
|
|
|
|
execTapeLeft :: State -> Execution State
|
|
execTapeLeft p = case dp p of 0 -> Crash NegTape
|
|
n -> Working p { dp = n - 1 }
|
|
|
|
execTapeRight :: State -> State
|
|
execTapeRight p = p { tape = tape p ++ newTape, dp = dp p + 1 }
|
|
where newTape = case dp p == length (tape p) - 1 of True -> [Byte 0]
|
|
_ -> []
|
|
|
|
execIn :: State -> IO (Execution State)
|
|
execIn p = do chr <- getChar
|
|
tp <- pure $ fromEnum chr
|
|
return $ Working p { tape = tapeHelp (tape p) (dp p) (\_ -> Byte tp) }
|
|
|
|
execOut :: State -> State
|
|
execOut p = p { output = output p ++ [chr char]}
|
|
where char = tape p !! dp p
|
|
|
|
findMatching :: Program -> Instruction -> Int -> Maybe Int
|
|
findMatching prg toFind = fmHelper $ -1
|
|
where (oppos, limit, next) = case toFind of
|
|
LoopEnd -> (LoopStart, length prg, (+1))
|
|
LoopStart -> (LoopEnd, 0, (-1+))
|
|
|
|
fmHelper :: Int -> Int -> Maybe Int
|
|
fmHelper acc s
|
|
| s == limit = Nothing
|
|
| acc == 0 && c == toFind = Just s
|
|
| c == toFind = fmHelper (acc - 1) $ next s
|
|
| c == oppos = fmHelper (acc + 1) $ next s
|
|
| otherwise = fmHelper acc $ next s
|
|
where c = prg !! s
|
|
|
|
execLoop :: Instruction -> State -> Execution State
|
|
execLoop d w = case posOrF of Just n -> Working w { ip = n }
|
|
Nothing -> Crash LoopNoMatch
|
|
where isZero = (tape w !! dp w) == Byte 0
|
|
jump = case d of LoopStart -> isZero
|
|
LoopEnd -> not isZero
|
|
posOrF = case jump of True -> findMatching (program w) d (ip w)
|
|
_ -> Just $ ip w
|
|
|
|
execute :: State -> IO (Execution State)
|
|
execute w = runInstr w >>= andThen
|
|
where instrFor :: State -> State -> IO (Execution State)
|
|
instrFor w = case (program w !! ip w) of
|
|
TapeLeft -> fmap return $ execTapeLeft
|
|
TapeRight -> return . return . execTapeRight
|
|
Add -> return . return . (execUpdate Add)
|
|
Sub -> return . return . (execUpdate Sub)
|
|
In -> execIn
|
|
Out -> return . return . execOut
|
|
l -> fmap return $ execLoop l
|
|
|
|
andThen :: Execution State -> IO (Execution State)
|
|
andThen s = case s >>= checkDone of
|
|
Working s -> execute s
|
|
t -> return t
|
|
|
|
runInstr :: State -> IO (Execution State)
|
|
runInstr w = instrFor w $ w
|
|
|
|
checkDone :: State -> Execution State
|
|
checkDone ps
|
|
| (length . program) ps == newIP = Done $ output ps
|
|
| otherwise = Working $ ps { ip = newIP }
|
|
where newIP = ip ps + 1
|
|
|
|
|
|
initState :: Program -> State
|
|
initState p = State {
|
|
tape = [Byte 0],
|
|
dp = 0,
|
|
output = "",
|
|
program = p,
|
|
ip = 0}
|
|
|
|
run :: String -> IO (Execution State)
|
|
run "" = return $ Done ""
|
|
run s = execute . initState . catMaybes . fmap parseInstr $ s
|