src/advent19/advent19.hs

   1 {-# LANGUAGE NegativeLiterals #-}
   2 {-# LANGUAGE FlexibleContexts #-}
   3 {-# LANGUAGE OverloadedStrings #-}
   4 {-# LANGUAGE TypeFamilies #-}
   5
   6
   7 import Debug.Trace
   8
   9 -- import Prelude hiding ((++))
  10 import Data.Text (Text)
  11 import qualified Data.Text as T
  12 import qualified Data.Text.IO as TIO
  13
  14 import Data.Void (Void)
  15 import Text.Megaparsec hiding (State)
  16 import Text.Megaparsec.Char
  17 import qualified Text.Megaparsec.Char.Lexer as L
  18 import qualified Control.Applicative as CA
  19
  20 import qualified Data.Map.Strict as M
  21 import Data.Map.Strict ((!))
  22 import Data.Bits ((.&.), (.|.))
  23
  24 import Control.Monad (when)
  25 import Control.Monad.State.Lazy
  26 import Control.Monad.Reader
  27 import Control.Monad.Writer
  28
  29 type Memory = M.Map Integer Integer
  30
  31 data Location = Literal Integer | Register Integer deriving (Show, Eq)
  32 data Instruction =
  33       Addr Integer Integer Integer
  34     | Addi Integer Integer Integer
  35     | Mulr Integer Integer Integer
  36     | Muli Integer Integer Integer
  37     | Banr Integer Integer Integer
  38     | Bani Integer Integer Integer
  39     | Borr Integer Integer Integer
  40     | Bori Integer Integer Integer
  41     | Setr Integer Integer Integer
  42     | Seti Integer Integer Integer
  43     | Gtir Integer Integer Integer
  44     | Gtri Integer Integer Integer
  45     | Gtrr Integer Integer Integer
  46     | Eqir Integer Integer Integer
  47     | Eqri Integer Integer Integer
  48     | Eqrr Integer Integer Integer
  49     deriving (Eq, Show, Ord)
  50
  51
  52 data Machine = Machine { _registers :: M.Map Integer Integer
  53                        , _pc :: Int
  54                        -- , _pcReg :: Integer
  55                        }
  56                deriving (Show, Eq)
  57
  58 type ProgrammedMachine = WriterT [Integer] (ReaderT (Integer, [Instruction]) (State Machine)) ()
  59
  60 emptyMachine = Machine {_registers = M.fromList (zip [0..5] (repeat 0)),
  61                         _pc = 0}
  62
  63 main :: IO ()
  64 main = do
  65         text <- TIO.readFile "data/advent19.txt"
  66         let (ip, instrs) = successfulParse text
  67         print (ip, instrs)
  68         -- print $ part1 ip instrs
  69         print $ sum [i | i <- [1..1032], 1032 `mod` i == 0]
  70         -- print $ part2 ip instrs
  71         print $ sum [i | i <- [1..10551432], 10551432 `mod` i == 0]
  72
  73 part1 ip instructions =
  74     runState (
  75         runReaderT (
  76             runWriterT executeInstructions
  77                    )
  78             (ip, instructions)
  79              )
  80              emptyMachine
  81
  82 part2 ip instructions =
  83     runState (
  84         runReaderT (
  85             runWriterT executeInstructions
  86                    )
  87             (ip, instructions)
  88              )
  89              m2
  90     where emptyRegisters = _registers emptyMachine
  91           m2 = emptyMachine {_registers = M.insert 0 1 emptyRegisters}
  92
  93 executeInstructions =
  94     do  (_, instrs) <- ask
  95         m <- get
  96         when (_pc m >= 0 && _pc m < length instrs)
  97             $
  98             do executeInstruction
  99                executeInstructions
 100
 101 executeInstruction :: ProgrammedMachine
 102 executeInstruction =
 103     do  (pcIs, instrs) <- ask
 104         m <- get
 105         let instr = instrs!!(_pc m)
 106         let memory0 = _registers m
 107         let memory1 = M.insert pcIs (fromIntegral (_pc m)) memory0
 108         let memory2 = if canPeep1 instrs (_pc m) memory1 --  sample1 == sample1Target
 109                       then memoryPeep1 memory1
 110                       else perform instr memory1
 111         -- let memory2 = perform instr memory1
 112         let pc' = fromIntegral ((memory2!pcIs) + 1)
 113         -- let aaa = trace ("pc: " ++ show (_pc m) ++ " m0: " ++ show memory0 ++ " m1: " ++ show memory1 ++ "m2: " ++ show memory2 ++ "pc': " ++ show pc') $! True
 114         let m' = m {_registers = memory2, _pc = pc'}
 115         put m'
 116     where sample1 pcVal instructions = take (length sample1Target) $ drop pcVal instructions
 117           sample1Target = [ Mulr 3 1 4
 118                           , Eqrr 4 2 4
 119                           , Addr 4 5 5
 120                           , Addi 5 1 5
 121                           , Addr 3 0 0
 122                           , Addi 1 1 1
 123                           , Gtrr 1 2 4
 124                           , Addr 5 4 5
 125                           , Seti 2 7 5
 126                           ]
 127           canPeep1 instructions pcVal mem = False -- ((sample1 pcVal instructions) == sample1Target) && ((mem!4) == 0)
 128           memoryPeep1 mem = M.union (M.fromList [(0, mem!0 + (if (((mem!2) `mod` (mem!3)) == 0) then mem!3 else 0)), (1, mem!2), (4, mem!2)]) mem
 129           -- M.insert 0 (mem!0 + mem!3) $ M.insert 1 (mem!2) $ M.insert 4 (mem!2) mem
 130
 131
 132 perform :: Instruction -> Memory -> Memory
 133 -- perform instr memory | ((memory!5 == 7) || ((memory!5 == 3) && (memory!1 == 1))) && (trace ("Perform " ++ show instr ++ " " ++ show memory) False) = undefined
 134 perform instr memory | trace ("Perform " ++ show instr ++ " " ++ show memory) False = undefined
 135 perform (Addr a b c) memory = M.insert c (memory!a + memory!b) memory
 136 perform (Addi a b c) memory = M.insert c (memory!a + b) memory
 137 perform (Mulr a b c) memory = M.insert c (memory!a * memory!b) memory
 138 perform (Muli a b c) memory = M.insert c (memory!a * b) memory
 139 perform (Banr a b c) memory = M.insert c (memory!a .&. memory!b) memory
 140 perform (Bani a b c) memory = M.insert c (memory!a .&. b) memory
 141 perform (Borr a b c) memory = M.insert c (memory!a .|. memory!b) memory
 142 perform (Bori a b c) memory = M.insert c (memory!a .|. b) memory
 143 perform (Setr a b c) memory = M.insert c (memory!a) memory
 144 perform (Seti a b c) memory = M.insert c a memory
 145 perform (Gtir a b c) memory = M.insert c (if a > (memory!b) then 1 else 0) memory
 146 perform (Gtri a b c) memory = M.insert c (if (memory!a) > b then 1 else 0) memory
 147 perform (Gtrr a b c) memory = M.insert c (if (memory!a) > (memory!b) then 1 else 0) memory
 148 perform (Eqir a b c) memory = M.insert c (if a == memory!b then 1 else 0) memory
 149 perform (Eqri a b c) memory = M.insert c (if (memory!a) == b then 1 else 0) memory
 150 perform (Eqrr a b c) memory = M.insert c (if (memory!a) == (memory!b) then 1 else 0) memory
 151
 152
 153 -- evaluate :: Machine -> Location -> Integer
 154 -- evaluate _ (Literal i)  = i
 155 -- evaluate m (Register r) = M.findWithDefault 0 r (registers m)
 156
 157
 158
 159 type Parser = Parsec Void Text
 160
 161 sc :: Parser ()
 162 sc = L.space (skipSome spaceChar) CA.empty CA.empty
 163
 164 lexeme  = L.lexeme sc
 165 integer = lexeme L.decimal
 166 symb = L.symbol sc
 167
 168
 169 instructionsP = (,) <$> headerP <*> many instructionP
 170 instructionP = choice [ addrP, addiP, mulrP, muliP, banrP, baniP,
 171     borrP, boriP, setrP, setiP, gtirP, gtriP, gtrrP,
 172     eqirP, eqriP, eqrrP ]
 173
 174 headerP = symb "#ip" *> integer
 175
 176 addrP = Addr <$> (try (symb "addr") *> integer) <*> integer <*> integer
 177 addiP = Addi <$> (try (symb "addi") *> integer) <*> integer <*> integer
 178 mulrP = Mulr <$> (try (symb "mulr") *> integer) <*> integer <*> integer
 179 muliP = Muli <$> (try (symb "muli") *> integer) <*> integer <*> integer
 180 banrP = Banr <$> (try (symb "banr") *> integer) <*> integer <*> integer
 181 baniP = Bani <$> (try (symb "bani") *> integer) <*> integer <*> integer
 182 borrP = Borr <$> (try (symb "borr") *> integer) <*> integer <*> integer
 183 boriP = Bori <$> (try (symb "bori") *> integer) <*> integer <*> integer
 184 setrP = Setr <$> (try (symb "setr") *> integer) <*> integer <*> integer
 185 setiP = Seti <$> (try (symb "seti") *> integer) <*> integer <*> integer
 186 gtirP = Gtir <$> (try (symb "gtir") *> integer) <*> integer <*> integer
 187 gtriP = Gtri <$> (try (symb "gtri") *> integer) <*> integer <*> integer
 188 gtrrP = Gtrr <$> (try (symb "gtrr") *> integer) <*> integer <*> integer
 189 eqirP = Eqir <$> (try (symb "eqir") *> integer) <*> integer <*> integer
 190 eqriP = Eqri <$> (try (symb "eqri") *> integer) <*> integer <*> integer
 191 eqrrP = Eqrr <$> (try (symb "eqrr") *> integer) <*> integer <*> integer
 192
 193 successfulParse :: Text -> (Integer, [Instruction])
 194 successfulParse input =
 195         case parse instructionsP "input" input of
 196                 Left  _error -> (0, []) -- TIO.putStr $ T.pack $ parseErrorPretty err
 197                 Right instructions  -> instructions