Removed IP from State
This commit is contained in:
parent
60cfc648ea
commit
8bd02f88ef
|
@ -5,8 +5,8 @@ import Control.Monad (liftM, ap)
|
||||||
import Debug.Trace
|
import Debug.Trace
|
||||||
import Control.Monad.Trans.State
|
import Control.Monad.Trans.State
|
||||||
|
|
||||||
data Instruction = TapeLeft | TapeRight | Add | Sub | Out | In | LoopStart | LoopEnd
|
data Instruction = TapeLeft | TapeRight | Add | Sub | Out | In | LoopStart |
|
||||||
deriving (Eq, Show)
|
LoopEnd deriving (Eq, Show)
|
||||||
|
|
||||||
parseInstr :: Char -> Maybe Instruction
|
parseInstr :: Char -> Maybe Instruction
|
||||||
parseInstr '<' = Just TapeLeft
|
parseInstr '<' = Just TapeLeft
|
||||||
|
@ -32,8 +32,10 @@ updateCell Sub (Byte i) = Byte (i - 1)
|
||||||
type Tape = [Byte]
|
type Tape = [Byte]
|
||||||
type Program = [Instruction]
|
type Program = [Instruction]
|
||||||
|
|
||||||
data Memory = Memory { tape :: Tape, dp :: Int, ip :: Int } deriving (Show)
|
data Memory = Memory { tape :: Tape, dp :: Int } deriving (Show)
|
||||||
data Term = Working | Crash Error | Done deriving (Show)
|
|
||||||
|
-- Consider putting IP in Termination output
|
||||||
|
data Term = Next Int | Crash Error Int | Done deriving (Show)
|
||||||
|
|
||||||
toProgram :: String -> Program
|
toProgram :: String -> Program
|
||||||
toProgram s = catMaybes $ fmap parseInstr s
|
toProgram s = catMaybes $ fmap parseInstr s
|
||||||
|
@ -48,32 +50,29 @@ errorDesc :: Error -> String
|
||||||
errorDesc NegTape = "ERROR: '<' not working. Cannot access negative tape positions."
|
errorDesc NegTape = "ERROR: '<' not working. Cannot access negative tape positions."
|
||||||
errorDesc LoopNoMatch = "ERROR: '[' or ']' not working. Matching parenthesis not found."
|
errorDesc LoopNoMatch = "ERROR: '[' or ']' not working. Matching parenthesis not found."
|
||||||
|
|
||||||
incrIP :: Memory -> Memory
|
execUpdate :: Instruction -> State Memory (Maybe Error)
|
||||||
incrIP p = p { ip = ip p + 1 }
|
|
||||||
|
|
||||||
execUpdate :: Instruction -> State Memory Term
|
|
||||||
execUpdate i = state stateF
|
execUpdate i = state stateF
|
||||||
where stateF p = (Working, p { tape = newTape p })
|
where stateF p = (Nothing, p { tape = newTape p })
|
||||||
newTape p = tapeHelp (tape p) (dp p) (updateCell i)
|
newTape p = tapeHelp (tape p) (dp p) (updateCell i)
|
||||||
|
|
||||||
execTapeLeft :: State Memory Term
|
execTapeLeft :: State Memory (Maybe Error)
|
||||||
execTapeLeft = state $ \p -> case dp p of 0 -> (Crash NegTape, p)
|
execTapeLeft = state $ \p -> case dp p of 0 -> (Just NegTape, p)
|
||||||
n -> (Working, p { dp = n - 1 })
|
n -> (Nothing, p { dp = n - 1 })
|
||||||
|
|
||||||
execTapeRight :: State Memory Term
|
execTapeRight :: State Memory (Maybe Error)
|
||||||
execTapeRight = state $ \p -> (Working, newMem p)
|
execTapeRight = state $ \p -> (Nothing, newMem p)
|
||||||
where newMem p = p { tape = tape p ++ newTape p, dp = dp p + 1 }
|
where newMem p = p { tape = tape p ++ newTape p, dp = dp p + 1 }
|
||||||
newTape p = case dp p == length (tape p) - 1 of True -> [Byte 0]
|
newTape p = case dp p == length (tape p) - 1 of True -> [Byte 0]
|
||||||
_ -> []
|
_ -> []
|
||||||
|
|
||||||
execIn :: StateT Memory IO Term
|
execIn :: StateT Memory IO (Maybe Error)
|
||||||
execIn = StateT $ \p -> do chr <- getChar
|
execIn = StateT $ \p -> do chr <- getChar
|
||||||
tp <- pure $ fromEnum chr
|
tp <- pure $ fromEnum chr
|
||||||
return (Working, newTape tp p)
|
return (Nothing, newTape tp p)
|
||||||
where newTape tp p = p { tape = tapeHelp (tape p) (dp p) (\_ -> Byte tp) }
|
where newTape tp p = p { tape = tapeHelp (tape p) (dp p) (\_ -> Byte tp) }
|
||||||
|
|
||||||
execOut :: StateT Memory IO Term
|
execOut :: StateT Memory IO (Maybe Error)
|
||||||
execOut = StateT $ \p -> putChar (chr (tape p !! dp p)) >> (return (Working, p))
|
execOut = StateT $ \p -> putChar (chr (tape p !! dp p)) >> (return (Nothing, p))
|
||||||
|
|
||||||
findMatching :: Program -> Instruction -> Int -> Maybe Int
|
findMatching :: Program -> Instruction -> Int -> Maybe Int
|
||||||
findMatching prg par = fmHelper $ -1
|
findMatching prg par = fmHelper $ -1
|
||||||
|
@ -90,51 +89,48 @@ findMatching prg par = fmHelper $ -1
|
||||||
| otherwise = fmHelper acc $ next s
|
| otherwise = fmHelper acc $ next s
|
||||||
where c = prg !! s
|
where c = prg !! s
|
||||||
|
|
||||||
execLoop :: Program -> Instruction -> State Memory Term
|
execLoop :: Program -> Instruction -> Int -> State Memory Term
|
||||||
execLoop p d = state $ \w -> case posOrF w of Just n -> (Working, w { ip = n })
|
execLoop p d ip = state $ \w -> case posOrF w of Just n -> (Next n, w)
|
||||||
Nothing -> (Crash LoopNoMatch, w)
|
Nothing -> (Crash LoopNoMatch ip, w)
|
||||||
where isZero w = (tape w !! dp w) == Byte 0
|
where isZero w = (tape w !! dp w) == Byte 0
|
||||||
jump = case d of LoopStart -> isZero
|
jump = case d of LoopStart -> isZero
|
||||||
LoopEnd -> not . isZero
|
LoopEnd -> not . isZero
|
||||||
posOrF w = case jump w of True -> findMatching p d (ip w)
|
posOrF w = case jump w of True -> findMatching p d ip
|
||||||
_ -> Just $ ip w
|
_ -> Just ip
|
||||||
|
|
||||||
execute :: Program -> Memory -> IO (Term, Memory)
|
execute :: Program -> Memory -> IO (Term, Memory)
|
||||||
execute p = runStateT runInstruction
|
execute p = runStateT (runInstruction 0)
|
||||||
where runInstruction :: StateT Memory IO Term
|
where runInstruction :: Int -> StateT Memory IO Term
|
||||||
runInstruction = do i <- runInstr
|
runInstruction ip = fmap checkDone (instrFor ip) >>= print >>= loopBack
|
||||||
d <- checkDone i
|
where loopBack (Next i) = runInstruction i
|
||||||
loopBack d
|
loopBack x = return x
|
||||||
where loopBack s = case s of Working -> runInstruction
|
print :: Term -> StateT Memory IO Term
|
||||||
t -> return t
|
print a = StateT $ \s -> return $ traceShowId (a, s)
|
||||||
|
|
||||||
runInstr :: StateT Memory IO Term
|
instrFor :: Int -> StateT Memory IO Term
|
||||||
runInstr = StateT $ \m -> (runStateT (instrFor m) m)
|
instrFor ip = case (p !! ip) of
|
||||||
|
TapeLeft -> toTerm ip . toStateT $ execTapeLeft
|
||||||
|
TapeRight -> toTerm ip . toStateT $ execTapeRight
|
||||||
|
Add -> toTerm ip . toStateT $ execUpdate Add
|
||||||
|
Sub -> toTerm ip . toStateT $ execUpdate Sub
|
||||||
|
In -> toTerm ip execIn
|
||||||
|
Out -> toTerm ip execOut
|
||||||
|
l -> toStateT $ execLoop p l ip
|
||||||
|
|
||||||
instrFor :: Memory -> StateT Memory IO Term
|
toTerm ip = fmap termMem
|
||||||
instrFor w = case traceShowId $ (p !! ip w) of
|
where termMem Nothing = Next $ ip + 1
|
||||||
TapeLeft -> toStateT execTapeLeft
|
termMem (Just e) = Crash e ip
|
||||||
TapeRight -> toStateT execTapeRight
|
|
||||||
Add -> toStateT $ execUpdate Add
|
|
||||||
Sub -> toStateT $ execUpdate Sub
|
|
||||||
In -> execIn
|
|
||||||
Out -> execOut
|
|
||||||
l -> toStateT $ execLoop p l
|
|
||||||
|
|
||||||
toStateT :: (Monad m) => State s a -> StateT s m a
|
toStateT :: (Monad m) => State s a -> StateT s m a
|
||||||
toStateT x = StateT $ (\s -> return . runState x $ s)
|
toStateT x = StateT $ (\s -> return . runState x $ s)
|
||||||
|
|
||||||
checkDone :: Term -> StateT Memory IO Term
|
checkDone :: Term -> Term
|
||||||
checkDone Working = StateT $ return . isDone
|
checkDone (Next x) = if x == (length p) then Done else Next x
|
||||||
where isDone ps
|
checkDone x = x
|
||||||
| length p == newIP = (Done, ps)
|
|
||||||
| otherwise = traceShowId (Working, ps { ip = newIP })
|
|
||||||
where newIP = ip ps + 1
|
|
||||||
checkDone t = return t
|
|
||||||
|
|
||||||
|
|
||||||
initMemory :: Memory
|
initMemory :: Memory
|
||||||
initMemory = Memory { tape = [Byte 0], dp = 0, ip = 0 }
|
initMemory = Memory { tape = [Byte 0], dp = 0 }
|
||||||
|
|
||||||
run :: String -> IO ((Term, Memory))
|
run :: String -> IO ((Term, Memory))
|
||||||
run p = case catMaybes . fmap parseInstr $ p of [] -> return (Done, initMemory)
|
run p = case catMaybes . fmap parseInstr $ p of [] -> return (Done, initMemory)
|
||||||
|
|
Loading…
Reference in New Issue
Block a user