Rewritten loops and update tape operations
This commit is contained in:
Claudio Maggioni (maggicl)
parent
df9ac7f41c
commit
4dc1eeb3c3
1 changed files with 41 additions and 46 deletions
|
|
@ -23,13 +23,11 @@ newtype Byte = Byte Int deriving (Eq, Ord, Read, Show)
|
|||
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)
|
||||
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]
|
||||
|
|
@ -55,7 +53,7 @@ instance Applicative Execution where
|
|||
pure = return
|
||||
(<*>) = ap
|
||||
|
||||
toProgram :: String -> [Instruction]
|
||||
toProgram :: String -> Program
|
||||
toProgram s = catMaybes $ fmap parseInstr s
|
||||
|
||||
tapeHelp :: Tape -> Int -> (Byte -> Byte) -> Tape
|
||||
|
|
@ -71,61 +69,58 @@ errorDesc LoopNoMatch = "ERROR: '[' or ']' not working. Matching parenthesis not
|
|||
incrIP :: State -> State
|
||||
incrIP p = p { ip = ip p + 1 }
|
||||
|
||||
execAdd :: State -> Execution State
|
||||
execAdd p = Working p { tape = newTape }
|
||||
where newTape = tapeHelp (tape p) (dp p) incr
|
||||
|
||||
execSub :: State -> Execution State
|
||||
execSub p = Working p { tape = newTape }
|
||||
where newTape = tapeHelp (tape p) (dp p) decr
|
||||
execUpdate :: Instruction -> State -> Execution State
|
||||
execUpdate i p = Working 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 -> Execution State
|
||||
execTapeRight p = Working p { tape = if endOfType then tape p ++ [Byte 0] else tape p, dp = dp p + 1 }
|
||||
where endOfType = dp p == length (tape p) - 1
|
||||
execTapeRight p = Working p { tape = tape p ++ newTape, dp = dp p + 1 }
|
||||
where newTape = case dp p == length (tape p) - 1 of True -> [Byte 0]
|
||||
_ -> []
|
||||
|
||||
execOut :: State -> Execution State
|
||||
execOut p = Working p { output = output p ++ [chr char]}
|
||||
where char = tape p !! dp p
|
||||
|
||||
data WalkingDirection = Forward | Backward deriving (Eq, Show)
|
||||
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+))
|
||||
|
||||
findMatching :: Program -> Int -> WalkingDirection -> Maybe Int
|
||||
findMatching prg start wd = case wd of
|
||||
Forward -> fmHelper start (-1) LoopEnd LoopStart (+1) (length prg)
|
||||
Backward -> fmHelper start (-1) LoopStart LoopEnd (-1+) 0
|
||||
where fmHelper :: Int -> Int -> Instruction -> Instruction -> (Int -> Int)
|
||||
-> Int -> Maybe Int
|
||||
fmHelper s acc b ob upd limit
|
||||
| s == limit = Nothing
|
||||
| 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
|
||||
| otherwise = fmHelper (upd s) acc b ob upd limit
|
||||
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 :: WalkingDirection -> State -> Execution State
|
||||
execLoop d w = case posOrF of
|
||||
Just n -> Working w { ip = n }
|
||||
Nothing -> Crash LoopNoMatch
|
||||
where jump
|
||||
| (tape w !! dp w) == Byte 0 = d == Forward
|
||||
| otherwise = d == Backward
|
||||
posOrF = if jump then findMatching (program w) (ip w) d else Just $ ip w
|
||||
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 -> Execution State
|
||||
execute w = (traceShowId $ runInstr w) >>= checkDone >>= execute
|
||||
execute w = do ran <- (traceShowId $ runInstr w)
|
||||
newStatus <- checkDone ran
|
||||
execute newStatus
|
||||
where instrFor w = case (program w !! ip w) of
|
||||
TapeLeft -> execTapeLeft
|
||||
TapeRight -> execTapeRight
|
||||
Add -> execAdd
|
||||
Sub -> execSub
|
||||
Out -> execOut
|
||||
LoopStart -> execLoop Forward
|
||||
LoopEnd -> execLoop Backward
|
||||
TapeLeft -> execTapeLeft
|
||||
TapeRight -> execTapeRight
|
||||
Add -> execUpdate Add
|
||||
Sub -> execUpdate Sub
|
||||
Out -> execOut
|
||||
l -> execLoop l
|
||||
|
||||
runInstr :: State -> Execution State
|
||||
runInstr w = instrFor w $ w
|
||||
|
|
|
|||
Loading…
Reference in a new issue