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