advent24/Main.hs

   1 -- Writeup at https://work.njae.me.uk/2022/04/23/advent-of-code-2021-day-24/
   2 -- Based on ideas by Daniel Lin,
   3 --   taken from https://github.com/ephemient/aoc2021/blob/main/hs/src/Day24.hs
   4
   5 -- import Debug.Trace
   6
   7 import Data.Text (Text)
   8 import qualified Data.Text.IO as TIO
   9 import Data.Attoparsec.Text -- hiding (take, takeWhile)
  10 import Control.Applicative
  11 import qualified Data.Map.Strict as M
  12 import Data.Map.Strict ((!))
  13 import Data.List
  14 import Control.Monad
  15 import Data.Maybe
  16
  17 data Register = W | X | Y | Z deriving (Eq, Ord, Show, Enum)
  18
  19 data Interval = Interval Integer Integer
  20   deriving (Eq, Ord, Show)
  21
  22 data Argument = Reg Register | Lit Integer
  23   deriving (Eq, Ord, Show)
  24
  25 data Instruction
  26   = Inp Register
  27   | Add Register Argument
  28   | Mul Register Argument
  29   | Div Register Argument
  30   | Mod Register Argument
  31   | Eql Register Argument
  32   deriving (Eq, Ord, Show)
  33
  34 type LitMachine = M.Map Register Integer
  35 type IntMachine = M.Map Register (Maybe Interval)
  36
  37 data ModelMachine = ModelMachine
  38   { mCode :: [Integer]
  39   , mMachine :: LitMachine
  40   } deriving (Show)
  41
  42 -- Main
  43
  44 main :: IO ()
  45 main =
  46   do  text <- TIO.readFile "data/advent24.txt"
  47       let instrs = successfulParse text
  48       let m0 = ModelMachine {mCode = [], mMachine = emptyMachine}
  49       putStrLn $ part1 m0 instrs
  50       putStrLn $ part2 m0 instrs
  51
  52 part1 :: ModelMachine -> [Instruction] -> String
  53 part1 = findCode [9, 8..1]
  54
  55 part2 :: ModelMachine -> [Instruction] -> String
  56 part2 = findCode [1..9]
  57
  58 findCode :: [Integer] -> ModelMachine -> [Instruction] -> String
  59 findCode digits machine instrs = concatMap show $ mCode $ head $ runLit instrs digits machine
  60
  61 plausible :: [Instruction] -> LitMachine -> Bool
  62 plausible instrs litMachine = feasible ranMachine
  63   where intMachine = intervalify litMachine
  64         ranMachine = runInt instrs intMachine
  65
  66 feasible :: Maybe IntMachine -> Bool
  67 feasible Nothing = False
  68 feasible (Just machine) = isJust z && a <= 0 && b >= 0
  69   where z = machine ! Z
  70         Just (Interval a b) = z
  71
  72
  73
  74 -- feasible :: IntMachine -> Bool
  75 -- -- feasible machine | trace ("Feasible " ++ (show machine)) False = undefined
  76 -- feasible machine
  77 --   | (w && x && y && isJust z) = a <= 0 && b >= 0
  78 --   | otherwise = False
  79 --   where w = isJust $ machine ! W
  80 --         x = isJust $ machine ! X
  81 --         y = isJust $ machine ! Y
  82 --         z = machine ! Z
  83 --         Just (Interval a b) = z
  84
  85 valid :: ModelMachine -> Bool
  86 valid (ModelMachine{..}) = (mMachine ! Z) == 0
  87
  88
  89 emptyMachine :: LitMachine
  90 emptyMachine = M.fromList [(r, 0) | r <- [W .. Z]]
  91
  92 intervalify :: LitMachine -> IntMachine
  93 intervalify = M.map (\i -> Just (Interval i i))
  94
  95
  96 runLit :: [Instruction] -> [Integer] -> ModelMachine -> [ModelMachine]
  97 -- runLit instrs _digits m0 | trace ((show $ length instrs) ++ " " ++ (show m0)) False = undefined
  98 -- runLit [] _digits machine | trace (show machine) True = [machine]
  99 runLit [] _ machine = [machine]
 100 runLit (Inp reg : instrs) digits (ModelMachine {..}) =
 101   do guard (plausible (Inp reg : instrs) mMachine)
 102      i <- digits
 103      let m1 = M.insert reg i mMachine
 104      mm2 <- runLit instrs digits (ModelMachine { mCode = mCode ++ [i], mMachine = m1})
 105      guard (valid mm2)
 106      return mm2
 107 runLit (Add reg arg : instrs) digits (ModelMachine {..}) =
 108   runLit instrs digits (ModelMachine{mMachine = M.insert reg c mMachine, ..})
 109   where a = mMachine ! reg
 110         b = evaluateLit arg mMachine
 111         c = a + b
 112 runLit (Mul reg arg : instrs) digits (ModelMachine {..}) =
 113   runLit instrs digits (ModelMachine{mMachine = M.insert reg c mMachine, ..})
 114   where a = mMachine ! reg
 115         b = evaluateLit arg mMachine
 116         c = a * b
 117 runLit (Div reg arg : instrs) digits (ModelMachine {..}) =
 118   runLit instrs digits (ModelMachine{mMachine = M.insert reg c mMachine, ..})
 119   where a = mMachine ! reg
 120         b = evaluateLit arg mMachine
 121         c = a `quot` b
 122 runLit (Mod reg arg : instrs) digits (ModelMachine {..}) =
 123   runLit instrs digits (ModelMachine{mMachine = M.insert reg c mMachine, ..})
 124   where a = mMachine ! reg
 125         b = evaluateLit arg mMachine
 126         c = a `rem` b
 127 runLit (Eql reg arg : instrs) digits (ModelMachine {..}) =
 128   runLit instrs digits (ModelMachine{mMachine = M.insert reg c mMachine, ..})
 129   where a = mMachine ! reg
 130         b = evaluateLit arg mMachine
 131         c = if a == b then 1 else 0
 132
 133
 134 runInt :: [Instruction] -> IntMachine -> Maybe IntMachine
 135 runInt instrs machine = foldl' interpretInt (Just machine) instrs
 136
 137 interpretInt :: Maybe IntMachine -> Instruction -> Maybe IntMachine
 138 -- interpretInt machine instr | trace ("iInt " ++ (show instr) ++ " " ++  (show machine)) False = undefined
 139 interpretInt Nothing _ = Nothing
 140 interpretInt (Just machine) (Inp reg) = Just $ M.insert reg (Just (Interval 1 9)) machine
 141 interpretInt (Just machine) (Add reg arg)
 142   | isJust a && isJust b = Just $ M.insert reg c machine
 143   | otherwise = Nothing
 144   where a = machine ! reg
 145         b = evaluateInt arg machine
 146         c = join $ (+:) <$> a <*> b
 147 interpretInt (Just machine) (Mul reg arg)
 148   | isJust a && isJust b = Just $ M.insert reg c machine
 149   | otherwise = Nothing
 150   where a = machine ! reg
 151         b = evaluateInt arg machine
 152         c = join $ (*:) <$> a <*> b
 153 interpretInt (Just machine) (Div reg arg)
 154   | isJust a && isJust b = Just $ M.insert reg c machine
 155   | otherwise = Nothing
 156   where a = machine ! reg
 157         b = evaluateInt arg machine
 158         c = join $ (/:) <$> a <*> b
 159 interpretInt (Just machine) (Mod reg arg)
 160   | isJust a && isJust b = Just $ M.insert reg c machine
 161   | otherwise = Nothing
 162   where a = machine ! reg
 163         b = evaluateInt arg machine
 164         c = join $ (%:) <$> a <*> b
 165 interpretInt (Just machine) (Eql reg arg)
 166   | isJust a && isJust b = Just $ M.insert reg c machine
 167   | otherwise = Nothing
 168   where a = machine ! reg
 169         b = evaluateInt arg machine
 170         c = join $ (=:) <$> a <*> b
 171
 172 (+:), (*:), (/:), (%:), (=:) :: Interval -> Interval -> Maybe Interval
 173 (Interval a b) +: (Interval c d) = Just (Interval (a + c) (b + d))
 174 (Interval a b) *: (Interval c d)
 175   | a >= 0 && c >= 0 = Just ( Interval (a * c) (b * d) )
 176   | b <= 0 && d <= 0 = Just ( Interval (b * d) (a * c) )
 177   | a >= 0 && d <= 0 = Just ( Interval (a * d) (b * c) )
 178   | b <= 0 && c >= 0 = Just ( Interval (b * c) (a * d) )
 179 (Interval a b) /: (Interval c d)
 180   | c > 0 = Just ( Interval (a `quot` d) (b `quot` c) )
 181   | d < 0 = Just ( Interval (a `quot` c) (b `quot` d) )
 182   | otherwise = Nothing
 183 (Interval _a _b) %: (Interval c d)
 184   | c > 0 = Just ( Interval 0 (d - 1))
 185   | otherwise = Nothing
 186 (Interval a b) =: (Interval c d)
 187   | b < c = Just (Interval 0 0)
 188   | a > d = Just (Interval 0 0)
 189   | a == b && a == c && a == d = Just (Interval 1 1)
 190   | otherwise = Just (Interval 0 1)
 191
 192
 193 evaluateLit :: Argument -> LitMachine -> Integer
 194 evaluateLit (Reg reg) machine =  machine ! reg
 195 evaluateLit (Lit n) _ = n
 196
 197 evaluateInt :: Argument -> IntMachine -> Maybe Interval
 198 evaluateInt (Reg reg) machine =  machine ! reg
 199 evaluateInt (Lit n) _ = Just (Interval n n)
 200
 201
 202 -- Parse the input file
 203
 204 instructionsP:: Parser [Instruction]
 205 instructionsP = instructionP `sepBy` endOfLine
 206
 207 instructionP:: Parser Instruction
 208 instructionP = choice [inpP, addP, mulP, divP, modP, eqlP]
 209
 210 inpP, addP, mulP, divP, modP, eqlP :: Parser Instruction
 211 inpP = Inp <$> ("inp " *> registerP)
 212 addP = Add <$> ("add " *> registerP) <*> (" " *> argumentP)
 213 mulP = Mul <$> ("mul " *> registerP) <*> (" " *> argumentP)
 214 divP = Div <$> ("div " *> registerP) <*> (" " *> argumentP)
 215 modP = Mod <$> ("mod " *> registerP) <*> (" " *> argumentP)
 216 eqlP = Eql <$> ("eql " *> registerP) <*> (" " *> argumentP)
 217
 218 registerP, wP, xP, yP, zP :: Parser Register
 219 registerP = choice [wP, xP, yP, zP]
 220 wP = "w" *> pure W
 221 xP = "x" *> pure X
 222 yP = "y" *> pure Y
 223 zP = "z" *> pure Z
 224
 225 argumentP :: Parser Argument
 226 argumentP = (Reg <$> registerP) <|> (Lit <$> signed decimal)
 227
 228 successfulParse :: Text -> [Instruction]
 229 successfulParse input =
 230   case parseOnly instructionsP input of
 231     Left  _err -> [] -- TIO.putStr $ T.pack $ parseErrorPretty err
 232     Right instrs -> instrs