Updated instruction types
This commit is contained in:
parent
02c382ca13
commit
a1a9aec6bd
1 changed files with 25 additions and 25 deletions
|
@ -4,35 +4,37 @@ import Debug.Trace
|
|||
import Control.Monad.Trans.State
|
||||
import qualified Data.Vector as V
|
||||
|
||||
data Instruction = TapeLeft | TapeRight | Add | Sub | Out | In | LoopStart |
|
||||
LoopEnd deriving (Eq, Show)
|
||||
data UpdType = Add | Sub deriving (Eq, Show)
|
||||
data LoopType = Start | End deriving (Eq, Show)
|
||||
data Instruction = TapeLeft | TapeRight | Update UpdType | Out | In |
|
||||
Loop LoopType deriving (Eq, Show)
|
||||
|
||||
parseInstr :: Char -> Maybe Instruction
|
||||
parseInstr '<' = Just TapeLeft
|
||||
parseInstr '>' = Just TapeRight
|
||||
parseInstr '+' = Just Add
|
||||
parseInstr '-' = Just Sub
|
||||
parseInstr '+' = Just $ Update Add
|
||||
parseInstr '-' = Just $ Update Sub
|
||||
parseInstr '.' = Just Out
|
||||
parseInstr ',' = Just In
|
||||
parseInstr '[' = Just LoopStart
|
||||
parseInstr ']' = Just LoopEnd
|
||||
parseInstr '[' = Just $ Loop Start
|
||||
parseInstr ']' = Just $ Loop End
|
||||
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 :: UpdType -> 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 = V.Vector Byte
|
||||
type Program = V.Vector Instruction
|
||||
|
||||
data Memory = Memory { tape :: Tape, dp :: Int } deriving (Show)
|
||||
|
||||
type Program = V.Vector Instruction
|
||||
|
||||
-- Consider putting IP in Termination output
|
||||
data Term = Next Int | Crash Error Int | Done deriving (Show)
|
||||
|
||||
|
@ -50,7 +52,7 @@ errorDesc :: Error -> String
|
|||
errorDesc NegTape = "ERROR: '<' not working. Cannot access negative tape positions."
|
||||
errorDesc LoopNoMatch = "ERROR: '[' or ']' not working. Matching parenthesis not found."
|
||||
|
||||
execUpdate :: Instruction -> State Memory (Maybe Error)
|
||||
execUpdate :: UpdType -> State Memory (Maybe Error)
|
||||
execUpdate i = state stateF
|
||||
where stateF p = (Nothing, p { tape = newTape p })
|
||||
newTape p = tapeHelp (tape p) (dp p) (updateCell i)
|
||||
|
@ -76,28 +78,28 @@ execOut :: StateT Memory IO (Maybe Error)
|
|||
execOut = StateT $ \p -> putChar (chr $ tape p V.! dp p) >>
|
||||
(return (Nothing, p))
|
||||
|
||||
findMatching :: Program -> Instruction -> Int -> Maybe Int
|
||||
findMatching :: Program -> LoopType -> Int -> Maybe Int
|
||||
findMatching prg par = fmHelper $ -1
|
||||
where (oppos, limit, next) = case par of
|
||||
LoopStart -> (LoopEnd, length prg, (+1))
|
||||
LoopEnd -> (LoopStart, 0, (-1+))
|
||||
Start -> (End, length prg, (+1))
|
||||
End -> (Start, 0, (-1+))
|
||||
|
||||
fmHelper :: Int -> Int -> Maybe Int
|
||||
fmHelper acc s
|
||||
| s == limit = Nothing
|
||||
| acc == 0 && c == oppos = Just s
|
||||
| c == oppos = fmHelper (acc - 1) $ next s
|
||||
| c == par = fmHelper (acc + 1) $ next s
|
||||
| otherwise = fmHelper acc $ next s
|
||||
| s == limit = Nothing
|
||||
| acc == 0 && c == Loop oppos = Just s
|
||||
| c == Loop oppos = fmHelper (acc - 1) $ next s
|
||||
| c == Loop par = fmHelper (acc + 1) $ next s
|
||||
| otherwise = fmHelper acc $ next s
|
||||
where c = prg V.! s
|
||||
|
||||
execLoop :: Program -> Instruction -> Int -> State Memory Term
|
||||
execLoop :: Program -> LoopType -> Int -> State Memory Term
|
||||
execLoop p i ip = state $ \w -> case posOrF w of
|
||||
Just n -> (Next $ n + 1, w)
|
||||
Nothing -> (Crash LoopNoMatch ip, w)
|
||||
where posOrF ps = case ((tape ps V.! dp ps) == Byte 0, i) of
|
||||
(True, LoopStart) -> findMatching p i ip
|
||||
(False, LoopEnd) -> findMatching p i ip
|
||||
(True, Start) -> findMatching p i ip
|
||||
(False, End) -> findMatching p i ip
|
||||
_ -> Just ip
|
||||
|
||||
execute :: Program -> Memory -> IO (Term, Memory)
|
||||
|
@ -111,14 +113,12 @@ execute p = runStateT $ runInstruction 0
|
|||
|
||||
instrFor :: Int -> StateT Memory IO Term
|
||||
instrFor ip = case (p V.! ip) of
|
||||
Update t -> toTerm ip . toStateT $ execUpdate t
|
||||
Loop t -> toStateT $ execLoop p t ip
|
||||
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
|
||||
LoopStart -> toStateT $ execLoop p LoopStart ip
|
||||
LoopEnd -> toStateT $ execLoop p LoopEnd ip
|
||||
|
||||
toTerm ip = fmap termMem
|
||||
where termMem Nothing = Next $ ip + 1
|
||||
|
|
Loading…
Reference in a new issue