Done day 9

diff --git a/advent09/package.yaml b/advent09/package.yaml
new file mode 100644 (file)
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: <https://github.com/sol/hpack>.
+
+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 (file)
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 (file)
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 b8552548ff074e6f7bdfc94dcc931ff39e7a91ca..8f4b3e18df30e2b2d7988c1415998306492b17c4 100644 (file)
--- 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.