From 9c092291e0a897ae7c8b3d59b04a0cd1938bbcaf Mon Sep 17 00:00:00 2001 From: Neil Smith Date: Mon, 9 Dec 2019 19:45:37 +0000 Subject: [PATCH] Moved Intcode interpreter into a separate module, ensured all previous days still work. --- advent02/package.yaml | 3 +- advent02/src/advent02.hs | 101 ++------------------ advent05/package.yaml | 14 +-- advent05/src/advent05.hs | 165 +------------------------------- advent05/src/advent05rws.hs | 170 -------------------------------- advent07/package.yaml | 3 +- advent07/src/advent07.hs | 186 +++--------------------------------- advent09/package.yaml | 4 +- advent09/src/advent09.hs | 186 ++---------------------------------- intcode/package.yaml | 59 ++++++++++++ intcode/src/Intcode.hs | 183 +++++++++++++++++++++++++++++++++++ stack.yaml | 1 + 12 files changed, 279 insertions(+), 796 deletions(-) delete mode 100644 advent05/src/advent05rws.hs create mode 100644 intcode/package.yaml create mode 100644 intcode/src/Intcode.hs diff --git a/advent02/package.yaml b/advent02/package.yaml index e77a633..b080b0b 100644 --- a/advent02/package.yaml +++ b/advent02/package.yaml @@ -56,6 +56,5 @@ executables: dependencies: - base >= 2 && < 6 - text - - megaparsec + - intcode - containers - - mtl diff --git a/advent02/src/advent02.hs b/advent02/src/advent02.hs index 6eddc0a..1c127f7 100644 --- a/advent02/src/advent02.hs +++ b/advent02/src/advent02.hs @@ -1,36 +1,15 @@ --- Some code taken from [AoC 2017 day 5](https://adventofcode.com/2017/day/5), --- and some from [AoC 2018 day 21](https://adventofcode.com/2018/day/21) -import Data.Text (Text) import qualified Data.Text.IO as TIO -import Data.Void (Void) - -import Text.Megaparsec hiding (State) -import Text.Megaparsec.Char -import qualified Text.Megaparsec.Char.Lexer as L -import qualified Control.Applicative as CA - -import Control.Monad (unless) -import Control.Monad.State.Strict - -import qualified Data.IntMap.Strict as M -import Data.IntMap.Strict ((!)) - -type Memory = M.IntMap Int - -data Machine = Machine { _memory :: Memory - , _ip :: Int - } - deriving (Show, Eq) - -type ProgrammedMachine = State Machine () +import Intcode +import qualified Data.Map as M +import Data.Map ((!)) main :: IO () main = do text <- TIO.readFile "data/advent02.txt" - let mem = successfulParse text + let mem = parseMachineMemory text let machine = makeMachine mem print $ part1 machine print $ part2 machine @@ -49,74 +28,14 @@ part2 machine = noun * 100 + verb nounVerbResult n v machine == part2Target ] -makeMachine :: [Int] -> Machine -makeMachine memory = Machine {_ip = 0, _memory = M.fromList $ zip [0..] memory} +nounVerbResult :: Integer -> Integer -> Machine -> Integer +nounVerbResult noun verb machine = machineOutput machine' + where (_, machine', _) = runMachine [] nvMachine + nvMachine = machineNounVerb machine noun verb -nounVerbResult :: Int -> Int -> Machine -> Int -nounVerbResult noun verb machine = machineOutput nvMachine - where nvMachine0 = machineNounVerb machine noun verb - nvMachine = execState runAll nvMachine0 - -machineNounVerb :: Machine -> Int -> Int -> Machine +machineNounVerb :: Machine -> Integer -> Integer -> Machine machineNounVerb machine noun verb = machine { _memory = M.insert 1 noun $ M.insert 2 verb $ _memory machine } -machineOutput :: Machine -> Int +machineOutput :: Machine -> Integer machineOutput machine = (_memory machine)!0 - -runAll :: ProgrammedMachine -runAll = do m0 <- get - unless (lkup (_ip m0) (_memory m0) == 99) - do runStep - runAll - -runStep :: ProgrammedMachine -runStep = - do m0 <- get - let mem = _memory m0 - let ip = _ip m0 - let (mem', ip') = perform (mem!ip) ip mem - put m0 {_ip = ip', _memory = mem'} - -perform :: Int -> Int -> Memory -> (Memory, Int) -perform 1 ip mem = (iInsert (ip + 3) (a + b) mem, ip + 4) - where a = mem!>(ip + 1) - b = mem!>(ip + 2) -perform 2 ip mem = (iInsert (ip + 3) (a * b) mem, ip + 4) - where a = mem!>(ip + 1) - b = mem!>(ip + 2) - - --- Some IntMap utility functions, for syntactic sugar - --- prefix version of (!) -lkup k m = m!k - --- indirect lookup -(!>) m k = m!(m!k) - --- indirect insert -iInsert k v m = M.insert (m!k) v m - - - --- Parse the input file -type Parser = Parsec Void Text - -sc :: Parser () -sc = L.space (skipSome spaceChar) CA.empty CA.empty --- sc = L.space (skipSome (char ' ')) CA.empty CA.empty - -lexeme = L.lexeme sc -integer = lexeme L.decimal --- signedInteger = L.signed sc integer -symb = L.symbol sc -comma = symb "," - -memoryP = integer `sepBy` comma - -successfulParse :: Text -> [Int] -successfulParse input = - case parse memoryP "input" input of - Left _err -> [] -- TIO.putStr $ T.pack $ parseErrorPretty err - Right memory -> memory \ No newline at end of file diff --git a/advent05/package.yaml b/advent05/package.yaml index 20dde11..768fc18 100644 --- a/advent05/package.yaml +++ b/advent05/package.yaml @@ -56,16 +56,4 @@ executables: dependencies: - base >= 2 && < 6 - text - - megaparsec - - containers - - mtl - - advent05rws: - main: advent05rws.hs - source-dirs: src - dependencies: - - base >= 2 && < 6 - - text - - megaparsec - - containers - - mtl + - intcode diff --git a/advent05/src/advent05.hs b/advent05/src/advent05.hs index 2368edb..5b76b30 100644 --- a/advent05/src/advent05.hs +++ b/advent05/src/advent05.hs @@ -1,175 +1,16 @@ -import Debug.Trace -import Data.Text (Text) import qualified Data.Text.IO as TIO -import Data.Void (Void) - -import Text.Megaparsec hiding (State) -import Text.Megaparsec.Char -import qualified Text.Megaparsec.Char.Lexer as L -import qualified Control.Applicative as CA - -import Control.Monad (unless) -import Control.Monad.State.Strict -import Control.Monad.Reader -import Control.Monad.Writer - -import qualified Data.IntMap.Strict as M -import Data.IntMap.Strict ((!)) -import Data.List - -type Memory = M.IntMap Int - -data Machine = Machine { _memory :: Memory - , _ip :: Int - , _inputIndex :: Int - } - deriving (Show, Eq) - -type ProgrammedMachine = WriterT [Int] (ReaderT ([Int]) (State Machine)) () - -data ParameterMode = Position | Immediate deriving (Ord, Eq, Show) +import Intcode main :: IO () main = do text <- TIO.readFile "data/advent05.txt" - let mem = successfulParse text + let mem = parseMachineMemory text print $ findMachineOutput [1] mem print $ findMachineOutput [5] mem findMachineOutput inputs program = last output - where finalStack = - runState ( - runReaderT ( - runWriterT runAll - ) - inputs - ) - (makeMachine program) - ((_retval, output), _machine) = finalStack - -makeMachine :: [Int] -> Machine -makeMachine memory = Machine {_ip = 0, _inputIndex = 0 - , _memory = M.fromList $ zip [0..] memory - } - - -runAll :: ProgrammedMachine -runAll = do mem <- gets _memory - ip <- gets _ip - unless (mem!ip == 99) - do runStep - runAll - -runStep :: ProgrammedMachine -runStep = - do mem <- gets _memory - ip <- gets _ip - let opcode = (mem!ip) `mod` 100 - let modes = parameterModes ((mem!ip) `div` 100) - fetchInput opcode - putOutput opcode modes - mem' <- gets _memory - let (mem'', ip') = perform opcode ip modes mem' - modify (\m -> m {_ip = ip', _memory = mem''}) - - --- fetchInput opcode | trace ("Input with opcode " ++ show opcode) False = undefined -fetchInput 3 = - do mem <- gets _memory - ip <- gets _ip - inputIndex <- gets _inputIndex - inputs <- ask - let mem' = iInsert (ip + 1) (inputs!!inputIndex) mem - modify (\m -> m {_inputIndex = inputIndex + 1, _memory = mem'}) -fetchInput _ = return () - - --- putOutput opcode _modes | trace ("Output with opcode " ++ show opcode) False = undefined -putOutput 4 modes = - do mem <- gets _memory - ip <- gets _ip - let v = getMemoryValue (ip + 1) (modes!!0) mem - tell [v] -putOutput _ _ = return () - - -perform :: Int -> Int -> [ParameterMode] -> Memory -> (Memory, Int) --- perform instr ip modes mem | trace ("Perform ip " ++ show ip ++ " opcode " ++ show instr ++ " modes " ++ (show (take 3 modes)) ++ " args " ++ (intercalate ", " (map show [(mem!(ip+1)), (mem!(ip+2)), (mem!(ip+3))]))) False = undefined -perform 1 ip modes mem = (iInsert (ip + 3) (a + b) mem, ip + 4) - where a = getMemoryValue (ip + 1) (modes!!0) mem - b = getMemoryValue (ip + 2) (modes!!1) mem -perform 2 ip modes mem = (iInsert (ip + 3) (a * b) mem, ip + 4) - where a = getMemoryValue (ip + 1) (modes!!0) mem - b = getMemoryValue (ip + 2) (modes!!1) mem -perform 3 ip _ mem = (mem, ip + 2) -perform 4 ip _ mem = (mem, ip + 2) -perform 5 ip modes mem = (mem, ip') - where a = getMemoryValue (ip + 1) (modes!!0) mem - b = getMemoryValue (ip + 2) (modes!!1) mem - ip' = if a /= 0 then b else ip + 3 -perform 6 ip modes mem = (mem, ip') - where a = getMemoryValue (ip + 1) (modes!!0) mem - b = getMemoryValue (ip + 2) (modes!!1) mem - ip' = if a == 0 then b else ip + 3 -perform 7 ip modes mem = (iInsert (ip + 3) res mem, ip + 4) - where a = getMemoryValue (ip + 1) (modes!!0) mem - b = getMemoryValue (ip + 2) (modes!!1) mem - res = if a < b then 1 else 0 -perform 8 ip modes mem = (iInsert (ip + 3) res mem, ip + 4) - where a = getMemoryValue (ip + 1) (modes!!0) mem - b = getMemoryValue (ip + 2) (modes!!1) mem - res = if a == b then 1 else 0 -perform _ ip _ mem = (mem, ip) - - -getMemoryValue loc Position mem = mem!>loc -getMemoryValue loc Immediate mem = mem!loc - - -parameterModes :: Int -> [ParameterMode] -parameterModes modeCode = unfoldr generateMode modeCode - -generateMode :: Int -> Maybe (ParameterMode, Int) -generateMode modeCode = Just (mode, modeCode `div` 10) - where mode = case (modeCode `mod` 10) of - 0 -> Position - 1 -> Immediate - - --- Some IntMap utility functions, for syntactic sugar - --- prefix version of (!) -lkup k m = m!k - --- indirect lookup -(!>) m k = m!(m!k) - --- indirect insert -iInsert k v m = M.insert (m!k) v m - - - --- Parse the input file -type Parser = Parsec Void Text - -sc :: Parser () -sc = L.space (skipSome spaceChar) CA.empty CA.empty --- sc = L.space (skipSome (char ' ')) CA.empty CA.empty - -lexeme = L.lexeme sc -integer = lexeme L.decimal -signedInteger = L.signed sc integer -symb = L.symbol sc -comma = symb "," - -memoryP = signedInteger `sepBy` comma - -successfulParse :: Text -> [Int] -successfulParse input = - case parse memoryP "input" input of - Left _err -> [] -- TIO.putStr $ T.pack $ parseErrorPretty err - Right memory -> memory \ No newline at end of file + where (_, _, output) = runProgram inputs program diff --git a/advent05/src/advent05rws.hs b/advent05/src/advent05rws.hs deleted file mode 100644 index b82bbf7..0000000 --- a/advent05/src/advent05rws.hs +++ /dev/null @@ -1,170 +0,0 @@ -import Debug.Trace - -import Data.Text (Text) -import qualified Data.Text.IO as TIO - -import Data.Void (Void) - -import Text.Megaparsec hiding (State) -import Text.Megaparsec.Char -import qualified Text.Megaparsec.Char.Lexer as L -import qualified Control.Applicative as CA - -import Control.Monad (unless) -import Control.Monad.State.Strict -import Control.Monad.Reader -import Control.Monad.Writer -import Control.Monad.RWS.Strict - - -import qualified Data.IntMap.Strict as M -import Data.IntMap.Strict ((!)) -import Data.List - -type Memory = M.IntMap Int - -data Machine = Machine { _memory :: Memory - , _ip :: Int - , _inputIndex :: Int - } - deriving (Show, Eq) - -type ProgrammedMachine = RWS [Int] [Int] Machine () - -data ParameterMode = Position | Immediate deriving (Ord, Eq, Show) - - -main :: IO () -main = do - text <- TIO.readFile "data/advent05.txt" - let mem = successfulParse text - print $ findMachineOutput [1] mem - print $ findMachineOutput [5] mem - -findMachineOutput :: [Int] -> [Int] -> Int -findMachineOutput inputs program = last output - where (_machine, output) = execRWS runAll inputs (makeMachine program) - - -makeMachine :: [Int] -> Machine -makeMachine memory = Machine {_ip = 0, _inputIndex = 0 - , _memory = M.fromList $ zip [0..] memory - } - - -runAll :: ProgrammedMachine -runAll = do mem <- gets _memory - ip <- gets _ip - unless (mem!ip == 99) - do runStep - runAll - -runStep :: ProgrammedMachine -runStep = - do mem <- gets _memory - ip <- gets _ip - let opcode = (mem!ip) `mod` 100 - let modes = parameterModes ((mem!ip) `div` 100) - fetchInput opcode - putOutput opcode modes - mem' <- gets _memory - let (mem'', ip') = perform opcode ip modes mem' - modify (\m -> m {_ip = ip', _memory = mem''}) - - --- fetchInput opcode | trace ("Input with opcode " ++ show opcode) False = undefined -fetchInput 3 = - do mem <- gets _memory - ip <- gets _ip - inputIndex <- gets _inputIndex - inputs <- ask - let mem' = iInsert (ip + 1) (inputs!!inputIndex) mem - modify (\m -> m {_inputIndex = inputIndex + 1, _memory = mem'}) -fetchInput _ = return () - - --- putOutput opcode _modes | trace ("Output with opcode " ++ show opcode) False = undefined -putOutput 4 modes = - do mem <- gets _memory - ip <- gets _ip - let v = getMemoryValue (ip + 1) (modes!!0) mem - tell [v] -putOutput _ _ = return () - - -perform :: Int -> Int -> [ParameterMode] -> Memory -> (Memory, Int) --- perform instr ip modes mem | trace ("Perform ip " ++ show ip ++ " opcode " ++ show instr ++ " modes " ++ (show (take 3 modes)) ++ " args " ++ (intercalate ", " (map show [(mem!(ip+1)), (mem!(ip+2)), (mem!(ip+3))]))) False = undefined -perform 1 ip modes mem = (iInsert (ip + 3) (a + b) mem, ip + 4) - where a = getMemoryValue (ip + 1) (modes!!0) mem - b = getMemoryValue (ip + 2) (modes!!1) mem -perform 2 ip modes mem = (iInsert (ip + 3) (a * b) mem, ip + 4) - where a = getMemoryValue (ip + 1) (modes!!0) mem - b = getMemoryValue (ip + 2) (modes!!1) mem -perform 3 ip _ mem = (mem, ip + 2) -perform 4 ip _ mem = (mem, ip + 2) -perform 5 ip modes mem = (mem, ip') - where a = getMemoryValue (ip + 1) (modes!!0) mem - b = getMemoryValue (ip + 2) (modes!!1) mem - ip' = if a /= 0 then b else ip + 3 -perform 6 ip modes mem = (mem, ip') - where a = getMemoryValue (ip + 1) (modes!!0) mem - b = getMemoryValue (ip + 2) (modes!!1) mem - ip' = if a == 0 then b else ip + 3 -perform 7 ip modes mem = (iInsert (ip + 3) res mem, ip + 4) - where a = getMemoryValue (ip + 1) (modes!!0) mem - b = getMemoryValue (ip + 2) (modes!!1) mem - res = if a < b then 1 else 0 -perform 8 ip modes mem = (iInsert (ip + 3) res mem, ip + 4) - where a = getMemoryValue (ip + 1) (modes!!0) mem - b = getMemoryValue (ip + 2) (modes!!1) mem - res = if a == b then 1 else 0 -perform _ ip _ mem = (mem, ip) - - -getMemoryValue loc Position mem = mem!>loc -getMemoryValue loc Immediate mem = mem!loc - - -parameterModes :: Int -> [ParameterMode] -parameterModes modeCode = unfoldr generateMode modeCode - -generateMode :: Int -> Maybe (ParameterMode, Int) -generateMode modeCode = Just (mode, modeCode `div` 10) - where mode = case (modeCode `mod` 10) of - 0 -> Position - 1 -> Immediate - - --- Some IntMap utility functions, for syntactic sugar - --- prefix version of (!) -lkup k m = m!k - --- indirect lookup -(!>) m k = m!(m!k) - --- indirect insert -iInsert k v m = M.insert (m!k) v m - - - --- Parse the input file -type Parser = Parsec Void Text - -sc :: Parser () -sc = L.space (skipSome spaceChar) CA.empty CA.empty --- sc = L.space (skipSome (char ' ')) CA.empty CA.empty - -lexeme = L.lexeme sc -integer = lexeme L.decimal -signedInteger = L.signed sc integer -symb = L.symbol sc -comma = symb "," - -memoryP = signedInteger `sepBy` comma - -successfulParse :: Text -> [Int] -successfulParse input = - case parse memoryP "input" input of - Left _err -> [] -- TIO.putStr $ T.pack $ parseErrorPretty err - Right memory -> memory \ No newline at end of file diff --git a/advent07/package.yaml b/advent07/package.yaml index 18d6c87..bfc3e3f 100644 --- a/advent07/package.yaml +++ b/advent07/package.yaml @@ -56,6 +56,5 @@ executables: dependencies: - base >= 2 && < 6 - text - - megaparsec - containers - - mtl + - intcode diff --git a/advent07/src/advent07.hs b/advent07/src/advent07.hs index 27c7875..d359780 100644 --- a/advent07/src/advent07.hs +++ b/advent07/src/advent07.hs @@ -1,56 +1,30 @@ import Debug.Trace -import Data.Text (Text) -import qualified Data.Text.IO as TIO - -import Data.Void (Void) - -import Text.Megaparsec hiding (State) -import Text.Megaparsec.Char -import qualified Text.Megaparsec.Char.Lexer as L -import qualified Control.Applicative as CA - -import Control.Monad (unless) -import Control.Monad.State.Strict -import Control.Monad.Reader -import Control.Monad.Writer -import Control.Monad.RWS.Strict +import Intcode +import qualified Data.Text.IO as TIO import qualified Data.IntMap.Strict as M import Data.IntMap.Strict ((!)) import Data.List import Data.Function (on) -type Memory = M.IntMap Int - -data Machine = Machine { _memory :: Memory - , _ip :: Int - , _inputIndex :: Int - } - deriving (Show, Eq) - -type ProgrammedMachine = RWS [Int] [Int] Machine data EncapsulatedMacine = EncapsulatedMacine { _machine :: Machine , _executionState :: ExecutionState - , _initialInput :: [Int] - , _currentInput :: [Int] - , _machineOutput :: [Int] + , _initialInput :: [Integer] + , _currentInput :: [Integer] + , _machineOutput :: [Integer] } deriving (Show, Eq) -data ParameterMode = Position | Immediate deriving (Ord, Eq, Show) - -data ExecutionState = Runnable | Blocked | Terminated deriving (Ord, Eq, Show) - type Pipeline = M.IntMap EncapsulatedMacine main :: IO () main = do text <- TIO.readFile "data/advent07.txt" - let mem = successfulParse text + let mem = parseMachineMemory text print $ part1 mem print $ part2 mem @@ -61,7 +35,8 @@ part1 mem = maximum outputs chainMachines mem settings = foldl' (chainMachine mem) 0 settings -chainMachine mem prevOutput setting = findMachineOutput [setting, prevOutput] mem +chainMachine mem prevOutput setting = last output + where (_, _, output) = runProgram [setting, prevOutput] mem part2 mem = maximum outputs @@ -69,14 +44,14 @@ part2 mem = maximum outputs pipelines = map (buildPipeline mem) inputs outputs = map runPipeline pipelines -buildPipeline :: [Int] -> [Int] -> Pipeline +buildPipeline :: [Integer] -> [Integer] -> Pipeline buildPipeline mem input = M.insert 0 machine0' pipeline where pipeline = M.fromList $ zip [0..] $ map (encapsulate mem) input machine0 = pipeline!0 machine0' = machine0 { _initialInput = (_initialInput machine0) ++ [0]} -encapsulate :: [Int] -> Int -> EncapsulatedMacine +encapsulate :: [Integer] -> Integer -> EncapsulatedMacine encapsulate mem input = EncapsulatedMacine { _machine = makeMachine mem , _executionState = Runnable @@ -86,7 +61,7 @@ encapsulate mem input = EncapsulatedMacine } -runPipeline :: Pipeline -> Int +runPipeline :: Pipeline -> Integer -- runPipeline pipeline | trace (pipelineTrace pipeline) False = undefined runPipeline pipeline | finished pipeline = last $ _machineOutput $ snd $ M.findMax pipeline @@ -118,7 +93,6 @@ emTrace e = intercalate " ; " terms , show $ _machineOutput e ] - finished :: Pipeline -> Bool finished = M.null . runnableMachines @@ -132,140 +106,4 @@ runEncapsulatedMachine e = e { _machine = machine' } where machine = _machine e input = _currentInput e - (halted, machine', output) = runRWS runAll input machine - - -findMachineOutput :: [Int] -> [Int] -> Int -findMachineOutput inputs program = last output - where (_haltedBecause, _machine, output) = runRWS runAll inputs (makeMachine program) - - -makeMachine :: [Int] -> Machine -makeMachine memory = Machine {_ip = 0, _inputIndex = 0 - , _memory = M.fromList $ zip [0..] memory - } - - -runAll :: ProgrammedMachine ExecutionState -runAll = do mem <- gets _memory - ip <- gets _ip - input <- ask - iIndex <- gets _inputIndex - let acutalInputLength = length input - let requiredInputLength = iIndex + 1 - if (mem!ip == 99) - then return Terminated - else if (mem!ip == 3 && requiredInputLength > acutalInputLength) - then return Blocked - else do runStep - runAll - -runStep :: ProgrammedMachine () -runStep = - do mem <- gets _memory - ip <- gets _ip - let opcode = (mem!ip) `mod` 100 - let modes = parameterModes ((mem!ip) `div` 100) - fetchInput opcode - putOutput opcode modes - mem' <- gets _memory - let (mem'', ip') = perform opcode ip modes mem' - modify (\m -> m {_ip = ip', _memory = mem''}) - -fetchInput :: Int -> ProgrammedMachine () --- fetchInput opcode | trace ("Input with opcode " ++ show opcode) False = undefined -fetchInput 3 = - do mem <- gets _memory - ip <- gets _ip - inputIndex <- gets _inputIndex - inputs <- ask - let mem' = iInsert (ip + 1) (inputs!!inputIndex) mem - modify (\m -> m {_inputIndex = inputIndex + 1, _memory = mem'}) -fetchInput _ = return () - -putOutput :: Int -> [ParameterMode] -> ProgrammedMachine () --- putOutput opcode _modes | trace ("Output with opcode " ++ show opcode) False = undefined -putOutput 4 modes = - do mem <- gets _memory - ip <- gets _ip - let v = getMemoryValue (ip + 1) (modes!!0) mem - tell [v] -putOutput _ _ = return () - - -perform :: Int -> Int -> [ParameterMode] -> Memory -> (Memory, Int) --- perform instr ip modes mem | trace ("Perform ip " ++ show ip ++ " opcode " ++ show instr ++ " modes " ++ (show (take 3 modes)) ++ " args " ++ (intercalate ", " (map show [(mem!(ip+1)), (mem!(ip+2)), (mem!(ip+3))]))) False = undefined -perform 1 ip modes mem = (iInsert (ip + 3) (a + b) mem, ip + 4) - where a = getMemoryValue (ip + 1) (modes!!0) mem - b = getMemoryValue (ip + 2) (modes!!1) mem -perform 2 ip modes mem = (iInsert (ip + 3) (a * b) mem, ip + 4) - where a = getMemoryValue (ip + 1) (modes!!0) mem - b = getMemoryValue (ip + 2) (modes!!1) mem -perform 3 ip _ mem = (mem, ip + 2) -perform 4 ip _ mem = (mem, ip + 2) -perform 5 ip modes mem = (mem, ip') - where a = getMemoryValue (ip + 1) (modes!!0) mem - b = getMemoryValue (ip + 2) (modes!!1) mem - ip' = if a /= 0 then b else ip + 3 -perform 6 ip modes mem = (mem, ip') - where a = getMemoryValue (ip + 1) (modes!!0) mem - b = getMemoryValue (ip + 2) (modes!!1) mem - ip' = if a == 0 then b else ip + 3 -perform 7 ip modes mem = (iInsert (ip + 3) res mem, ip + 4) - where a = getMemoryValue (ip + 1) (modes!!0) mem - b = getMemoryValue (ip + 2) (modes!!1) mem - res = if a < b then 1 else 0 -perform 8 ip modes mem = (iInsert (ip + 3) res mem, ip + 4) - where a = getMemoryValue (ip + 1) (modes!!0) mem - b = getMemoryValue (ip + 2) (modes!!1) mem - res = if a == b then 1 else 0 -perform _ ip _ mem = (mem, ip) - - -getMemoryValue loc Position mem = mem!>loc -getMemoryValue loc Immediate mem = mem!loc - - -parameterModes :: Int -> [ParameterMode] -parameterModes modeCode = unfoldr generateMode modeCode - -generateMode :: Int -> Maybe (ParameterMode, Int) -generateMode modeCode = Just (mode, modeCode `div` 10) - where mode = case (modeCode `mod` 10) of - 0 -> Position - 1 -> Immediate - - --- Some IntMap utility functions, for syntactic sugar - --- prefix version of (!) -lkup k m = m!k - --- indirect lookup -(!>) m k = m!(m!k) - --- indirect insert -iInsert k v m = M.insert (m!k) v m - - - --- Parse the input file -type Parser = Parsec Void Text - -sc :: Parser () -sc = L.space (skipSome spaceChar) CA.empty CA.empty --- sc = L.space (skipSome (char ' ')) CA.empty CA.empty - -lexeme = L.lexeme sc -integer = lexeme L.decimal -signedInteger = L.signed sc integer -symb = L.symbol sc -comma = symb "," - -memoryP = signedInteger `sepBy` comma - -successfulParse :: Text -> [Int] -successfulParse input = - case parse memoryP "input" input of - Left _err -> [] -- TIO.putStr $ T.pack $ parseErrorPretty err - Right memory -> memory \ No newline at end of file + (halted, machine', output) = runMachine input machine diff --git a/advent09/package.yaml b/advent09/package.yaml index 6f444ae..814aaab 100644 --- a/advent09/package.yaml +++ b/advent09/package.yaml @@ -56,6 +56,4 @@ executables: dependencies: - base >= 2 && < 6 - text - - megaparsec - - containers - - mtl + - intcode diff --git a/advent09/src/advent09.hs b/advent09/src/advent09.hs index e8b98a5..6984329 100644 --- a/advent09/src/advent09.hs +++ b/advent09/src/advent09.hs @@ -1,190 +1,18 @@ -import Debug.Trace +import Intcode -import Data.Text (Text) +-- import Data.Text (Text) import qualified Data.Text.IO as TIO -import Data.Void (Void) - -import Text.Megaparsec hiding (State) -import Text.Megaparsec.Char -import qualified Text.Megaparsec.Char.Lexer as L -import qualified Control.Applicative as CA - --- import Control.Monad (unless) -import Control.Monad.State.Strict -import Control.Monad.Reader -import Control.Monad.Writer -import Control.Monad.RWS.Strict - - -import qualified Data.Map.Strict as M -import Data.Map.Strict ((!)) -import Data.List --- import Data.Function (on) - -type Memory = M.Map Integer Integer - -data Machine = Machine { _memory :: Memory - , _ip :: Integer - , _inputIndex :: Int - , _rb :: Integer - } - deriving (Show, Eq) - -type ProgrammedMachine = RWS [Integer] [Integer] Machine - -data ExecutionState = Runnable | Blocked | Terminated deriving (Ord, Eq, Show) - -data ParameterMode = Position | Immediate | Relative deriving (Ord, Eq, Show) - - main :: IO () main = do text <- TIO.readFile "data/advent09.txt" - let mem = successfulParse text + let mem = parseMachineMemory text print $ part1 mem print $ part2 mem +part1 mem = head output + where (_, _, output) = runProgram [1] mem -part1 mem = findMachineOutput [1] mem - -part2 mem = findMachineOutput [2] mem - - -findMachineOutput :: [Integer] -> [Integer] -> [Integer] -findMachineOutput inputs program = output - where (_haltedBecause, _machine, output) = runRWS runAll inputs (makeMachine program) - - -makeMachine :: [Integer] -> Machine -makeMachine memory = Machine {_ip = 0, _inputIndex = 0, _rb = 0 - , _memory = M.fromList $ zip [0..] memory - } - - -runAll :: ProgrammedMachine ExecutionState -runAll = do mem <- gets _memory - ip <- gets _ip - input <- ask - iIndex <- gets _inputIndex - let acutalInputLength = length input - let requiredInputLength = iIndex + 1 - if (mem!ip == 99) - then return Terminated - else if (mem!ip == 3 && requiredInputLength > acutalInputLength) - then return Blocked - else do runStep - runAll - -runStep :: ProgrammedMachine () -runStep = - do mem <- gets _memory - ip <- gets _ip - rb <- gets _rb - let opcode = (mem!ip) `mod` 100 - let modes = parameterModes ((mem!ip) `div` 100) - fetchInput opcode modes - putOutput opcode modes - mem' <- gets _memory - let (mem'', ip', rb') = perform opcode ip modes rb mem' - modify (\m -> m {_ip = ip', _memory = mem'', _rb = rb'}) - -fetchInput :: Integer -> [ParameterMode] -> ProgrammedMachine () --- fetchInput opcode _modes | trace ("Input with opcode " ++ show opcode) False = undefined -fetchInput 3 modes = - do mem <- gets _memory - ip <- gets _ip - rb <- gets _rb - inputIndex <- gets _inputIndex - inputs <- ask - let mem' = iInsert (ip + 1) (modes!!0) rb (inputs!!inputIndex) mem - modify (\m -> m {_inputIndex = inputIndex + 1, _memory = mem'}) -fetchInput _ _ = return () - -putOutput :: Integer -> [ParameterMode] -> ProgrammedMachine () --- putOutput opcode _modes | trace ("Output with opcode " ++ show opcode) False = undefined -putOutput 4 modes = - do mem <- gets _memory - ip <- gets _ip - rb <- gets _rb - let v = getMemoryValue (ip + 1) (modes!!0) rb mem - tell [v] -putOutput _ _ = return () - - -perform :: Integer -> Integer -> [ParameterMode] -> Integer -> Memory -> (Memory, Integer, Integer) --- perform instr ip modes rb mem | trace ("Perform ip " ++ show ip ++ " opcode " ++ show instr ++ " modes " ++ (show (take 3 modes)) ++ " rb " ++ (show rb) ++ " args " ++ (intercalate ", " (map show [(mem!(ip+1)), (mem!(ip+2)), (mem!(ip+3))]))) False = undefined -perform 1 ip modes rb mem = (iInsert (ip + 3) (modes!!2) rb (a + b) mem, ip + 4, rb) - where a = getMemoryValue (ip + 1) (modes!!0) rb mem - b = getMemoryValue (ip + 2) (modes!!1) rb mem -perform 2 ip modes rb mem = (iInsert (ip + 3) (modes!!2) rb (a * b) mem, ip + 4, rb) - where a = getMemoryValue (ip + 1) (modes!!0) rb mem - b = getMemoryValue (ip + 2) (modes!!1) rb mem -perform 3 ip _ rb mem = (mem, ip + 2, rb) -perform 4 ip _ rb mem = (mem, ip + 2, rb) -perform 5 ip modes rb mem = (mem, ip', rb) - where a = getMemoryValue (ip + 1) (modes!!0) rb mem - b = getMemoryValue (ip + 2) (modes!!1) rb mem - ip' = if a /= 0 then b else ip + 3 -perform 6 ip modes rb mem = (mem, ip', rb) - where a = getMemoryValue (ip + 1) (modes!!0) rb mem - b = getMemoryValue (ip + 2) (modes!!1) rb mem - ip' = if a == 0 then b else ip + 3 -perform 7 ip modes rb mem = (iInsert (ip + 3) (modes!!2) rb res mem, ip + 4, rb) - where a = getMemoryValue (ip + 1) (modes!!0) rb mem - b = getMemoryValue (ip + 2) (modes!!1) rb mem - res = if a < b then 1 else 0 -perform 8 ip modes rb mem = (iInsert (ip + 3) (modes!!2) rb res mem, ip + 4, rb) - where a = getMemoryValue (ip + 1) (modes!!0) rb mem - b = getMemoryValue (ip + 2) (modes!!1) rb mem - res = if a == b then 1 else 0 -perform 9 ip modes rb mem = (mem, ip + 2, rb + a) - where a = getMemoryValue (ip + 1) (modes!!0) rb mem -perform _ ip _ rb mem = (mem, ip, rb) - - -getMemoryValue :: Integer -> ParameterMode -> Integer -> Memory -> Integer -getMemoryValue loc Position rb mem = getMemoryValue loc' Immediate rb mem - where loc' = M.findWithDefault 0 loc mem -getMemoryValue loc Immediate _ mem = M.findWithDefault 0 loc mem -getMemoryValue loc Relative rb mem = getMemoryValue loc' Immediate 0 mem - where loc' = rb + M.findWithDefault 0 loc mem - --- indirect insert -iInsert :: Integer -> ParameterMode -> Integer -> Integer -> Memory -> Memory -iInsert loc Position _rb value mem = M.insert loc' value mem - where loc' = M.findWithDefault 0 loc mem -iInsert loc Immediate _rb value mem = M.insert loc value mem -iInsert loc Relative rb value mem = M.insert loc' value mem - where loc' = rb + M.findWithDefault 0 loc mem - -parameterModes :: Integer -> [ParameterMode] -parameterModes modeCode = unfoldr generateMode modeCode - -generateMode :: Integer -> Maybe (ParameterMode, Integer) -generateMode modeCode = Just (mode, modeCode `div` 10) - where mode = case (modeCode `mod` 10) of - 0 -> Position - 1 -> Immediate - 2 -> Relative - --- Parse the input file -type Parser = Parsec Void Text - -sc :: Parser () -sc = L.space (skipSome spaceChar) CA.empty CA.empty --- sc = L.space (skipSome (char ' ')) CA.empty CA.empty - -lexeme = L.lexeme sc -integer = lexeme L.decimal -signedInteger = L.signed sc integer -symb = L.symbol sc -comma = symb "," - -memoryP = signedInteger `sepBy` comma +part2 mem = head output + where (_, _, output) = runProgram [2] mem -successfulParse :: Text -> [Integer] -successfulParse input = - case parse memoryP "input" input of - Left _err -> [] -- TIO.putStr $ T.pack $ parseErrorPretty err - Right memory -> memory diff --git a/intcode/package.yaml b/intcode/package.yaml new file mode 100644 index 0000000..339a24f --- /dev/null +++ b/intcode/package.yaml @@ -0,0 +1,59 @@ +# This YAML file describes your package. Stack will automatically generate a +# Cabal file when you run `stack build`. See the hpack website for help with +# this file: . + +name: intcode +synopsis: Advent of Code +version: '0.0.1' + +default-extensions: +- AllowAmbiguousTypes +- ApplicativeDo +- BangPatterns +- BlockArguments +- DataKinds +- DeriveFoldable +- DeriveFunctor +- DeriveGeneric +- DeriveTraversable +- EmptyCase +- FlexibleContexts +- FlexibleInstances +- FunctionalDependencies +- GADTs +- GeneralizedNewtypeDeriving +- ImplicitParams +- KindSignatures +- LambdaCase +- MonadComprehensions +- MonoLocalBinds +- MultiParamTypeClasses +- MultiWayIf +- NegativeLiterals +- NumDecimals +- OverloadedLists +- OverloadedStrings +- PartialTypeSignatures +- PatternGuards +- PatternSynonyms +- PolyKinds +- RankNTypes +- RecordWildCards +- ScopedTypeVariables +- TemplateHaskell +- TransformListComp +- TupleSections +- TypeApplications +- TypeInType +- TypeOperators +- ViewPatterns + + +library: + source-dirs: src + dependencies: + - base >= 2 && < 6 + - text + - megaparsec + - containers + - mtl diff --git a/intcode/src/Intcode.hs b/intcode/src/Intcode.hs new file mode 100644 index 0000000..bdc4cb4 --- /dev/null +++ b/intcode/src/Intcode.hs @@ -0,0 +1,183 @@ +module Intcode where + +import Debug.Trace + +import Data.Text (Text) +import qualified Data.Text.IO as TIO + +import Data.Void (Void) + +import Text.Megaparsec hiding (State) +import Text.Megaparsec.Char +import qualified Text.Megaparsec.Char.Lexer as L +import qualified Control.Applicative as CA + +-- import Control.Monad (unless) +import Control.Monad.State.Strict +import Control.Monad.Reader +import Control.Monad.Writer +import Control.Monad.RWS.Strict + + +import qualified Data.Map.Strict as M +import Data.Map.Strict ((!)) +import Data.List + +type Memory = M.Map Integer Integer + +data Machine = Machine { _memory :: Memory + , _ip :: Integer + , _inputIndex :: Int + , _rb :: Integer + } + deriving (Show, Eq) + +type ProgrammedMachine = RWS [Integer] [Integer] Machine + +data ExecutionState = Runnable | Blocked | Terminated deriving (Ord, Eq, Show) + +data ParameterMode = Position | Immediate | Relative deriving (Ord, Eq, Show) + + +-- returns (returnValue, finalMachine, outputs) +runProgram :: [Integer] -> [Integer] -> (ExecutionState, Machine, [Integer]) +runProgram inputs program = runMachine inputs (makeMachine program) + +runMachine :: [Integer] -> Machine -> (ExecutionState, Machine, [Integer]) +runMachine inputs machine = runRWS runAll inputs machine + + +makeMachine :: [Integer] -> Machine +makeMachine memory = Machine {_ip = 0, _inputIndex = 0, _rb = 0 + , _memory = M.fromList $ zip [0..] memory + } + + +runAll :: ProgrammedMachine ExecutionState +runAll = do mem <- gets _memory + ip <- gets _ip + input <- ask + iIndex <- gets _inputIndex + let acutalInputLength = length input + let requiredInputLength = iIndex + 1 + if (mem!ip == 99) + then return Terminated + else if (mem!ip == 3 && requiredInputLength > acutalInputLength) + then return Blocked + else do runStep + runAll + +runStep :: ProgrammedMachine () +runStep = + do mem <- gets _memory + ip <- gets _ip + rb <- gets _rb + let opcode = (mem!ip) `mod` 100 + let modes = parameterModes ((mem!ip) `div` 100) + fetchInput opcode modes + putOutput opcode modes + mem' <- gets _memory + let (mem'', ip', rb') = perform opcode ip modes rb mem' + modify (\m -> m {_ip = ip', _memory = mem'', _rb = rb'}) + +fetchInput :: Integer -> [ParameterMode] -> ProgrammedMachine () +-- fetchInput opcode _modes | trace ("Input with opcode " ++ show opcode) False = undefined +fetchInput 3 modes = + do mem <- gets _memory + ip <- gets _ip + rb <- gets _rb + inputIndex <- gets _inputIndex + inputs <- ask + let mem' = iInsert (ip + 1) (modes!!0) rb (inputs!!inputIndex) mem + modify (\m -> m {_inputIndex = inputIndex + 1, _memory = mem'}) +fetchInput _ _ = return () + +putOutput :: Integer -> [ParameterMode] -> ProgrammedMachine () +-- putOutput opcode _modes | trace ("Output with opcode " ++ show opcode) False = undefined +putOutput 4 modes = + do mem <- gets _memory + ip <- gets _ip + rb <- gets _rb + let v = getMemoryValue (ip + 1) (modes!!0) rb mem + tell [v] +putOutput _ _ = return () + + +perform :: Integer -> Integer -> [ParameterMode] -> Integer -> Memory -> (Memory, Integer, Integer) +-- perform instr ip modes rb mem | trace ("Perform ip " ++ show ip ++ " opcode " ++ show instr ++ " modes " ++ (show (take 3 modes)) ++ " rb " ++ (show rb) ++ " args " ++ (intercalate ", " (map show [(mem!(ip+1)), (mem!(ip+2)), (mem!(ip+3))]))) False = undefined +perform 1 ip modes rb mem = (iInsert (ip + 3) (modes!!2) rb (a + b) mem, ip + 4, rb) + where a = getMemoryValue (ip + 1) (modes!!0) rb mem + b = getMemoryValue (ip + 2) (modes!!1) rb mem +perform 2 ip modes rb mem = (iInsert (ip + 3) (modes!!2) rb (a * b) mem, ip + 4, rb) + where a = getMemoryValue (ip + 1) (modes!!0) rb mem + b = getMemoryValue (ip + 2) (modes!!1) rb mem +perform 3 ip _ rb mem = (mem, ip + 2, rb) +perform 4 ip _ rb mem = (mem, ip + 2, rb) +perform 5 ip modes rb mem = (mem, ip', rb) + where a = getMemoryValue (ip + 1) (modes!!0) rb mem + b = getMemoryValue (ip + 2) (modes!!1) rb mem + ip' = if a /= 0 then b else ip + 3 +perform 6 ip modes rb mem = (mem, ip', rb) + where a = getMemoryValue (ip + 1) (modes!!0) rb mem + b = getMemoryValue (ip + 2) (modes!!1) rb mem + ip' = if a == 0 then b else ip + 3 +perform 7 ip modes rb mem = (iInsert (ip + 3) (modes!!2) rb res mem, ip + 4, rb) + where a = getMemoryValue (ip + 1) (modes!!0) rb mem + b = getMemoryValue (ip + 2) (modes!!1) rb mem + res = if a < b then 1 else 0 +perform 8 ip modes rb mem = (iInsert (ip + 3) (modes!!2) rb res mem, ip + 4, rb) + where a = getMemoryValue (ip + 1) (modes!!0) rb mem + b = getMemoryValue (ip + 2) (modes!!1) rb mem + res = if a == b then 1 else 0 +perform 9 ip modes rb mem = (mem, ip + 2, rb + a) + where a = getMemoryValue (ip + 1) (modes!!0) rb mem +perform _ ip _ rb mem = (mem, ip, rb) + + +getMemoryValue :: Integer -> ParameterMode -> Integer -> Memory -> Integer +getMemoryValue loc Position rb mem = getMemoryValue loc' Immediate rb mem + where loc' = M.findWithDefault 0 loc mem +getMemoryValue loc Immediate _ mem = M.findWithDefault 0 loc mem +getMemoryValue loc Relative rb mem = getMemoryValue loc' Immediate 0 mem + where loc' = rb + M.findWithDefault 0 loc mem + +-- indirect insert +iInsert :: Integer -> ParameterMode -> Integer -> Integer -> Memory -> Memory +iInsert loc Position _rb value mem = M.insert loc' value mem + where loc' = M.findWithDefault 0 loc mem +iInsert loc Immediate _rb value mem = M.insert loc value mem +iInsert loc Relative rb value mem = M.insert loc' value mem + where loc' = rb + M.findWithDefault 0 loc mem + +parameterModes :: Integer -> [ParameterMode] +parameterModes modeCode = unfoldr generateMode modeCode + +generateMode :: Integer -> Maybe (ParameterMode, Integer) +generateMode modeCode = Just (mode, modeCode `div` 10) + where mode = case (modeCode `mod` 10) of + 0 -> Position + 1 -> Immediate + 2 -> Relative + + +-- Parse the input file +type Parser = Parsec Void Text + +sc :: Parser () +sc = L.space (skipSome spaceChar) CA.empty CA.empty +-- sc = L.space (skipSome (char ' ')) CA.empty CA.empty + +lexeme = L.lexeme sc +integer = lexeme L.decimal +signedInteger = L.signed sc integer +symb = L.symbol sc +comma = symb "," + +memoryP = signedInteger `sepBy` comma + + +parseMachineMemory :: Text -> [Integer] +parseMachineMemory input = + case parse memoryP "input" input of + Left _err -> [] -- TIO.putStr $ T.pack $ parseErrorPretty err + Right memory -> memory diff --git a/stack.yaml b/stack.yaml index 8f4b3e1..ef4e6be 100644 --- a/stack.yaml +++ b/stack.yaml @@ -46,6 +46,7 @@ packages: - advent07 - advent08 - advent09 +- intcode # Dependency packages to be pulled from upstream that are not in the resolver. -- 2.34.1