From 60c778793d16c9685df534154fa95771801d868c Mon Sep 17 00:00:00 2001 From: Neil Smith Date: Mon, 9 Dec 2019 10:51:07 +0000 Subject: [PATCH] Done day 9 --- advent09/package.yaml | 61 ++++++++++++ advent09/src/advent09.hs | 201 +++++++++++++++++++++++++++++++++++++++ data/advent09.txt | 1 + stack.yaml | 1 + 4 files changed, 264 insertions(+) create mode 100644 advent09/package.yaml create mode 100644 advent09/src/advent09.hs create mode 100644 data/advent09.txt diff --git a/advent09/package.yaml b/advent09/package.yaml new file mode 100644 index 0000000..6f444ae --- /dev/null +++ b/advent09/package.yaml @@ -0,0 +1,61 @@ +# 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: advent09 +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 + + +executables: + advent09: + main: advent09.hs + source-dirs: src + dependencies: + - base >= 2 && < 6 + - text + - megaparsec + - containers + - mtl diff --git a/advent09/src/advent09.hs b/advent09/src/advent09.hs new file mode 100644 index 0000000..76b13d8 --- /dev/null +++ b/advent09/src/advent09.hs @@ -0,0 +1,201 @@ +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 +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 + print $ part1 mem + print $ part2 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 | 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)) ++ " 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 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 + + +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 + + +-- 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 +iInsert :: Integer -> ParameterMode -> Integer -> Integer -> Memory -> Memory +iInsert loc Position _rb value mem = M.insert iloc value mem + where iloc = M.findWithDefault 0 loc mem +iInsert loc Relative rb value mem = M.insert iloc value mem + where iloc = rb + M.findWithDefault 0 loc mem + + + +-- 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 -> [Integer] +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/data/advent09.txt b/data/advent09.txt new file mode 100644 index 0000000..50e6615 --- /dev/null +++ b/data/advent09.txt @@ -0,0 +1 @@ +1102,34463338,34463338,63,1007,63,34463338,63,1005,63,53,1102,1,3,1000,109,988,209,12,9,1000,209,6,209,3,203,0,1008,1000,1,63,1005,63,65,1008,1000,2,63,1005,63,902,1008,1000,0,63,1005,63,58,4,25,104,0,99,4,0,104,0,99,4,17,104,0,99,0,0,1102,1,37,1007,1102,24,1,1006,1102,26,1,1012,1101,528,0,1023,1102,256,1,1027,1102,466,1,1029,1102,1,629,1024,1101,0,620,1025,1101,0,0,1020,1102,1,30,1004,1101,39,0,1003,1102,36,1,1005,1102,531,1,1022,1102,32,1,1019,1101,0,27,1000,1101,0,28,1016,1101,1,0,1021,1101,23,0,1013,1102,1,25,1015,1102,1,21,1008,1102,1,22,1018,1102,1,34,1014,1102,475,1,1028,1101,33,0,1002,1101,0,35,1011,1102,1,20,1009,1102,38,1,1017,1101,259,0,1026,1101,31,0,1010,1101,0,29,1001,109,8,21102,40,1,10,1008,1018,40,63,1005,63,203,4,187,1105,1,207,1001,64,1,64,1002,64,2,64,109,7,21108,41,41,0,1005,1015,225,4,213,1106,0,229,1001,64,1,64,1002,64,2,64,109,1,1205,5,247,4,235,1001,64,1,64,1105,1,247,1002,64,2,64,109,20,2106,0,-9,1105,1,265,4,253,1001,64,1,64,1002,64,2,64,109,-38,1202,4,1,63,1008,63,33,63,1005,63,291,4,271,1001,64,1,64,1106,0,291,1002,64,2,64,109,6,2102,1,0,63,1008,63,29,63,1005,63,315,1001,64,1,64,1106,0,317,4,297,1002,64,2,64,109,10,21102,42,1,5,1008,1019,40,63,1005,63,341,1001,64,1,64,1105,1,343,4,323,1002,64,2,64,109,-13,2101,0,5,63,1008,63,24,63,1005,63,365,4,349,1105,1,369,1001,64,1,64,1002,64,2,64,109,7,1202,-6,1,63,1008,63,36,63,1005,63,389,1105,1,395,4,375,1001,64,1,64,1002,64,2,64,109,1,2107,31,-5,63,1005,63,411,1106,0,417,4,401,1001,64,1,64,1002,64,2,64,109,3,1206,8,431,4,423,1105,1,435,1001,64,1,64,1002,64,2,64,109,-8,2108,31,0,63,1005,63,451,1105,1,457,4,441,1001,64,1,64,1002,64,2,64,109,26,2106,0,-2,4,463,1001,64,1,64,1106,0,475,1002,64,2,64,109,-33,1207,6,38,63,1005,63,491,1106,0,497,4,481,1001,64,1,64,1002,64,2,64,109,3,2108,27,0,63,1005,63,515,4,503,1105,1,519,1001,64,1,64,1002,64,2,64,109,23,2105,1,0,1106,0,537,4,525,1001,64,1,64,1002,64,2,64,109,-30,1207,7,28,63,1005,63,559,4,543,1001,64,1,64,1106,0,559,1002,64,2,64,109,20,21101,43,0,0,1008,1013,43,63,1005,63,581,4,565,1105,1,585,1001,64,1,64,1002,64,2,64,109,-14,2102,1,1,63,1008,63,27,63,1005,63,611,4,591,1001,64,1,64,1105,1,611,1002,64,2,64,109,18,2105,1,7,4,617,1001,64,1,64,1106,0,629,1002,64,2,64,109,13,1206,-9,641,1105,1,647,4,635,1001,64,1,64,1002,64,2,64,109,-18,21107,44,45,-1,1005,1011,665,4,653,1105,1,669,1001,64,1,64,1002,64,2,64,109,-2,2107,28,-9,63,1005,63,687,4,675,1106,0,691,1001,64,1,64,1002,64,2,64,1205,10,701,1106,0,707,4,695,1001,64,1,64,1002,64,2,64,109,-6,1201,2,0,63,1008,63,21,63,1005,63,731,1001,64,1,64,1106,0,733,4,713,1002,64,2,64,109,-5,1208,7,23,63,1005,63,753,1001,64,1,64,1105,1,755,4,739,1002,64,2,64,109,16,1208,-8,37,63,1005,63,777,4,761,1001,64,1,64,1106,0,777,1002,64,2,64,109,3,21107,45,44,-8,1005,1010,797,1001,64,1,64,1105,1,799,4,783,1002,64,2,64,109,-8,1201,-5,0,63,1008,63,36,63,1005,63,821,4,805,1106,0,825,1001,64,1,64,1002,64,2,64,109,-9,2101,0,1,63,1008,63,31,63,1005,63,845,1105,1,851,4,831,1001,64,1,64,1002,64,2,64,109,6,21108,46,49,3,1005,1010,867,1106,0,873,4,857,1001,64,1,64,1002,64,2,64,109,5,21101,47,0,7,1008,1019,44,63,1005,63,897,1001,64,1,64,1106,0,899,4,879,4,64,99,21101,27,0,1,21102,913,1,0,1106,0,920,21201,1,30449,1,204,1,99,109,3,1207,-2,3,63,1005,63,962,21201,-2,-1,1,21101,940,0,0,1105,1,920,21202,1,1,-1,21201,-2,-3,1,21102,1,955,0,1106,0,920,22201,1,-1,-2,1105,1,966,22102,1,-2,-2,109,-3,2105,1,0 diff --git a/stack.yaml b/stack.yaml index b855254..8f4b3e1 100644 --- a/stack.yaml +++ b/stack.yaml @@ -45,6 +45,7 @@ packages: - advent06 - advent07 - advent08 +- advent09 # Dependency packages to be pulled from upstream that are not in the resolver. -- 2.34.1