105 lines
3.3 KiB
Haskell
105 lines
3.3 KiB
Haskell
-- vim: set ts=4 sw=4 et tw=80:
|
|
|
|
module Interpreter where
|
|
import Data.Maybe (catMaybes)
|
|
|
|
data Instruction = TapeLeft | TapeRight | Add | Sub | Out | In | LoopStart | LoopEnd
|
|
|
|
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
|
|
chr :: Byte -> Char
|
|
chr (Byte i) = toEnum i :: Char
|
|
|
|
incr :: Byte -> Byte
|
|
incr (Byte 255) = Byte 0
|
|
incr (Byte i) = Byte (i + 1)
|
|
|
|
decr :: Byte -> Byte
|
|
decr (Byte 0) = Byte 255
|
|
decr (Byte i) = Byte (i - 1)
|
|
|
|
type Tape = [Byte]
|
|
type Program = [Instruction]
|
|
type IP = Int
|
|
type DP = Int
|
|
|
|
data ProgState = ProgState {
|
|
tape :: Tape,
|
|
dp :: DP,
|
|
output :: String,
|
|
program :: Program,
|
|
ip :: IP }
|
|
|
|
toProgram :: String -> [Instruction]
|
|
toProgram s = catMaybes $ fmap parseInstr s
|
|
|
|
tapeHelp :: Tape -> DP -> (Byte -> Byte) -> Tape
|
|
tapeHelp (t:tt) 0 alter = alter t : tt
|
|
tapeHelp (t:tt) dp alter = t : (tapeHelp tt dp alter)
|
|
|
|
data Error = NegTape | LoopNoMatch
|
|
|
|
errorDesc :: Error -> String
|
|
errorDesc NegTape = "ERROR: '<' not working. Cannot access negative tape positions."
|
|
errorDesc LoopNoMatch = "ERROR: '[' or ']' not working. Matching parenthesis not found."
|
|
|
|
incrIP :: ProgState -> ProgState
|
|
incrIP p = p { ip = ip p + 1 }
|
|
|
|
execAdd :: ProgState -> Either Error ProgState
|
|
execAdd p = Right p { tape = newTape }
|
|
where newTape = tapeHelp (tape p) (dp p) incr
|
|
|
|
execSub :: ProgState -> Either Error ProgState
|
|
execSub p = Right p { tape = newTape }
|
|
where newTape = tapeHelp (tape p) (dp p) decr
|
|
|
|
execTapeLeft :: ProgState -> Either Error ProgState
|
|
execTapeLeft p = case dp p of 0 -> Left NegTape
|
|
n -> Right p { dp = n - 1 }
|
|
|
|
execTapeRight :: ProgState -> Either Error ProgState
|
|
execTapeRight p = Right p { tape = if endOfType then tape p ++ [Byte 0] else tape p }
|
|
where endOfType = dp p == length (tape p) - 1
|
|
|
|
execOut :: ProgState -> Either Error ProgState
|
|
execOut p = Right p { output = output p ++ [chr char]}
|
|
where char = (tape p) !! dp p
|
|
|
|
data WalkingDirection = Forward | Backward
|
|
|
|
|
|
findMatching :: Program -> DP -> WalkingDirection -> Maybe IP
|
|
findMatching prg start wd = case wd of
|
|
Forward -> fmHelper start 0 LoopEnd LoopStart (+1) (length prg)
|
|
Backward -> fmHelper start 0 LoopStart LoopEnd (-1) 0
|
|
where fmHelper :: IP -> Int -> Instruction -> Instruction -> (IP -> IP)
|
|
-> Int -> Maybe DP
|
|
fmHelper s acc b ob upd limit
|
|
| acc == 0 && c == b = Just s
|
|
| c == b = fmHelper (upd s) (acc - 1) b ob upd limit
|
|
| c == ob = fmHelper (upd s) (acc + 1) b ob upd limit
|
|
| s == limit = Nothing
|
|
| otherwise = fmHelper (upd s) acc b ob upd limit
|
|
where c = prg !! start
|
|
|
|
execLoopStart :: ProgState -> Either Error ProgState
|
|
execLoopStart w = case newIP of
|
|
Just n -> Right w { ip = n }
|
|
Nothing -> Left LoopNoMatch
|
|
where jump = (tape w !! dp w) == 0
|
|
posOrF = if jump then findMatching (program w) (ip w) Forward else Just $ ip w
|
|
newIP = fmap (+1) posOrF
|
|
|
|
|