Done day 5

diff --git a/advent05/package.yaml b/advent05/package.yaml
new file mode 100644 (file)
index 0000000..1d04271
--- /dev/null
+++ b/advent05/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: advent05
+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:
+  advent05:
+    main: advent05.hs
+    source-dirs: src
+    dependencies:
+    - base >= 2 && < 6
+    - text
+    - megaparsec
+    - containers
+    - mtl

diff --git a/advent05/src/advent05.hs b/advent05/src/advent05.hs
new file mode 100644 (file)
index 0000000..752b8ed
--- /dev/null
+++ b/advent05/src/advent05.hs
@@ -0,0 +1,202 @@
+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)
+
+
+main :: IO ()
+main = do 
+        text <- TIO.readFile "data/advent05.txt"
+        let mem = successfulParse text
+        -- let machine = makeMachine mem
+        print $ findMachineOutput [1] mem
+        print $ findMachineOutput [5] mem
+        -- print $ part2 machine
+
+
+-- part1 machine = (_memory $ execState runAll machine1202)!0
+--     where machine1202 = machine { _memory = M.insert 1 12 $ M.insert 2 2 $ _memory machine }
+
+
+findMachineOutput inputs program = output -- last output
+    where   finalStack = 
+                runState (
+                    runReaderT (
+                        runWriterT runAll
+                               ) 
+                        inputs
+                         ) 
+                         (makeMachine program)
+            ((_retval, output), _machine) = finalStack
+
+
+-- part1 = nounVerbResult 12 2
+
+-- part2Target = 19690720
+
+-- part2 machine = noun * 100 + verb
+--     where (noun, verb) = head $ [(n, v) | n <- [0..99], v <- [0..99],
+--                                           nounVerbResult n v machine == part2Target ]
+
+
+makeMachine :: [Int] -> Machine
+makeMachine memory = Machine    {_ip = 0, _inputIndex = 0
+                                , _memory = M.fromList $ zip [0..] memory
+                                }
+
+-- 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 noun verb = machine { _memory = M.insert 1 noun $ M.insert 2 verb $ _memory machine }
+
+-- machineOutput :: Machine -> Int
+-- machineOutput machine = (_memory machine)!0
+
+
+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/data/advent05.txt b/data/advent05.txt
new file mode 100644 (file)
index 0000000..0727400
--- /dev/null
+++ b/data/advent05.txt
@@ -0,0 +1 @@
+3,225,1,225,6,6,1100,1,238,225,104,0,1101,81,30,225,1102,9,63,225,1001,92,45,224,101,-83,224,224,4,224,102,8,223,223,101,2,224,224,1,224,223,223,1102,41,38,225,1002,165,73,224,101,-2920,224,224,4,224,102,8,223,223,101,4,224,224,1,223,224,223,1101,18,14,224,1001,224,-32,224,4,224,1002,223,8,223,101,3,224,224,1,224,223,223,1101,67,38,225,1102,54,62,224,1001,224,-3348,224,4,224,1002,223,8,223,1001,224,1,224,1,224,223,223,1,161,169,224,101,-62,224,224,4,224,1002,223,8,223,101,1,224,224,1,223,224,223,2,14,18,224,1001,224,-1890,224,4,224,1002,223,8,223,101,3,224,224,1,223,224,223,1101,20,25,225,1102,40,11,225,1102,42,58,225,101,76,217,224,101,-153,224,224,4,224,102,8,223,223,1001,224,5,224,1,224,223,223,102,11,43,224,1001,224,-451,224,4,224,1002,223,8,223,101,6,224,224,1,223,224,223,1102,77,23,225,4,223,99,0,0,0,677,0,0,0,0,0,0,0,0,0,0,0,1105,0,99999,1105,227,247,1105,1,99999,1005,227,99999,1005,0,256,1105,1,99999,1106,227,99999,1106,0,265,1105,1,99999,1006,0,99999,1006,227,274,1105,1,99999,1105,1,280,1105,1,99999,1,225,225,225,1101,294,0,0,105,1,0,1105,1,99999,1106,0,300,1105,1,99999,1,225,225,225,1101,314,0,0,106,0,0,1105,1,99999,8,226,677,224,1002,223,2,223,1006,224,329,1001,223,1,223,7,226,226,224,102,2,223,223,1006,224,344,101,1,223,223,108,677,677,224,1002,223,2,223,1006,224,359,101,1,223,223,1107,226,677,224,1002,223,2,223,1005,224,374,101,1,223,223,1008,677,226,224,1002,223,2,223,1005,224,389,101,1,223,223,1007,677,226,224,1002,223,2,223,1005,224,404,1001,223,1,223,1107,677,226,224,1002,223,2,223,1005,224,419,1001,223,1,223,108,677,226,224,102,2,223,223,1006,224,434,1001,223,1,223,7,226,677,224,102,2,223,223,1005,224,449,1001,223,1,223,107,226,226,224,102,2,223,223,1006,224,464,101,1,223,223,107,677,226,224,102,2,223,223,1006,224,479,101,1,223,223,1007,677,677,224,1002,223,2,223,1006,224,494,1001,223,1,223,1008,226,226,224,1002,223,2,223,1006,224,509,101,1,223,223,7,677,226,224,1002,223,2,223,1006,224,524,1001,223,1,223,1007,226,226,224,102,2,223,223,1006,224,539,101,1,223,223,8,677,226,224,1002,223,2,223,1006,224,554,101,1,223,223,1008,677,677,224,102,2,223,223,1006,224,569,101,1,223,223,1108,677,226,224,102,2,223,223,1005,224,584,101,1,223,223,107,677,677,224,102,2,223,223,1006,224,599,1001,223,1,223,1108,677,677,224,1002,223,2,223,1006,224,614,1001,223,1,223,1107,677,677,224,1002,223,2,223,1005,224,629,1001,223,1,223,108,226,226,224,1002,223,2,223,1005,224,644,101,1,223,223,8,226,226,224,1002,223,2,223,1005,224,659,101,1,223,223,1108,226,677,224,1002,223,2,223,1006,224,674,101,1,223,223,4,223,99,226

diff --git a/stack.yaml b/stack.yaml
index e0c5714d61d8e030c406fdf565b765e91043edfa..441f991aff76d9177c4e2d45c39d13b1a7c20fa2 100644 (file)
--- a/stack.yaml
+++ b/stack.yaml
@@ -41,6 +41,7 @@ packages:
 - advent02
 - advent03
 - advent04
+- advent05
 
 
 # Dependency packages to be pulled from upstream that are not in the resolver.