Program is now an array

This commit is contained in:
Claudio Maggioni (maggicl) 2020-11-08 14:07:12 +01:00
parent fe51f06439
commit 4b4e4a5fe6
4 changed files with 43 additions and 32 deletions

View file

@ -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

View file

@ -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

View file

@ -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

View file

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