From 9720d35537f4ddeb5fe8fa09a38c0583ae7b3b7c Mon Sep 17 00:00:00 2001 From: Neil Smith Date: Fri, 6 Dec 2019 14:09:23 +0000 Subject: [PATCH] Now using the RWS monad stack --- advent05/package.yaml | 10 +++ advent05/src/advent05.hs | 2 +- advent05/src/advent05rws.hs | 170 ++++++++++++++++++++++++++++++++++++ 3 files changed, 181 insertions(+), 1 deletion(-) create mode 100644 advent05/src/advent05rws.hs diff --git a/advent05/package.yaml b/advent05/package.yaml index 1d04271..20dde11 100644 --- a/advent05/package.yaml +++ b/advent05/package.yaml @@ -59,3 +59,13 @@ executables: - megaparsec - containers - mtl + + advent05rws: + main: advent05rws.hs + source-dirs: src + dependencies: + - base >= 2 && < 6 + - text + - megaparsec + - containers + - mtl diff --git a/advent05/src/advent05.hs b/advent05/src/advent05.hs index 36ba499..2368edb 100644 --- a/advent05/src/advent05.hs +++ b/advent05/src/advent05.hs @@ -69,7 +69,7 @@ runStep = do mem <- gets _memory ip <- gets _ip let opcode = (mem!ip) `mod` 100 - let modes = parameterModes ((mem!ip) `div` 100) + let modes = parameterModes ((mem!ip) `div` 100) fetchInput opcode putOutput opcode modes mem' <- gets _memory diff --git a/advent05/src/advent05rws.hs b/advent05/src/advent05rws.hs new file mode 100644 index 0000000..b82bbf7 --- /dev/null +++ b/advent05/src/advent05rws.hs @@ -0,0 +1,170 @@ +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 -- 2.34.1