brainfuck-tut 0.5.1.3 → 0.6.0.0

raw patch · 3 files changed

+68/−44 lines, 3 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• brainfuck-tut.cabal +1/−1
• src/Language/Brainfuck/Eval.hs +44/−42
• src/Language/Brainfuck/Parse.hs +23/−1

@@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/  name:                brainfuck-tut-version:             0.5.1.3+version:             0.6.0.0 synopsis:            A simple BF interpreter. license:             BSD3 license-file:        LICENSE

@@ -13,8 +13,7 @@  import Data.Array ((//), (!)) import Data.Char (ord, chr)-import Data.List (elemIndices)-import Data.Maybe (listToMaybe)+import Data.Tuple (swap) import Data.Word (Word8)  import Language.Brainfuck.Types@@ -45,61 +44,64 @@  >>> let tape = listArray (0,99) (replicate 100 0) >>> eval tape "+.+."-TODO+\1\2 >>> eval tape ",."-TODO-+aa -} eval :: Tape -> String -> IO Tape eval storage program =   let instructions = parse program+      jumpPairs = matchJumps instructions -  in go storage instructions instructions 0 (PC 0)+  in case jumpPairs of+     (Right e) -> print e >> return storage+     (Left j)  -> let jrev = map swap j in+       step storage instructions instructions 0 (PC 0) j jrev    -- first set of instructions we advance over   -- second set of instructions are maintained for jump logic-  where go :: Tape -> [Term] -> [Term] ->-              DataPointer -> ProgramCounter -> IO Tape-        go tape [] _ _ _ = return tape-        go tape (IncDP:ops) os pos pc = go tape ops os (pos+1) (next pc)-        go tape (DecDP:ops) os pos pc = go tape ops os (pos-1) (next pc)-        go tape (IncByte:ops) os pos pc =-          go (modPos tape pos (+1)) ops os pos (next pc)-        go tape (DecByte:ops) os pos pc =-          go (modPos tape pos (subtract 1)) ops os pos (next pc)-        go tape (OutByte:ops) os pos pc =-          (showAt tape pos) >> go tape ops os pos (next pc)-        go tape (InByte:ops) os pos pc = do-          c <- getChar-          let b = fromIntegral $ ord c :: Word8-          go (tape // [(pos, b)]) ops os pos (next pc)-        go tape (JumpForward:ops) os pos pc = if shouldJump Forward tape pos-          then jump tape Forward os pos pc-          else go tape ops os pos (next pc)-        go tape (JumpBackward:ops) os pos pc = if shouldJump Backward tape pos-          then jump tape Backward os pos pc-          else go tape ops os pos (next pc)+  -- first JumpPairs allows lookups for ForwardJumps+  -- second JumpPairs allows lookups for BackwardJumps+  -- TODO: consider using a Reader monad to carry environment+  where step :: Tape -> [Term] -> [Term] ->+                DataPointer -> ProgramCounter -> JumpPairs -> JumpPairs ->+                IO Tape+        step tape [] _ _ _ _ _ = return tape+        step tape (o:ops) os pos pc jp jpr = case o of+          IncDP -> step tape ops os (pos+1) (next pc) jp jpr+          DecDP -> step tape ops os (pos-1) (next pc) jp jpr+          IncByte -> step (modAt tape pos (+1)) ops os pos (next pc) jp jpr+          DecByte -> step (modAt tape pos (subtract 1)) ops os pos (next pc) jp jpr+          OutByte -> showAt tape pos >> step tape ops os pos (next pc) jp jpr+          InByte -> do+            c <- getChar+            let b = fromIntegral $ ord c :: Word8+            step (tape // [(pos, b)]) ops os pos (next pc) jp jpr+          JumpForward -> doJump Forward tape ops os pos pc jp jpr+          JumpBackward -> doJump Backward tape ops os pos pc jp jpr -        jump tape dir os pos (PC pc) = do-          let jumpTo = findFunc dir pc (flipDir dir) os+        doJump :: Direction -> Tape -> [Term] -> [Term] ->+                  DataPointer -> ProgramCounter -> JumpPairs -> JumpPairs ->+                  IO Tape+        doJump dir tape ops os pos pc jp jpr =+          if shouldJump dir tape pos+          then jump tape dir os pos pc jp jpr+          else step tape ops os pos (next pc) jp jpr++        jump :: Tape -> Direction -> [Term] ->+                DataPointer -> ProgramCounter -> JumpPairs -> JumpPairs ->+                IO Tape+        jump tape dir os pos (PC pc) jp jpr = do+          let jumpTo = lookup pc (if dir == Forward then jp else jpr)           case jumpTo of-            Nothing -> print "jump not found" >> return tape-            (Just p) -> go tape (drop p os) os pos (PC p)+            Nothing -> return tape+            (Just p) -> step tape (drop p os) os pos (PC p) jp jpr          -- jump utilities-        dirToJump Forward  = JumpForward-        dirToJump Backward = JumpBackward         shouldJump Forward tape pos = (tape ! pos) == 0         shouldJump Backward tape pos = (tape ! pos) /= 0-        findIx p x = listToMaybe . filter p . elemIndices x-        findIxAfter pos = findIx (>pos)-        findIxBefore pos = findIx (<pos)-        findFunc Forward = findIxAfter-        findFunc Backward = findIxBefore-        flipDir Forward = dirToJump Backward-        flipDir Backward = dirToJump Forward          -- other evaluator utilities-        modPos arr pos f = arr // [(pos, f (arr ! pos))]-        showAt arr pos = putChar $ (chr . fromIntegral) $ (arr ! pos)+        modAt arr pos f = arr // [(pos, f (arr ! pos))]+        showAt arr pos = putChar $ (chr . fromIntegral) (arr ! pos)         next (PC n) = PC $ n + 1

@@ -8,7 +8,9 @@ Portability : POSIX -} module Language.Brainfuck.Parse (-  parse+  parse,+  matchJumps,+  JumpPairs ) where  import Language.Brainfuck.Types (Term(..))@@ -26,3 +28,23 @@   '[' -> JumpForward : parse xs   ']' -> JumpBackward : parse xs   _   -> parse xs++-- |Possible failure modes for pre-computing jump locations+data JumpMatchError+  = ForwardJumpNotMatched Int+  | BackwardJumpNotMatched Int deriving Show++type JumpPairs = [(Int,Int)]++-- TODO: swap [(Int,Int)] with Map Int Int for efficiency+-- |Given a list of terms, precomputes jump locations for matching '[' ']'+-- |Respects nesting of '[' and ']' terms.+matchJumps :: [Term] -> Either JumpPairs JumpMatchError+matchJumps ts' = go ts' [] 0 []+  where go (JumpForward:t:ts) acc pos ret = go (t:ts) (pos:acc) (pos+1) ret+        go (JumpBackward:ts) (p:acc) pos ret = go ts acc (pos+1) ((p,pos):ret)+        go (JumpBackward:_) [] pos _ = Right $ BackwardJumpNotMatched pos+        go [JumpForward] _ pos _ = Right $ ForwardJumpNotMatched pos+        go [] (p:_) _ _ = Right $ ForwardJumpNotMatched p+        go [] [] _ ret = Left ret+        go (_:ts) acc pos ret = go ts acc (pos+1) ret