Program is now an array

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

package.yaml

@@ -22,6 +22,7 @@ description:         Please see the README on GitHub at <https://github.com/gith
 dependencies:
 - base >= 4.7 && < 5
 - transformers
+- array
 
 library:
   source-dirs: src

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

test/Spec.hs

@@ -1,2 +1,4 @@
 main :: IO ()
 main = putStrLn "Test suite not yet implemented"
+
+