Program is now an array
This commit is contained in:
parent
fe51f06439
commit
4b4e4a5fe6
4 changed files with 43 additions and 32 deletions
|
@ -4,7 +4,7 @@ cabal-version: 1.12
|
||||||
--
|
--
|
||||||
-- see: https://github.com/sol/hpack
|
-- see: https://github.com/sol/hpack
|
||||||
--
|
--
|
||||||
-- hash: 16cbb08fa613499e2eb7c2ee55f9989d2a3895d105af6c712db09e00b2ac56c3
|
-- hash: e8d6e868e77028a711ad97c90ec474cf2f05ac4dfa6d3ae02a43bf494e5f726c
|
||||||
|
|
||||||
name: drbrainfuck
|
name: drbrainfuck
|
||||||
version: 0.1.0.0
|
version: 0.1.0.0
|
||||||
|
@ -34,7 +34,8 @@ library
|
||||||
hs-source-dirs:
|
hs-source-dirs:
|
||||||
src
|
src
|
||||||
build-depends:
|
build-depends:
|
||||||
base >=4.7 && <5
|
array
|
||||||
|
, base >=4.7 && <5
|
||||||
, transformers
|
, transformers
|
||||||
default-language: Haskell2010
|
default-language: Haskell2010
|
||||||
|
|
||||||
|
@ -46,7 +47,8 @@ executable drbrainfuck-exe
|
||||||
app
|
app
|
||||||
ghc-options: -threaded -rtsopts -with-rtsopts=-N
|
ghc-options: -threaded -rtsopts -with-rtsopts=-N
|
||||||
build-depends:
|
build-depends:
|
||||||
base >=4.7 && <5
|
array
|
||||||
|
, base >=4.7 && <5
|
||||||
, drbrainfuck
|
, drbrainfuck
|
||||||
, transformers
|
, transformers
|
||||||
default-language: Haskell2010
|
default-language: Haskell2010
|
||||||
|
@ -60,7 +62,8 @@ test-suite drbrainfuck-test
|
||||||
test
|
test
|
||||||
ghc-options: -threaded -rtsopts -with-rtsopts=-N
|
ghc-options: -threaded -rtsopts -with-rtsopts=-N
|
||||||
build-depends:
|
build-depends:
|
||||||
base >=4.7 && <5
|
array
|
||||||
|
, base >=4.7 && <5
|
||||||
, drbrainfuck
|
, drbrainfuck
|
||||||
, transformers
|
, transformers
|
||||||
default-language: Haskell2010
|
default-language: Haskell2010
|
||||||
|
|
|
@ -22,6 +22,7 @@ description: Please see the README on GitHub at <https://github.com/gith
|
||||||
dependencies:
|
dependencies:
|
||||||
- base >= 4.7 && < 5
|
- base >= 4.7 && < 5
|
||||||
- transformers
|
- transformers
|
||||||
|
- array
|
||||||
|
|
||||||
library:
|
library:
|
||||||
source-dirs: src
|
source-dirs: src
|
||||||
|
|
|
@ -1,9 +1,9 @@
|
||||||
module Interpreter where
|
module Interpreter where
|
||||||
-- vim: set ts=4 sw=4 et tw=80:
|
-- vim: set ts=4 sw=4 et tw=80:
|
||||||
import Data.Maybe (catMaybes)
|
import Data.Maybe (catMaybes)
|
||||||
import Control.Monad (liftM, ap)
|
|
||||||
import Debug.Trace
|
import Debug.Trace
|
||||||
import Control.Monad.Trans.State
|
import Control.Monad.Trans.State
|
||||||
|
import Data.Array.IArray
|
||||||
|
|
||||||
data Instruction = TapeLeft | TapeRight | Add | Sub | Out | In | LoopStart |
|
data Instruction = TapeLeft | TapeRight | Add | Sub | Out | In | LoopStart |
|
||||||
LoopEnd deriving (Eq, Show)
|
LoopEnd deriving (Eq, Show)
|
||||||
|
@ -30,15 +30,17 @@ updateCell Add (Byte i) = Byte (i + 1)
|
||||||
updateCell Sub (Byte i) = Byte (i - 1)
|
updateCell Sub (Byte i) = Byte (i - 1)
|
||||||
|
|
||||||
type Tape = [Byte]
|
type Tape = [Byte]
|
||||||
type Program = [Instruction]
|
type Program = Array Int Instruction
|
||||||
|
|
||||||
data Memory = Memory { tape :: Tape, dp :: Int } deriving (Show)
|
data Memory = Memory { tape :: Tape, dp :: Int } deriving (Show)
|
||||||
|
|
||||||
-- Consider putting IP in Termination output
|
-- Consider putting IP in Termination output
|
||||||
data Term = Next Int | Crash Error Int | Done deriving (Show)
|
data Term = Next Int | Crash Error Int | Done deriving (Show)
|
||||||
|
|
||||||
toProgram :: String -> Program
|
toProgram :: String -> Maybe Program
|
||||||
toProgram s = catMaybes $ fmap parseInstr s
|
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 :: Tape -> Int -> (Byte -> Byte) -> Tape
|
||||||
tapeHelp (t:tt) 0 alter = alter t : tt
|
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 :: Program -> Instruction -> Int -> Maybe Int
|
||||||
findMatching prg par = fmHelper $ -1
|
findMatching prg par = fmHelper $ -1
|
||||||
where (oppos, limit, next) = case par of
|
where (oppos, limit, next) = case par of
|
||||||
LoopStart -> (LoopEnd, length prg, (+1))
|
LoopStart -> (LoopEnd, length prg, (+1))
|
||||||
LoopEnd -> (LoopStart, 0, (-1+))
|
LoopEnd -> (LoopStart, 0, (-1+))
|
||||||
|
|
||||||
fmHelper :: Int -> Int -> Maybe Int
|
fmHelper :: Int -> Int -> Maybe Int
|
||||||
fmHelper acc s
|
fmHelper acc s
|
||||||
| s == limit = Nothing
|
| s == limit = Nothing
|
||||||
| acc == 0 && c == oppos = Just s
|
| acc == 0 && c == oppos = Just s
|
||||||
| c == oppos = fmHelper (acc - 1) $ next s
|
| c == oppos = fmHelper (acc - 1) $ next s
|
||||||
| c == par = fmHelper (acc + 1) $ next s
|
| c == par = fmHelper (acc + 1) $ next s
|
||||||
| otherwise = fmHelper acc $ next s
|
| otherwise = fmHelper acc $ next s
|
||||||
where c = prg !! s
|
where c = prg ! s
|
||||||
|
|
||||||
execLoop :: Program -> Instruction -> Int -> State Memory Term
|
execLoop :: Program -> Instruction -> Int -> State Memory Term
|
||||||
execLoop p d ip = state $ \w -> case posOrF w of Just n -> (Next $ n + 1, w)
|
execLoop p i ip = state $ \w -> case posOrF w of
|
||||||
_ -> (Crash LoopNoMatch ip, w)
|
Just n -> (Next $ n + 1, w)
|
||||||
where isZero w = (tape w !! dp w) == Byte 0
|
Nothing -> (Crash LoopNoMatch ip, w)
|
||||||
shouldJump LoopStart = isZero
|
where posOrF ps = case ((tape ps !! dp ps) == Byte 0, i) of
|
||||||
shouldJump LoopEnd = not . isZero
|
(True, LoopStart) -> findMatching p i ip
|
||||||
posOrF w = case shouldJump d w of True -> findMatching p d ip
|
(False, LoopEnd) -> findMatching p i ip
|
||||||
_ -> Just ip
|
_ -> Just ip
|
||||||
|
|
||||||
execute :: Program -> Memory -> IO (Term, Memory)
|
execute :: Program -> Memory -> IO (Term, Memory)
|
||||||
execute p = runStateT (runInstruction 0)
|
execute p = runStateT (runInstruction 1)
|
||||||
where runInstruction :: Int -> StateT Memory IO Term
|
where runInstruction :: Int -> StateT Memory IO Term
|
||||||
runInstruction ip = fmap checkDone (instrFor ip) >>= dbg >>= loopBack
|
runInstruction ip = fmap checkDone (instrFor ip) >>= dbg >>= loopBack
|
||||||
where loopBack (Next i) = runInstruction i
|
where loopBack (Next i) = runInstruction i
|
||||||
loopBack x = return x
|
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 :: Int -> StateT Memory IO Term
|
||||||
instrFor ip = case (p !! ip) of
|
instrFor ip = case (p ! ip) of
|
||||||
TapeLeft -> toTerm ip . toStateT $ execTapeLeft
|
TapeLeft -> toTerm ip . toStateT $ execTapeLeft
|
||||||
TapeRight -> toTerm ip . toStateT $ execTapeRight
|
TapeRight -> toTerm ip . toStateT $ execTapeRight
|
||||||
Add -> toTerm ip . toStateT $ execUpdate Add
|
Add -> toTerm ip . toStateT $ execUpdate Add
|
||||||
|
@ -125,7 +128,9 @@ execute p = runStateT (runInstruction 0)
|
||||||
toStateT x = StateT $ return . (runState x)
|
toStateT x = StateT $ return . (runState x)
|
||||||
|
|
||||||
checkDone :: Term -> Term
|
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
|
checkDone x = x
|
||||||
|
|
||||||
|
|
||||||
|
@ -133,5 +138,5 @@ initMemory :: Memory
|
||||||
initMemory = Memory { tape = [Byte 0], dp = 0 }
|
initMemory = Memory { tape = [Byte 0], dp = 0 }
|
||||||
|
|
||||||
run :: String -> IO ((Term, Memory))
|
run :: String -> IO ((Term, Memory))
|
||||||
run p = case catMaybes . fmap parseInstr $ p of [] -> return (Done, initMemory)
|
run str = case toProgram str of Nothing -> return (Done, initMemory)
|
||||||
pp -> execute pp initMemory
|
Just pp -> execute pp initMemory
|
||||||
|
|
|
@ -1,2 +1,4 @@
|
||||||
main :: IO ()
|
main :: IO ()
|
||||||
main = putStrLn "Test suite not yet implemented"
|
main = putStrLn "Test suite not yet implemented"
|
||||||
|
|
||||||
|
|
||||||
|
|
Loading…
Reference in a new issue