src/advent21/advent21-from-megathread.hs

   1 {-|
   2 Module:         Day21
   3 Description:    <https://adventofcode.com/2018/day/21 Day 21: Chronal Conversion>
   4 -}
   5 {-# LANGUAGE FlexibleContexts, RecordWildCards, TypeApplications #-}
   6 {-# OPTIONS_GHC -Wno-name-shadowing #-}
   7
   8 import Control.Monad.Cont (callCC, runCont, runContT)
   9 import Control.Monad.Loops (iterateM_)
  10 import Control.Monad.State (evalState, get, put)
  11 import Data.Array.Unboxed (Array, IArray, Ix, UArray, (!), (//), bounds, inRange, listArray)
  12 import Data.Bits (Bits, (.&.), (.|.))
  13 import Data.Bool (bool)
  14 import qualified Data.IntSet as S (empty, insert, member)
  15 import Data.List (genericLength)
  16 import Text.Megaparsec (MonadParsec, between, choice, parseMaybe, sepEndBy)
  17 import Text.Megaparsec.Char (newline, space, string)
  18 import Text.Megaparsec.Char.Lexer (decimal)
  19
  20 data Op
  21   = ADDR | ADDI | MULR | MULI | BANR | BANI | BORR | BORI
  22   | SETR | SETI | GTIR | GTRI | GTRR | EQIR | EQRI | EQRR
  23   deriving (Eq)
  24
  25 data Instruction i = Instruction {op :: Op, a :: i, b :: i, c :: i}
  26
  27
  28 main :: IO ()
  29 main = do
  30         text <- readFile "data/advent21.txt"
  31         print $ day21a text
  32         print $ day21b text
  33
  34
  35 parser :: (IArray a (Instruction i), MonadParsec e String m, Integral i, Ix i) => m (i, a i (Instruction i))
  36 parser = do
  37     ip <- between (string "#ip" *> space) newline decimal
  38     isns <- flip sepEndBy newline $ do
  39         op <- choice
  40           [ ADDR <$ string "addr", ADDI <$ string "addi"
  41           , MULR <$ string "mulr", MULI <$ string "muli"
  42           , BANR <$ string "banr", BANI <$ string "bani"
  43           , BORR <$ string "borr", BORI <$ string "bori"
  44           , SETR <$ string "setr", SETI <$ string "seti"
  45           , GTIR <$ string "gtir", GTRI <$ string "gtri", GTRR <$ string "gtrr"
  46           , EQIR <$ string "eqir", EQRI <$ string "eqri", EQRR <$ string "eqrr"
  47           ]
  48         Instruction op <$> (space *> decimal) <*> (space *> decimal) <*> (space *> decimal)
  49     return (ip, listArray (0, genericLength isns - 1) isns)
  50
  51 doOp :: (IArray a i, Bits i, Integral i, Ix i) => a i i -> Op -> i -> i -> i
  52 doOp r ADDR a b = r ! a + r ! b
  53 doOp r ADDI a b = r ! a + b
  54 doOp r MULR a b = r ! a * r ! b
  55 doOp r MULI a b = r ! a * b
  56 doOp r BANR a b = r ! a .&. r ! b
  57 doOp r BANI a b = r ! a .&. b
  58 doOp r BORR a b = r ! a .|. r ! b
  59 doOp r BORI a b = r ! a .|. b
  60 doOp r SETR a _ = r ! a
  61 doOp _ SETI a _ = a
  62 doOp r GTIR a b = bool 0 1 $ a > r ! b
  63 doOp r GTRI a b = bool 0 1 $ r ! a > b
  64 doOp r GTRR a b = bool 0 1 $ r ! a > r ! b
  65 doOp r EQIR a b = bool 0 1 $ a == r ! b
  66 doOp r EQRI a b = bool 0 1 $ r ! a == b
  67 doOp r EQRR a b = bool 0 1 $ r ! a == r ! b
  68
  69 step :: (Monad m, IArray a1 i, IArray a2 (Instruction i), Bits i, Integral i, Ix i, Show (a1 i i)) => (i -> m ()) -> i -> a2 i (Instruction i) -> a1 i i -> m (a1 i i)
  70 step f ip isns regs
  71   | c == 0 = fail "writing value to register 0"
  72   | op == EQRR, a == 0, c /= ip = regs // [(c, 0), (ip, regs ! ip + 1)] <$ f (regs ! b)
  73   | op == EQRR, b == 0, c /= ip = regs // [(c, 0), (ip, regs ! ip + 1)] <$ f (regs ! a)
  74   | (op /= SETI && a == 0) || (op `elem` [ADDR, MULR, BANR, BORR, GTIR, GTRR, EQIR, EQRR] && b == 0)
  75   = fail "reading from register 0"
  76   | inRange (bounds isns) (base + 8)
  77   , Instruction SETI 0 _ t <- isn, t `notElem` [0, ip]
  78   , Instruction ADDI t' 1 u <- isns ! (base + 1), t == t', u `notElem` [0, ip, t]
  79   , Instruction MULI u' n u'' <- isns ! (base + 2), u == u', n > 0, u == u''
  80   , Instruction GTRR u' r u'' <- isns ! (base + 3), u == u', r `notElem` [0, ip, t], u == u''
  81   , Instruction ADDR u' ip' ip'' <- isns ! (base + 4), u == u', ip == ip', ip == ip''
  82   , Instruction ADDI ip' 1 ip'' <- isns ! (base + 5), ip == ip', ip == ip''
  83   , Instruction SETI base' _ ip' <- isns ! (base + 6), base + 8 == base', ip == ip'
  84   , Instruction ADDI t' u' t'' <- isns ! (base + 7), t == t', u == u', t == t''
  85   , Instruction SETI base' _ ip' <- isns ! (base + 8), base == base', ip == ip'
  86   = return $ regs // [(ip, base + 9), (t, max 0 $ regs ! r `div` n), (u, 1)]
  87   | otherwise
  88   = return $ regs // if ip == c then [(ip, result + 1)] else [(ip, regs ! ip + 1), (c, result)]
  89   where base = regs ! ip
  90         isn@Instruction {..} = isns ! base
  91         result = doOp regs op a b
  92
  93 day21a :: String -> Maybe Int
  94 day21a input = do
  95     (ip, isns) <- parseMaybe @() (parser @Array) input
  96     let regs = listArray @UArray (0, 5) $ repeat 0
  97     return $ flip runCont id $ callCC $ \f -> iterateM_ (step f ip isns) regs
  98
  99 day21b :: String -> Maybe Int
 100 day21b input = do
 101     (ip, isns) <- parseMaybe @() (parser @Array) input
 102     let regs = listArray @UArray (0, 5) $ repeat 0
 103         reportDup f i = do
 104             (seen, prior) <- get
 105             if i `S.member` seen then f prior else put (S.insert i seen, i)
 106     return $ flip evalState (S.empty, undefined) $ flip runContT return $ callCC $ \f ->
 107         iterateM_ (step (reportDup f) ip isns) regs