advent07/src/advent07.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 import Control.Monad.RWS.Strict
  18
  19
  20 import qualified Data.IntMap.Strict as M
  21 import Data.IntMap.Strict ((!))
  22 import Data.List
  23 import Data.Function (on)
  24
  25 type Memory = M.IntMap Int
  26
  27 data Machine = Machine { _memory :: Memory
  28                        , _ip :: Int
  29                        , _inputIndex :: Int
  30                        }
  31                deriving (Show, Eq)
  32
  33 type ProgrammedMachine = RWS [Int] [Int] Machine
  34
  35 data EncapsulatedMacine = EncapsulatedMacine
  36     { _machine :: Machine
  37     , _executionState :: ExecutionState
  38     , _initialInput :: [Int]
  39     , _currentInput :: [Int]
  40     , _machineOutput :: [Int]
  41     } deriving (Show, Eq)
  42
  43 data ParameterMode = Position | Immediate deriving (Ord, Eq, Show)
  44
  45 data ExecutionState = Runnable | Blocked | Terminated  deriving (Ord, Eq, Show)
  46
  47 type Pipeline = M.IntMap EncapsulatedMacine
  48
  49
  50 main :: IO ()
  51 main = do
  52         text <- TIO.readFile "data/advent07.txt"
  53         let mem = successfulParse text
  54         print $ part1 mem
  55         print $ part2 mem
  56
  57
  58 part1 mem = maximum outputs
  59     where inputs = permutations [0..4]
  60           outputs = map (chainMachines mem) inputs
  61
  62 chainMachines mem settings = foldl' (chainMachine mem) 0 settings
  63
  64 chainMachine mem prevOutput setting = findMachineOutput [setting, prevOutput] mem
  65
  66
  67 part2 mem = maximum outputs
  68     where   inputs = permutations [5..9]
  69             pipelines = map (buildPipeline mem) inputs
  70             outputs = map runPipeline pipelines
  71
  72 buildPipeline :: [Int] -> [Int] -> Pipeline
  73 buildPipeline mem input = M.insert 0 machine0' pipeline
  74     where pipeline = M.fromList $ zip [0..] $ map (encapsulate mem) input
  75           machine0 = pipeline!0
  76           machine0' = machine0 { _initialInput = (_initialInput machine0) ++ [0]}
  77
  78
  79 encapsulate :: [Int] -> Int -> EncapsulatedMacine
  80 encapsulate mem input = EncapsulatedMacine
  81     { _machine = makeMachine mem
  82     , _executionState = Runnable
  83     , _initialInput = [input]
  84     , _machineOutput = []
  85     , _currentInput = [input]
  86     }
  87
  88
  89 runPipeline :: Pipeline -> Int
  90 -- runPipeline pipeline | trace (pipelineTrace pipeline) False = undefined
  91 runPipeline pipeline
  92     | finished pipeline = last $ _machineOutput $ snd $ M.findMax pipeline
  93     | otherwise = runPipeline pipeline''
  94     where   (indexToRun, machineToRun) = M.findMin $ runnableMachines pipeline
  95             feedsIntoIndex = (indexToRun + 1) `mod` (M.size pipeline)
  96             feedsIntoMachine = pipeline!feedsIntoIndex
  97             fimi = _initialInput feedsIntoMachine
  98             machine' = runEncapsulatedMachine machineToRun
  99             fullOutput = _machineOutput machine'
 100             feedsIntoState = case (_executionState feedsIntoMachine) of
 101                                   Blocked -> Runnable
 102                                   Terminated -> Terminated
 103                                   Runnable -> Runnable
 104             feedsIntoMachine' = feedsIntoMachine {_executionState = feedsIntoState, _currentInput = fimi ++ fullOutput}
 105             pipeline' = M.insert indexToRun machine' pipeline
 106             pipeline'' = M.insert feedsIntoIndex feedsIntoMachine' pipeline'
 107
 108
 109
 110 pipelineTrace :: Pipeline -> String
 111 pipelineTrace pipeline = show $ M.toList $ M.map emTrace pipeline
 112
 113 emTrace e = intercalate " ; " terms
 114     where terms = [ show $ _executionState e
 115                   , "in"
 116                   , show $ _currentInput e
 117                   , "out"
 118                   , show $ _machineOutput e
 119                   ]
 120
 121
 122 finished :: Pipeline -> Bool
 123 finished = M.null . runnableMachines
 124
 125 runnableMachines :: Pipeline -> Pipeline
 126 runnableMachines = M.filter (\e -> _executionState e == Runnable)
 127
 128 runEncapsulatedMachine :: EncapsulatedMacine -> EncapsulatedMacine
 129 runEncapsulatedMachine e = e { _machine = machine'
 130                              , _executionState = halted
 131                              , _machineOutput = (_machineOutput e) ++ output
 132                              }
 133     where   machine = _machine e
 134             input = _currentInput e
 135             (halted, machine', output) = runRWS runAll input machine
 136
 137
 138 findMachineOutput :: [Int] -> [Int] -> Int
 139 findMachineOutput inputs program = last output
 140     where (_haltedBecause, _machine, output) = runRWS runAll inputs (makeMachine program)
 141
 142
 143 makeMachine :: [Int] -> Machine
 144 makeMachine memory = Machine    {_ip = 0, _inputIndex = 0
 145                                 , _memory = M.fromList $ zip [0..] memory
 146                                 }
 147
 148
 149 runAll :: ProgrammedMachine ExecutionState
 150 runAll = do mem <- gets _memory
 151             ip <- gets _ip
 152             input <- ask
 153             iIndex <- gets _inputIndex
 154             let acutalInputLength = length input
 155             let requiredInputLength = iIndex + 1
 156             if (mem!ip == 99)
 157             then return Terminated
 158             else    if (mem!ip == 3 && requiredInputLength > acutalInputLength)
 159                     then return Blocked
 160                     else do runStep
 161                             runAll
 162
 163 runStep :: ProgrammedMachine ()
 164 runStep =
 165     do mem <- gets _memory
 166        ip <- gets _ip
 167        let opcode = (mem!ip) `mod` 100
 168        let modes = parameterModes ((mem!ip) `div` 100)
 169        fetchInput opcode
 170        putOutput opcode modes
 171        mem' <- gets _memory
 172        let (mem'', ip') = perform opcode ip modes mem'
 173        modify (\m -> m {_ip = ip', _memory = mem''})
 174
 175 fetchInput :: Int -> ProgrammedMachine ()
 176 -- fetchInput opcode | trace ("Input with opcode " ++ show opcode) False = undefined
 177 fetchInput 3 =
 178     do mem <- gets _memory
 179        ip <- gets _ip
 180        inputIndex <- gets _inputIndex
 181        inputs <- ask
 182        let mem' = iInsert (ip + 1) (inputs!!inputIndex) mem
 183        modify (\m -> m {_inputIndex = inputIndex + 1, _memory = mem'})
 184 fetchInput _ = return ()
 185
 186 putOutput :: Int -> [ParameterMode] -> ProgrammedMachine ()
 187 -- putOutput opcode _modes | trace ("Output with opcode " ++ show opcode) False = undefined
 188 putOutput 4 modes =
 189     do mem <- gets _memory
 190        ip <- gets _ip
 191        let v = getMemoryValue (ip + 1) (modes!!0) mem
 192        tell [v]
 193 putOutput _ _ = return ()
 194
 195
 196 perform :: Int -> Int -> [ParameterMode] -> Memory -> (Memory, Int)
 197 -- 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
 198 perform 1 ip modes mem = (iInsert (ip + 3) (a + b) mem, ip + 4)
 199     where a = getMemoryValue (ip + 1) (modes!!0) mem
 200           b = getMemoryValue (ip + 2) (modes!!1) mem
 201 perform 2 ip modes mem = (iInsert (ip + 3) (a * b) mem, ip + 4)
 202     where a = getMemoryValue (ip + 1) (modes!!0) mem
 203           b = getMemoryValue (ip + 2) (modes!!1) mem
 204 perform 3 ip _ mem = (mem, ip + 2)
 205 perform 4 ip _ mem = (mem, ip + 2)
 206 perform 5 ip modes mem = (mem, ip')
 207     where a = getMemoryValue (ip + 1) (modes!!0) mem
 208           b = getMemoryValue (ip + 2) (modes!!1) mem
 209           ip' = if a /= 0 then b else ip + 3
 210 perform 6 ip modes mem = (mem, ip')
 211     where a = getMemoryValue (ip + 1) (modes!!0) mem
 212           b = getMemoryValue (ip + 2) (modes!!1) mem
 213           ip' = if a == 0 then b else ip + 3
 214 perform 7 ip modes mem = (iInsert (ip + 3) res mem, ip + 4)
 215     where a = getMemoryValue (ip + 1) (modes!!0) mem
 216           b = getMemoryValue (ip + 2) (modes!!1) mem
 217           res = if a < b then 1 else 0
 218 perform 8 ip modes mem = (iInsert (ip + 3) res mem, ip + 4)
 219     where a = getMemoryValue (ip + 1) (modes!!0) mem
 220           b = getMemoryValue (ip + 2) (modes!!1) mem
 221           res = if a == b then 1 else 0
 222 perform _ ip _ mem = (mem, ip)
 223
 224
 225 getMemoryValue loc Position mem = mem!>loc
 226 getMemoryValue loc Immediate mem = mem!loc
 227
 228
 229 parameterModes :: Int -> [ParameterMode]
 230 parameterModes modeCode = unfoldr generateMode modeCode
 231
 232 generateMode :: Int -> Maybe (ParameterMode, Int)
 233 generateMode modeCode = Just (mode, modeCode `div` 10)
 234     where mode = case (modeCode `mod` 10) of
 235                     0 -> Position
 236                     1 -> Immediate
 237
 238
 239 -- Some IntMap utility functions, for syntactic sugar
 240
 241 -- prefix version of (!)
 242 lkup k m = m!k
 243
 244 -- indirect lookup
 245 (!>) m k = m!(m!k)
 246
 247 -- indirect insert
 248 iInsert k v m = M.insert (m!k) v m
 249
 250
 251
 252 -- Parse the input file
 253 type Parser = Parsec Void Text
 254
 255 sc :: Parser ()
 256 sc = L.space (skipSome spaceChar) CA.empty CA.empty
 257 -- sc = L.space (skipSome (char ' ')) CA.empty CA.empty
 258
 259 lexeme  = L.lexeme sc
 260 integer = lexeme L.decimal
 261 signedInteger = L.signed sc integer
 262 symb = L.symbol sc
 263 comma = symb ","
 264
 265 memoryP = signedInteger `sepBy` comma
 266
 267 successfulParse :: Text -> [Int]
 268 successfulParse input =
 269         case parse memoryP "input" input of
 270                 Left  _err -> [] -- TIO.putStr $ T.pack $ parseErrorPretty err
 271                 Right memory -> memory