diff --git a/src/Interpreter/Definitions.hs b/src/Interpreter/Definitions.hs
new file mode 100644
index 0000000000000000000000000000000000000000..b7c97b77ddf86cde71254db68deed2b84dd40ec4
--- /dev/null
+++ b/src/Interpreter/Definitions.hs
@@ -0,0 +1,13 @@
+module Interpreter.Definitions where
+
+
+data InterpreterCode =
+ InterAdd Integer
+ | InterMov Integer
+ | InterSet Integer
+ | InterRead
+ | InterWrite
+ | InterLoop [InterpreterCode]
+ deriving (Eq, Show)
+
+type InterpreterCodeBlock = [InterpreterCode]
\ No newline at end of file
diff --git a/src/Interpreter/Interpreter.hs b/src/Interpreter/Interpreter.hs
index 8fe81cd9e95562e144334fee9d3748d9e6daa66b..3b04be35a96a0b6a6bf6c6bef754557c9d301472 100644
--- a/src/Interpreter/Interpreter.hs
+++ b/src/Interpreter/Interpreter.hs
@@ -5,6 +5,8 @@ import Text.Trifecta
import Parser.LangParser
import Parser.Definitions
import Control.Monad.State
+import Interpreter.Optimizer
+import Interpreter.Definitions
data InterpreterState = InterpreterState{
@@ -14,14 +16,9 @@ data InterpreterState = InterpreterState{
offset :: Integer
} deriving (Show)
-data Direction =
- LeftDirection | RightDirection
- deriving (Eq, Show)
-
-
-- Initial buffer length and expanding rate
replicaFactor :: Int
-replicaFactor = 3000
+replicaFactor = 350
io :: IO a -> StateT InterpreterState IO a
io = liftIO
@@ -34,22 +31,21 @@ prompt text = do
defaultState :: InterpreterState
defaultState = InterpreterState { buffer = replicate replicaFactor 0
- , inputNumber = 0
- , index = 0
- , offset = 0
- }
+ , inputNumber = 0
+ , index = 0
+ , offset = 0
+ }
updateListElement :: [Integer] -> Integer -> (Integer -> Integer) -> [Integer]
updateListElement list index update = do
- let element = update $ list !! fromInteger index
- let (x,_:ys) = splitAt (fromInteger index) list
+ let element = update $ list !! fromInteger index
+ let (x, _ : ys) = splitAt (fromInteger index) list
x ++ element : ys
expandIfNeeded :: [Integer] -> Integer -> [Integer]
--- Expand buffer to travel left but index is less than zero
-expandIfNeeded old_buffer (-1) = replicate replicaFactor 0 ++ old_buffer
--- Expand buffer in need to travel Right
-expandIfNeeded old_buffer new_index = old_buffer
+expandIfNeeded old_buffer new_index
+ | new_index < 0 = replicate replicaFactor 0 ++ old_buffer
+ | new_index >= 0 = old_buffer
++ needed (new_index - toInteger (length old_buffer))
where
needed len | len >= 0 = replicate replicaFactor 0
@@ -58,76 +54,49 @@ expandIfNeeded old_buffer new_index = old_buffer
increaseInputNumber :: InterpreterState -> InterpreterState
increaseInputNumber state = state { inputNumber = inputNumber state + 1 }
--- Fuction to update state accordingly to walk direction
-walkUpdate :: Direction -> InterpreterState -> InterpreterState
--- Walk left with buffer expnding if needed
-walkUpdate LeftDirection old_state = do
- let update_func t = t - 1
+-- Fuction to update state accordingly to pointer movement
+walkUpdate :: Integer -> InterpreterState -> InterpreterState
+walkUpdate steps old_state = do
+ let update_func t = t + steps
let updated_buffer =
expandIfNeeded (buffer old_state) (update_func $ index old_state)
-- Finding diff because we need to update current index correctly
let len_diff =
toInteger $ length updated_buffer - length (buffer old_state)
- old_state { buffer = updated_buffer
- , index = update_func $ index old_state + len_diff
- , offset = update_func $ offset old_state
- }
+ -- Finding new index of our pointer
+ let new_index = case () of
+ _ | steps < 0 -> update_func $ index old_state + len_diff
+ | steps > 0 -> update_func $ index old_state
-walkUpdate RightDirection old_state = do
- let update_func t = t + 1
- let updated_buffer =
- expandIfNeeded (buffer old_state) (update_func $ index old_state)
old_state { buffer = updated_buffer
- , index = update_func $ index old_state
+ , index = new_index
, offset = update_func $ offset old_state
}
updateStateCell :: (Integer -> Integer) -> InterpreterState -> InterpreterState
updateStateCell update_func old_state = do
- let new_buffer = updateListElement (buffer old_state) (index old_state) update_func
- old_state{
- buffer = new_buffer
- }
+ let new_buffer =
+ updateListElement (buffer old_state) (index old_state) update_func
+ old_state { buffer = new_buffer }
-updateCell :: (Integer->Integer) -> StateT InterpreterState IO ()
+updateCell :: (Integer -> Integer) -> StateT InterpreterState IO ()
updateCell update_func = modify (updateStateCell update_func)
-walk :: Direction -> StateT InterpreterState IO ()
-walk direction = do
- modify (walkUpdate direction)
+walk :: Integer -> StateT InterpreterState IO ()
+walk steps = do
+ modify (walkUpdate steps)
return ()
doAction :: REPLCode -> State InterpreterState ()
doAction = undefined
-getBufferSlice :: Integer -> Integer -> [Integer] -> [Integer]
+getBufferSlice :: Integer -> Integer -> [Integer] -> [Integer]
getBufferSlice size current_index current_buffer = do
- let start = fromInteger $ current_index - size
- let end = fromInteger $ current_index + size
+ let start = fromInteger $ current_index - size
+ let end = fromInteger $ current_index + size
drop start $ take end current_buffer
-runHelper :: REPLHelpers -> StateT InterpreterState IO ()
-runHelper PrintState = do
- current_state <- get
- let buffer_slice = getBufferSlice 5 (index current_state) (buffer current_state)
- io $ putStrLn $ "Current index: " ++ show (index current_state)
- io $ putStrLn $ "Offset from start: " ++ show (offset current_state)
- io $ putStrLn $ "part of curren buffer: \n" ++ show buffer_slice
- return ()
-
-runHelper PrintBuf = do
- current_state <- get
- let buffer_slice = getBufferSlice 5 (index current_state) (buffer current_state)
- io $ print buffer_slice
- return ()
-
-runHelper PrintBufChars = do
- current_state <- get
- let buffer_slice = getBufferSlice 5 (index current_state) (buffer current_state)
- io $ print $ map (\t -> toEnum (fromInteger t) :: Char) buffer_slice
- return ()
-
getCell :: StateT InterpreterState IO Integer
getCell = do
state <- get
@@ -146,29 +115,30 @@ readCell = do
updateCell (const $ toInteger $ fromEnum char)
return ()
-runBrainCodeLoop :: BrainBreakBlock -> StateT InterpreterState IO ()
-runBrainCodeLoop code = do
+runInterpreterLoop :: InterpreterCodeBlock -> StateT InterpreterState IO ()
+runInterpreterLoop code = do
cell <- getCell
case cell of
- 0 -> return ()
- val -> runBrainBreakCode code
+ 0 -> return ()
+ val -> runInterpreterCode code
cell <- getCell
- case cell of
- 0 -> return ()
- val -> runBrainCodeLoop code
-
-runBrainBreakOperation :: BrainBreakOperation -> StateT InterpreterState IO ()
-runBrainBreakOperation MoveLeft = walk LeftDirection
-runBrainBreakOperation MoveRight = walk RightDirection
-runBrainBreakOperation Increment = updateCell (+1)
-runBrainBreakOperation Decrement = updateCell (\t -> t - 1)
-runBrainBreakOperation Write = printCell
-runBrainBreakOperation Read = readCell
-runBrainBreakOperation (Loop code) = runBrainCodeLoop code
-runBrainBreakOperation Comment = return ()
+ case cell of
+ 0 -> return ()
+ val -> runInterpreterLoop code
+
+runInterpreterOperation :: InterpreterCode -> StateT InterpreterState IO ()
+runInterpreterOperation (InterAdd value) = updateCell (+ value)
+runInterpreterOperation (InterMov step ) = walk step
+runInterpreterOperation (InterSet value) = updateCell (const value)
+runInterpreterOperation InterRead = readCell
+runInterpreterOperation InterWrite = printCell
+runInterpreterOperation (InterLoop code) = runInterpreterLoop code
+
+runInterpreterCode :: InterpreterCodeBlock -> StateT InterpreterState IO ()
+runInterpreterCode (x : xs) = do
+ runInterpreterOperation x
+ runInterpreterCode xs
+runInterpreterCode _ = return ()
runBrainBreakCode :: BrainBreakBlock -> StateT InterpreterState IO ()
-runBrainBreakCode (x : xs) = do
- runBrainBreakOperation x
- runBrainBreakCode xs
-runBrainBreakCode [] = return ()
+runBrainBreakCode = runInterpreterCode . optimize
diff --git a/src/Interpreter/Optimizer.hs b/src/Interpreter/Optimizer.hs
index 66af1c1497d26a9ca5cfde0e9187ac8d3a020db6..4061bac3caf9a56d36ae2e885691ac2da1ebc293 100644
--- a/src/Interpreter/Optimizer.hs
+++ b/src/Interpreter/Optimizer.hs
@@ -1,5 +1,11 @@
-module Interpreter.Optimizer where
+module Interpreter.Optimizer
+ ( optimize
+ )
+where
+import Parser.Definitions
+import Parser.LangParser
+import Interpreter.Definitions
{-
Optiomization plans:
* Instruction merging
@@ -29,4 +35,71 @@ Optiomization plans:
[-]+++ => Set 0, Add 3 => Set 3
+++[-] => Set 0
Also sequential Set instructions may be merged.
--}
\ No newline at end of file
+-}
+
+mapCodes :: BrainBreakOperation -> InterpreterCode
+mapCodes Increment = InterAdd 1
+mapCodes Decrement = InterAdd (-1)
+mapCodes MoveRight = InterMov 1
+mapCodes MoveLeft = InterMov (-1)
+mapCodes Read = InterRead
+mapCodes Write = InterWrite
+mapCodes (Loop [Decrement]) = InterSet 0
+mapCodes (Loop vals ) = InterLoop $ map mapCodes $ filterComments vals
+
+
+canBeMerged :: InterpreterCode -> InterpreterCode -> Bool
+canBeMerged (InterMov _) (InterMov _) = True
+canBeMerged (InterAdd _) (InterAdd _) = True
+canBeMerged (InterSet _) (InterSet _) = True
+canBeMerged (InterSet _) (InterAdd _) = True
+canBeMerged (InterAdd _) (InterSet _) = True
+canBeMerged (InterLoop _) (InterLoop _) = True
+canBeMerged _ _ = False
+
+
+mergeOperations :: InterpreterCode -> InterpreterCode -> InterpreterCode
+mergeOperations (InterMov a) (InterMov b) = InterMov (a + b)
+mergeOperations (InterAdd a) (InterAdd b) = InterAdd (a + b)
+mergeOperations (InterSet a) (InterSet b) = InterSet b
+mergeOperations (InterSet a) (InterAdd b) = InterSet (a + b)
+mergeOperations (InterAdd a) (InterSet b) = InterSet b
+mergeOperations (InterLoop a) (InterLoop b) = InterLoop a
+mergeOperations _ _ = error "Operations can't be merged"
+
+isNoAction :: InterpreterCode -> Bool
+isNoAction action | action == InterMov 0 = True
+ | action == InterAdd 0 = True
+ | action == InterLoop [] = True
+ | otherwise = False
+
+isOpositeMovement :: InterpreterCode -> InterpreterCode -> Bool
+isOpositeMovement (InterMov 1) (InterMov (-1)) = True
+isOpositeMovement _ _ = False
+
+optimizer
+ :: InterpreterCodeBlock -> InterpreterCodeBlock -> InterpreterCodeBlock
+optimizer processed [] = processed
+optimizer [] other = optimizer [head other] (tail other)
+optimizer processed (x : xs)
+ | canBeMerged (last processed) x = optimizer
+ (init processed ++ [mergeOperations (last processed) x])
+ xs
+ | otherwise = optimizer (processed ++ [x]) xs
+
+
+removeStartLoops :: InterpreterCodeBlock -> InterpreterCodeBlock
+removeStartLoops [] = []
+removeStartLoops (x : xs) | canBeMerged x (InterLoop []) = removeStartLoops xs
+ | otherwise = xs
+
+preprocess :: BrainBreakBlock -> InterpreterCodeBlock
+preprocess = map mapCodes
+
+optimize :: BrainBreakBlock -> InterpreterCodeBlock
+optimize =
+ filter (not . isNoAction)
+ . optimizer []
+ . removeStartLoops
+ . preprocess
+ . filterComments
diff --git a/src/Interpreter/REPL.hs b/src/Interpreter/REPL.hs
index a05b28a19f835660e3176d487845b5a3620a34dc..78f2a78b30535873c93b1aa44b26322a3c50b186 100644
--- a/src/Interpreter/REPL.hs
+++ b/src/Interpreter/REPL.hs
@@ -7,6 +7,29 @@ import Parser.Definitions
import Control.Monad.State
import Interpreter.Interpreter
+runHelper :: REPLHelpers -> StateT InterpreterState IO ()
+runHelper PrintState = do
+ current_state <- get
+ let buffer_slice =
+ getBufferSlice 5 (index current_state) (buffer current_state)
+ io $ putStrLn $ "Current index: " ++ show (index current_state)
+ io $ putStrLn $ "Offset from start: " ++ show (offset current_state)
+ io $ putStrLn $ "part of curren buffer: \n" ++ show buffer_slice
+ return ()
+
+runHelper PrintBuf = do
+ current_state <- get
+ let buffer_slice =
+ getBufferSlice 5 (index current_state) (buffer current_state)
+ io $ print buffer_slice
+ return ()
+
+runHelper PrintBufChars = do
+ current_state <- get
+ let buffer_slice =
+ getBufferSlice 5 (index current_state) (buffer current_state)
+ io $ print $ map (\t -> toEnum (fromInteger t) :: Char) buffer_slice
+ return ()
replCodeRunner :: REPLCode -> StateT InterpreterState IO ()