advent05/src/advent05.hs

   1 import Debug.Trace
   2
   3 import Data.Text (Text)
   4 import qualified Data.Text.IO as TIO
   5
   6 import Data.Void (Void)
   7
   8 import Text.Megaparsec hiding (State)
   9 import Text.Megaparsec.Char
  10 import qualified Text.Megaparsec.Char.Lexer as L
  11 import qualified Control.Applicative as CA
  12
  13 import Control.Monad (unless)
  14 import Control.Monad.State.Strict
  15 import Control.Monad.Reader
  16 import Control.Monad.Writer
  17
  18 import qualified Data.IntMap.Strict as M
  19 import Data.IntMap.Strict ((!))
  20 import Data.List
  21
  22 type Memory = M.IntMap Int
  23
  24 data Machine = Machine { _memory :: Memory
  25                        , _ip :: Int
  26                        , _inputIndex :: Int
  27                        }
  28                deriving (Show, Eq)
  29
  30 type ProgrammedMachine = WriterT [Int] (ReaderT ([Int]) (State Machine)) ()
  31
  32 data ParameterMode = Position | Immediate deriving (Ord, Eq, Show)
  33
  34
  35 main :: IO ()
  36 main = do
  37         text <- TIO.readFile "data/advent05.txt"
  38         let mem = successfulParse text
  39         -- let machine = makeMachine mem
  40         print $ findMachineOutput [1] mem
  41         print $ findMachineOutput [5] mem
  42         -- print $ part2 machine
  43
  44
  45 -- part1 machine = (_memory $ execState runAll machine1202)!0
  46 --     where machine1202 = machine { _memory = M.insert 1 12 $ M.insert 2 2 $ _memory machine }
  47
  48
  49 findMachineOutput inputs program = output -- last output
  50     where   finalStack =
  51                 runState (
  52                     runReaderT (
  53                         runWriterT runAll
  54                                )
  55                         inputs
  56                          )
  57                          (makeMachine program)
  58             ((_retval, output), _machine) = finalStack
  59
  60
  61 -- part1 = nounVerbResult 12 2
  62
  63 -- part2Target = 19690720
  64
  65 -- part2 machine = noun * 100 + verb
  66 --     where (noun, verb) = head $ [(n, v) | n <- [0..99], v <- [0..99],
  67 --                                           nounVerbResult n v machine == part2Target ]
  68
  69
  70 makeMachine :: [Int] -> Machine
  71 makeMachine memory = Machine    {_ip = 0, _inputIndex = 0
  72                                 , _memory = M.fromList $ zip [0..] memory
  73                                 }
  74
  75 -- nounVerbResult :: Int -> Int -> Machine -> Int
  76 -- nounVerbResult noun verb machine = machineOutput nvMachine
  77 --     where nvMachine0 = machineNounVerb machine noun verb
  78 --           nvMachine = execState runAll nvMachine0
  79
  80 -- machineNounVerb :: Machine -> Int -> Int -> Machine
  81 -- machineNounVerb machine noun verb = machine { _memory = M.insert 1 noun $ M.insert 2 verb $ _memory machine }
  82
  83 -- machineOutput :: Machine -> Int
  84 -- machineOutput machine = (_memory machine)!0
  85
  86
  87 runAll :: ProgrammedMachine
  88 runAll = do mem <- gets _memory
  89             ip <- gets _ip
  90             unless (mem!ip == 99)
  91                 do runStep
  92                    runAll
  93
  94 runStep :: ProgrammedMachine
  95 runStep =
  96     do mem <- gets _memory
  97        ip <- gets _ip
  98        let opcode = (mem!ip) `mod` 100
  99        let modes = parameterModes  ((mem!ip) `div` 100)
 100        fetchInput opcode
 101        putOutput opcode modes
 102        mem' <- gets _memory
 103        let (mem'', ip') = perform opcode ip modes mem'
 104        modify (\m -> m {_ip = ip', _memory = mem''})
 105
 106
 107 -- fetchInput opcode | trace ("Input with opcode " ++ show opcode) False = undefined
 108 fetchInput 3 =
 109     do mem <- gets _memory
 110        ip <- gets _ip
 111        inputIndex <- gets _inputIndex
 112        inputs <- ask
 113        let mem' = iInsert (ip + 1) (inputs!!inputIndex) mem
 114        modify (\m -> m {_inputIndex = inputIndex + 1, _memory = mem'})
 115 fetchInput _ = return ()
 116
 117
 118 -- putOutput opcode _modes | trace ("Output with opcode " ++ show opcode) False = undefined
 119 putOutput 4 modes =
 120     do mem <- gets _memory
 121        ip <- gets _ip
 122        let v = getMemoryValue (ip + 1) (modes!!0) mem
 123        tell [v]
 124 putOutput _ _ = return ()
 125
 126
 127 perform :: Int -> Int -> [ParameterMode] -> Memory -> (Memory, Int)
 128 -- 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
 129 perform 1 ip modes mem = (iInsert (ip + 3) (a + b) mem, ip + 4)
 130     where a = getMemoryValue (ip + 1) (modes!!0) mem
 131           b = getMemoryValue (ip + 2) (modes!!1) mem
 132 perform 2 ip modes mem = (iInsert (ip + 3) (a * b) mem, ip + 4)
 133     where a = getMemoryValue (ip + 1) (modes!!0) mem
 134           b = getMemoryValue (ip + 2) (modes!!1) mem
 135 perform 3 ip _ mem = (mem, ip + 2)
 136 perform 4 ip _ mem = (mem, ip + 2)
 137 perform 5 ip modes mem = (mem, ip')
 138     where a = getMemoryValue (ip + 1) (modes!!0) mem
 139           b = getMemoryValue (ip + 2) (modes!!1) mem
 140           ip' = if a /= 0 then b else ip + 3
 141 perform 6 ip modes mem = (mem, ip')
 142     where a = getMemoryValue (ip + 1) (modes!!0) mem
 143           b = getMemoryValue (ip + 2) (modes!!1) mem
 144           ip' = if a == 0 then b else ip + 3
 145 perform 7 ip modes mem = (iInsert (ip + 3) res mem, ip + 4)
 146     where a = getMemoryValue (ip + 1) (modes!!0) mem
 147           b = getMemoryValue (ip + 2) (modes!!1) mem
 148           res = if a < b then 1 else 0
 149 perform 8 ip modes mem = (iInsert (ip + 3) res mem, ip + 4)
 150     where a = getMemoryValue (ip + 1) (modes!!0) mem
 151           b = getMemoryValue (ip + 2) (modes!!1) mem
 152           res = if a == b then 1 else 0
 153 perform _ ip _ mem = (mem, ip)
 154
 155
 156 getMemoryValue loc Position mem = mem!>loc
 157 getMemoryValue loc Immediate mem = mem!loc
 158
 159
 160 parameterModes :: Int -> [ParameterMode]
 161 parameterModes modeCode = unfoldr generateMode modeCode
 162
 163 generateMode :: Int -> Maybe (ParameterMode, Int)
 164 generateMode modeCode = Just (mode, modeCode `div` 10)
 165     where mode = case (modeCode `mod` 10) of
 166                     0 -> Position
 167                     1 -> Immediate
 168
 169
 170 -- Some IntMap utility functions, for syntactic sugar
 171
 172 -- prefix version of (!)
 173 lkup k m = m!k
 174
 175 -- indirect lookup
 176 (!>) m k = m!(m!k)
 177
 178 -- indirect insert
 179 iInsert k v m = M.insert (m!k) v m
 180
 181
 182
 183 -- Parse the input file
 184 type Parser = Parsec Void Text
 185
 186 sc :: Parser ()
 187 sc = L.space (skipSome spaceChar) CA.empty CA.empty
 188 -- sc = L.space (skipSome (char ' ')) CA.empty CA.empty
 189
 190 lexeme  = L.lexeme sc
 191 integer = lexeme L.decimal
 192 signedInteger = L.signed sc integer
 193 symb = L.symbol sc
 194 comma = symb ","
 195
 196 memoryP = signedInteger `sepBy` comma
 197
 198 successfulParse :: Text -> [Int]
 199 successfulParse input =
 200         case parse memoryP "input" input of
 201                 Left  _err -> [] -- TIO.putStr $ T.pack $ parseErrorPretty err
 202                 Right memory -> memory