From 4b4e4a5fe60535e32070d4b2ee12fde38f2a80fa Mon Sep 17 00:00:00 2001 From: "Claudio Maggioni (maggicl)" Date: Sun, 8 Nov 2020 14:07:12 +0100 Subject: [PATCH] Program is now an array --- drbrainfuck.cabal | 11 ++++++--- package.yaml | 1 + src/Interpreter.hs | 61 +++++++++++++++++++++++++--------------------- test/Spec.hs | 2 ++ 4 files changed, 43 insertions(+), 32 deletions(-) diff --git a/drbrainfuck.cabal b/drbrainfuck.cabal index f0df9e9..48afda2 100644 --- a/drbrainfuck.cabal +++ b/drbrainfuck.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: 16cbb08fa613499e2eb7c2ee55f9989d2a3895d105af6c712db09e00b2ac56c3 +-- hash: e8d6e868e77028a711ad97c90ec474cf2f05ac4dfa6d3ae02a43bf494e5f726c name: drbrainfuck version: 0.1.0.0 @@ -34,7 +34,8 @@ library hs-source-dirs: src build-depends: - base >=4.7 && <5 + array + , base >=4.7 && <5 , transformers default-language: Haskell2010 @@ -46,7 +47,8 @@ executable drbrainfuck-exe app ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: - base >=4.7 && <5 + array + , base >=4.7 && <5 , drbrainfuck , transformers default-language: Haskell2010 @@ -60,7 +62,8 @@ test-suite drbrainfuck-test test ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: - base >=4.7 && <5 + array + , base >=4.7 && <5 , drbrainfuck , transformers default-language: Haskell2010 diff --git a/package.yaml b/package.yaml index 40f1f14..f89e199 100644 --- a/package.yaml +++ b/package.yaml @@ -22,6 +22,7 @@ description: Please see the README on GitHub at = 4.7 && < 5 - transformers +- array library: source-dirs: src diff --git a/src/Interpreter.hs b/src/Interpreter.hs index 9fc4ed6..2844f45 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -1,9 +1,9 @@ module Interpreter where -- vim: set ts=4 sw=4 et tw=80: import Data.Maybe (catMaybes) -import Control.Monad (liftM, ap) import Debug.Trace import Control.Monad.Trans.State +import Data.Array.IArray data Instruction = TapeLeft | TapeRight | Add | Sub | Out | In | LoopStart | LoopEnd deriving (Eq, Show) @@ -30,15 +30,17 @@ updateCell Add (Byte i) = Byte (i + 1) updateCell Sub (Byte i) = Byte (i - 1) type Tape = [Byte] -type Program = [Instruction] +type Program = Array Int Instruction 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 +toProgram :: String -> Maybe Program +toProgram s = case progL of [] -> Nothing + _ -> Just $ listArray (1, (length progL)) progL + where progL = catMaybes $ fmap parseInstr s tapeHelp :: Tape -> Int -> (Byte -> Byte) -> Tape tapeHelp (t:tt) 0 alter = alter t : tt @@ -76,38 +78,39 @@ execOut = StateT $ \p -> putChar (chr (tape p !! dp p)) >> (return (Nothing, p)) findMatching :: Program -> Instruction -> Int -> Maybe Int findMatching prg par = fmHelper $ -1 - where (oppos, limit, next) = case par of - LoopStart -> (LoopEnd, length prg, (+1)) - LoopEnd -> (LoopStart, 0, (-1+)) + where (oppos, limit, next) = case par of + LoopStart -> (LoopEnd, length prg, (+1)) + LoopEnd -> (LoopStart, 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 - where c = prg !! s + 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 + where c = prg ! s execLoop :: Program -> Instruction -> Int -> State Memory Term -execLoop p d ip = state $ \w -> case posOrF w of Just n -> (Next $ n + 1, w) - _ -> (Crash LoopNoMatch ip, w) - where isZero w = (tape w !! dp w) == Byte 0 - shouldJump LoopStart = isZero - shouldJump LoopEnd = not . isZero - posOrF w = case shouldJump d w of True -> findMatching p d ip - _ -> Just ip +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 !! dp ps) == Byte 0, i) of + (True, LoopStart) -> findMatching p i ip + (False, LoopEnd) -> findMatching p i ip + _ -> Just ip execute :: Program -> Memory -> IO (Term, Memory) -execute p = runStateT (runInstruction 0) +execute p = runStateT (runInstruction 1) where runInstruction :: Int -> StateT Memory IO Term runInstruction ip = fmap checkDone (instrFor ip) >>= dbg >>= loopBack where loopBack (Next i) = runInstruction i loopBack x = return x - dbg a = StateT $ \s -> return $ traceShowId (a, s) + dbg a = StateT $ \s -> do _ <- putStrLn . show $ (a, s) + return (a, s) instrFor :: Int -> StateT Memory IO Term - instrFor ip = case (p !! ip) of + instrFor ip = case (p ! ip) of TapeLeft -> toTerm ip . toStateT $ execTapeLeft TapeRight -> toTerm ip . toStateT $ execTapeRight Add -> toTerm ip . toStateT $ execUpdate Add @@ -125,7 +128,9 @@ execute p = runStateT (runInstruction 0) toStateT x = StateT $ return . (runState x) checkDone :: Term -> Term - checkDone (Next x) = if x == (length p) then Done else Next x + checkDone (Next x) + | x == (snd . bounds $ p) + 1 = Done + | otherwise = Next x checkDone x = x @@ -133,5 +138,5 @@ initMemory :: Memory initMemory = Memory { tape = [Byte 0], dp = 0 } run :: String -> IO ((Term, Memory)) -run p = case catMaybes . fmap parseInstr $ p of [] -> return (Done, initMemory) - pp -> execute pp initMemory +run str = case toProgram str of Nothing -> return (Done, initMemory) + Just pp -> execute pp initMemory diff --git a/test/Spec.hs b/test/Spec.hs index cd4753f..c7d26a6 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,2 +1,4 @@ main :: IO () main = putStrLn "Test suite not yet implemented" + +