src/advent21/advent21.hs

   1 {-# LANGUAGE NegativeLiterals #-}
   2 {-# LANGUAGE FlexibleContexts #-}
   3 {-# LANGUAGE OverloadedStrings #-}
   4 {-# LANGUAGE TypeFamilies #-}
   5 {-# LANGUAGE BangPatterns #-}
   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 qualified Data.Set as S
  23 import Data.Bits ((.&.), (.|.))
  24
  25 import Control.Monad (when)
  26 import Control.Monad.State.Strict
  27 import Control.Monad.Reader
  28 import Control.Monad.Writer
  29
  30 type Memory = M.Map Integer Integer
  31
  32 data Location = Literal Integer | Register Integer deriving (Show, Eq)
  33 data Instruction =
  34       Addr Integer Integer Integer
  35     | Addi Integer Integer Integer
  36     | Mulr Integer Integer Integer
  37     | Muli Integer Integer Integer
  38     | Banr Integer Integer Integer
  39     | Bani Integer Integer Integer
  40     | Borr Integer Integer Integer
  41     | Bori Integer Integer Integer
  42     | Setr Integer Integer Integer
  43     | Seti Integer Integer Integer
  44     | Gtir Integer Integer Integer
  45     | Gtri Integer Integer Integer
  46     | Gtrr Integer Integer Integer
  47     | Eqir Integer Integer Integer
  48     | Eqri Integer Integer Integer
  49     | Eqrr Integer Integer Integer
  50     deriving (Eq, Show, Ord)
  51
  52
  53 data Machine = Machine { _registers :: M.Map Integer Integer
  54                        , _pc :: Int
  55                        , _history :: S.Set Integer
  56                        , _previous :: Integer
  57                        -- , _pcReg :: Integer
  58                        }
  59                deriving (Show, Eq)
  60
  61 type ProgrammedMachine = WriterT [Integer] (ReaderT (Integer, [Instruction]) (State Machine)) ()
  62
  63 emptyMachine = Machine { _registers = M.fromList (zip [0..5] (repeat 0))
  64                        , _pc = 0
  65                        , _history = S.empty
  66                        , _previous = 0
  67                        }
  68
  69 main :: IO ()
  70 main = do
  71         text <- TIO.readFile "data/advent21.txt"
  72         let (ip, instrs) = successfulParse text
  73         -- print (ip, instrs)
  74         -- print $ zip [0..] instrs
  75         print $ part1 ip instrs
  76         print $ part2 ip instrs
  77
  78 part1 ip instructions =
  79     runState (
  80         runReaderT (
  81             runWriterT executeInstructions1
  82                    )
  83             (ip, instructions)
  84              )
  85              emptyMachine
  86
  87 part2 ip instructions =
  88     runState (
  89         runReaderT (
  90             runWriterT executeInstructions2
  91                    )
  92             (ip, instructions)
  93              )
  94              emptyMachine
  95
  96
  97 -- part2 ip instructions = head (dropWhile terminates [11592302..]) - 1
  98 -- part2 ip instructions = terminates 11592301
  99 --     where emptyRegisters = _registers emptyMachine
 100 --           m2 reg0 = emptyMachine {_registers = M.insert 0 reg0 emptyRegisters}
 101 --           terminates reg0 = null $ runResult (m2 reg0) ip instructions
 102
 103 -- runResult machine ip instructions = r1Repeat
 104 --     where
 105 --         r1Repeat = snd $ fst $ result
 106 --         result =
 107 --           runState (
 108 --             runReaderT (
 109 --                 runWriterT executeInstructions2
 110 --                        )
 111 --                 (ip, instructions)
 112 --                  )
 113 --                  machine
 114
 115
 116 executeInstructions1 =
 117     do  (_, instrs) <- ask
 118         m <- get
 119         if (_pc m == 28) then do
 120           tell [(_registers m)!1]
 121         else do
 122           when (_pc m >= 0 && _pc m < length instrs)
 123               $
 124               do executeInstruction
 125                  executeInstructions1
 126
 127 executeInstructions2 =
 128     do  (_, instrs) <- ask
 129         m0 <- get
 130         let r1 = (trace ("R1 = " ++ (show $ (_registers m0)!1) ++ " :: " ++ (show $ S.size (_history m0)))) $ (_registers m0)!1
 131         if (_pc m0 == 28 && (S.member r1 (_history m0))) then do
 132             -- abort as found a loop
 133             tell $ [_previous m0]
 134         else do
 135             when (_pc m0 == 28)
 136                 $
 137                 do
 138                     let m0' = m0 { _history = S.insert ((_registers m0)!1) (_history m0)
 139                                  , _previous = (_registers m0)!1 }
 140                     -- let x = trace ("PC = 28, register 1 = " ++ (show ((_registers m0)!1))) $! True
 141                     put m0'
 142             m <- get
 143             when (_pc m >= 0 && _pc m < length instrs)
 144                 $
 145                 do  executeInstruction
 146                     executeInstructions2
 147
 148
 149 executeInstruction :: ProgrammedMachine
 150 executeInstruction =
 151     do  (pcIs, instrs) <- ask
 152         m <- get
 153         let instr = instrs!!(_pc m)
 154         let memory0 = _registers m
 155         let memory1 = M.insert pcIs (fromIntegral (_pc m)) memory0
 156         let memory2 = perform instr memory1
 157         let pc' = fromIntegral ((memory2!pcIs) + 1)
 158         -- let aaa = trace ("pc: " ++ show (_pc m) ++ " m0: " ++ show memory0 ++ " m1: " ++ show memory1 ++ "m2: " ++ show memory2 ++ "pc': " ++ show pc') $! True
 159         let m' = m {_registers = memory2, _pc = pc'}
 160         put m'
 161
 162
 163 perform :: Instruction -> Memory -> Memory
 164 -- perform instr memory | ((memory!5 == 7) || ((memory!5 == 3) && (memory!1 == 1))) && (trace ("Perform " ++ show instr ++ " " ++ show memory) False) = undefined
 165 -- perform instr memory | trace ("Perform " ++ show instr ++ " " ++ show memory) False = undefined
 166 perform (Addr a b c) !memory = M.insert c (memory!a + memory!b) memory
 167 perform (Addi a b c) !memory = M.insert c (memory!a + b) memory
 168 perform (Mulr a b c) !memory = M.insert c (memory!a * memory!b) memory
 169 perform (Muli a b c) !memory = M.insert c (memory!a * b) memory
 170 perform (Banr a b c) !memory = M.insert c (memory!a .&. memory!b) memory
 171 perform (Bani a b c) !memory = M.insert c (memory!a .&. b) memory
 172 perform (Borr a b c) !memory = M.insert c (memory!a .|. memory!b) memory
 173 perform (Bori a b c) !memory = M.insert c (memory!a .|. b) memory
 174 perform (Setr a b c) !memory = M.insert c (memory!a) memory
 175 perform (Seti a b c) !memory = M.insert c a memory
 176 perform (Gtir a b c) !memory = M.insert c (if a > (memory!b) then 1 else 0) memory
 177 perform (Gtri a b c) !memory = M.insert c (if (memory!a) > b then 1 else 0) memory
 178 perform (Gtrr a b c) !memory = M.insert c (if (memory!a) > (memory!b) then 1 else 0) memory
 179 perform (Eqir a b c) !memory = M.insert c (if a == memory!b then 1 else 0) memory
 180 perform (Eqri a b c) !memory = M.insert c (if (memory!a) == b then 1 else 0) memory
 181 perform (Eqrr a b c) !memory = M.insert c (if (memory!a) == (memory!b) then 1 else 0) memory
 182
 183
 184 -- evaluate :: Machine -> Location -> Integer
 185 -- evaluate _ (Literal i)  = i
 186 -- evaluate m (Register r) = M.findWithDefault 0 r (registers m)
 187
 188
 189
 190 type Parser = Parsec Void Text
 191
 192 sc :: Parser ()
 193 sc = L.space (skipSome spaceChar) CA.empty CA.empty
 194
 195 lexeme  = L.lexeme sc
 196 integer = lexeme L.decimal
 197 symb = L.symbol sc
 198
 199
 200 instructionsP = (,) <$> headerP <*> many instructionP
 201 instructionP = choice [ addrP, addiP, mulrP, muliP, banrP, baniP,
 202     borrP, boriP, setrP, setiP, gtirP, gtriP, gtrrP,
 203     eqirP, eqriP, eqrrP ]
 204
 205 headerP = symb "#ip" *> integer
 206
 207 addrP = Addr <$> (try (symb "addr") *> integer) <*> integer <*> integer
 208 addiP = Addi <$> (try (symb "addi") *> integer) <*> integer <*> integer
 209 mulrP = Mulr <$> (try (symb "mulr") *> integer) <*> integer <*> integer
 210 muliP = Muli <$> (try (symb "muli") *> integer) <*> integer <*> integer
 211 banrP = Banr <$> (try (symb "banr") *> integer) <*> integer <*> integer
 212 baniP = Bani <$> (try (symb "bani") *> integer) <*> integer <*> integer
 213 borrP = Borr <$> (try (symb "borr") *> integer) <*> integer <*> integer
 214 boriP = Bori <$> (try (symb "bori") *> integer) <*> integer <*> integer
 215 setrP = Setr <$> (try (symb "setr") *> integer) <*> integer <*> integer
 216 setiP = Seti <$> (try (symb "seti") *> integer) <*> integer <*> integer
 217 gtirP = Gtir <$> (try (symb "gtir") *> integer) <*> integer <*> integer
 218 gtriP = Gtri <$> (try (symb "gtri") *> integer) <*> integer <*> integer
 219 gtrrP = Gtrr <$> (try (symb "gtrr") *> integer) <*> integer <*> integer
 220 eqirP = Eqir <$> (try (symb "eqir") *> integer) <*> integer <*> integer
 221 eqriP = Eqri <$> (try (symb "eqri") *> integer) <*> integer <*> integer
 222 eqrrP = Eqrr <$> (try (symb "eqrr") *> integer) <*> integer <*> integer
 223
 224 successfulParse :: Text -> (Integer, [Instruction])
 225 successfulParse input =
 226         case parse instructionsP "input" input of
 227                 Left  _error -> (0, []) -- TIO.putStr $ T.pack $ parseErrorPretty err
 228                 Right instructions  -> instructions