advent09/src/advent09.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.Map.Strict as M
  21 import Data.Map.Strict ((!))
  22 import Data.List
  23 -- import Data.Function (on)
  24
  25 type Memory = M.Map Integer Integer
  26
  27 data Machine = Machine { _memory :: Memory
  28                        , _ip :: Integer
  29                        , _inputIndex :: Int
  30                        , _rb :: Integer
  31                        }
  32                deriving (Show, Eq)
  33
  34 type ProgrammedMachine = RWS [Integer] [Integer] Machine
  35
  36 data ExecutionState = Runnable | Blocked | Terminated  deriving (Ord, Eq, Show)
  37
  38 data ParameterMode = Position | Immediate | Relative deriving (Ord, Eq, Show)
  39
  40
  41 main :: IO ()
  42 main = do
  43         text <- TIO.readFile "data/advent09.txt"
  44         let mem = successfulParse text
  45         print $ part1 mem
  46         print $ part2 mem
  47
  48
  49 part1 mem = findMachineOutput [1] mem
  50
  51 part2 mem = findMachineOutput [2] mem
  52
  53
  54 findMachineOutput :: [Integer] -> [Integer] -> [Integer]
  55 findMachineOutput inputs program = output
  56     where (_haltedBecause, _machine, output) = runRWS runAll inputs (makeMachine program)
  57
  58
  59 makeMachine :: [Integer] -> Machine
  60 makeMachine memory = Machine    {_ip = 0, _inputIndex = 0, _rb = 0
  61                                 , _memory = M.fromList $ zip [0..] memory
  62                                 }
  63
  64
  65 runAll :: ProgrammedMachine ExecutionState
  66 runAll = do mem <- gets _memory
  67             ip <- gets _ip
  68             input <- ask
  69             iIndex <- gets _inputIndex
  70             let acutalInputLength = length input
  71             let requiredInputLength = iIndex + 1
  72             if (mem!ip == 99)
  73             then return Terminated
  74             else    if (mem!ip == 3 && requiredInputLength > acutalInputLength)
  75                     then return Blocked
  76                     else do runStep
  77                             runAll
  78
  79 runStep :: ProgrammedMachine ()
  80 runStep =
  81     do mem <- gets _memory
  82        ip <- gets _ip
  83        rb <- gets _rb
  84        let opcode = (mem!ip) `mod` 100
  85        let modes = parameterModes ((mem!ip) `div` 100)
  86        fetchInput opcode modes
  87        putOutput opcode modes
  88        mem' <- gets _memory
  89        let (mem'', ip', rb') = perform opcode ip modes rb mem'
  90        modify (\m -> m {_ip = ip', _memory = mem'', _rb = rb'})
  91
  92 fetchInput :: Integer -> [ParameterMode] -> ProgrammedMachine ()
  93 -- fetchInput opcode _modes | trace ("Input with opcode " ++ show opcode) False = undefined
  94 fetchInput 3 modes =
  95     do mem <- gets _memory
  96        ip <- gets _ip
  97        rb <- gets _rb
  98        inputIndex <- gets _inputIndex
  99        inputs <- ask
 100        let mem' = iInsert (ip + 1) (modes!!0) rb (inputs!!inputIndex) mem
 101        modify (\m -> m {_inputIndex = inputIndex + 1, _memory = mem'})
 102 fetchInput _ _ = return ()
 103
 104 putOutput :: Integer -> [ParameterMode] -> ProgrammedMachine ()
 105 -- putOutput opcode _modes | trace ("Output with opcode " ++ show opcode) False = undefined
 106 putOutput 4 modes =
 107     do mem <- gets _memory
 108        ip <- gets _ip
 109        rb <- gets _rb
 110        let v = getMemoryValue (ip + 1) (modes!!0) rb mem
 111        tell [v]
 112 putOutput _ _ = return ()
 113
 114
 115 perform :: Integer -> Integer -> [ParameterMode] -> Integer -> Memory -> (Memory, Integer, Integer)
 116 -- perform instr ip modes rb mem | trace ("Perform ip " ++ show ip ++ " opcode " ++ show instr ++ " modes " ++ (show (take 3 modes)) ++ " rb " ++ (show rb) ++ " args " ++ (intercalate ", " (map show [(mem!(ip+1)), (mem!(ip+2)), (mem!(ip+3))]))) False = undefined
 117 perform 1 ip modes rb mem = (iInsert (ip + 3) (modes!!2) rb (a + b) mem, ip + 4, rb)
 118     where a = getMemoryValue (ip + 1) (modes!!0) rb mem
 119           b = getMemoryValue (ip + 2) (modes!!1) rb mem
 120 perform 2 ip modes rb mem = (iInsert (ip + 3) (modes!!2) rb (a * b) mem, ip + 4, rb)
 121     where a = getMemoryValue (ip + 1) (modes!!0) rb mem
 122           b = getMemoryValue (ip + 2) (modes!!1) rb mem
 123 perform 3 ip _ rb mem = (mem, ip + 2, rb)
 124 perform 4 ip _ rb mem = (mem, ip + 2, rb)
 125 perform 5 ip modes rb mem = (mem, ip', rb)
 126     where a = getMemoryValue (ip + 1) (modes!!0) rb mem
 127           b = getMemoryValue (ip + 2) (modes!!1) rb mem
 128           ip' = if a /= 0 then b else ip + 3
 129 perform 6 ip modes rb mem = (mem, ip', rb)
 130     where a = getMemoryValue (ip + 1) (modes!!0) rb mem
 131           b = getMemoryValue (ip + 2) (modes!!1) rb mem
 132           ip' = if a == 0 then b else ip + 3
 133 perform 7 ip modes rb mem = (iInsert (ip + 3) (modes!!2) rb res mem, ip + 4, rb)
 134     where a = getMemoryValue (ip + 1) (modes!!0) rb mem
 135           b = getMemoryValue (ip + 2) (modes!!1) rb mem
 136           res = if a < b then 1 else 0
 137 perform 8 ip modes rb mem = (iInsert (ip + 3) (modes!!2) rb res mem, ip + 4, rb)
 138     where a = getMemoryValue (ip + 1) (modes!!0) rb mem
 139           b = getMemoryValue (ip + 2) (modes!!1) rb mem
 140           res = if a == b then 1 else 0
 141 perform 9 ip modes rb mem = (mem, ip + 2, rb + a)
 142     where a = getMemoryValue (ip + 1) (modes!!0) rb mem
 143 perform _ ip _ rb mem = (mem, ip, rb)
 144
 145
 146 getMemoryValue :: Integer -> ParameterMode -> Integer -> Memory -> Integer
 147 getMemoryValue loc Position rb mem = getMemoryValue loc' Immediate rb mem
 148     where loc' = M.findWithDefault 0 loc mem
 149 getMemoryValue loc Immediate _ mem = M.findWithDefault 0 loc mem
 150 getMemoryValue loc Relative rb mem = getMemoryValue loc' Immediate 0 mem
 151     where loc' = rb + M.findWithDefault 0 loc mem
 152
 153 -- indirect insert
 154 iInsert :: Integer -> ParameterMode -> Integer -> Integer -> Memory -> Memory
 155 iInsert loc Position _rb value mem = M.insert loc' value mem
 156     where loc' = M.findWithDefault 0 loc mem
 157 iInsert loc Immediate _rb value mem = M.insert loc value mem
 158 iInsert loc Relative rb value mem = M.insert loc' value mem
 159     where loc' = rb + M.findWithDefault 0 loc mem
 160
 161 parameterModes :: Integer -> [ParameterMode]
 162 parameterModes modeCode = unfoldr generateMode modeCode
 163
 164 generateMode :: Integer -> Maybe (ParameterMode, Integer)
 165 generateMode modeCode = Just (mode, modeCode `div` 10)
 166     where mode = case (modeCode `mod` 10) of
 167                     0 -> Position
 168                     1 -> Immediate
 169                     2 -> Relative
 170
 171 -- Parse the input file
 172 type Parser = Parsec Void Text
 173
 174 sc :: Parser ()
 175 sc = L.space (skipSome spaceChar) CA.empty CA.empty
 176 -- sc = L.space (skipSome (char ' ')) CA.empty CA.empty
 177
 178 lexeme  = L.lexeme sc
 179 integer = lexeme L.decimal
 180 signedInteger = L.signed sc integer
 181 symb = L.symbol sc
 182 comma = symb ","
 183
 184 memoryP = signedInteger `sepBy` comma
 185
 186 successfulParse :: Text -> [Integer]
 187 successfulParse input =
 188         case parse memoryP "input" input of
 189                 Left  _err -> [] -- TIO.putStr $ T.pack $ parseErrorPretty err
 190                 Right memory -> memory