advent24/MainDelay.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 as M
  12 import Data.Map ((!))
  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 LiteralMachine = M.Map Register Integer
  35 type IntervalMachine = M.Map Register (Maybe Interval)
  36
  37 data CodeMachine = CodeMachine
  38   { mCode :: [Integer]
  39   , mMachine :: LiteralMachine
  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 = CodeMachine {mCode = [], mMachine = emptyMachine}
  49       putStrLn $ part1 m0 instrs
  50       putStrLn $ part2 m0 instrs
  51
  52 part1 :: CodeMachine -> [Instruction] -> String
  53 part1 = findCode [9, 8..1]
  54
  55 part2 :: CodeMachine -> [Instruction] -> String
  56 part2 = findCode [1..9]
  57
  58 findCode :: [Integer] -> CodeMachine -> [Instruction] -> String
  59 findCode digits machine instrs = concatMap show $ mCode $ head $ runLit instrs digits machine
  60
  61 plausible :: [Instruction] -> LiteralMachine -> Bool
  62 plausible instrs litMachine = feasible ranMachine
  63   where intMachine = intervalify litMachine
  64         ranMachine = runInt instrs intMachine
  65
  66 feasible :: IntervalMachine -> Bool
  67 -- feasible machine | trace ("Feasible " ++ (show machine)) False = undefined
  68 feasible machine
  69   | (w && x && y && isJust z) = a <= 0 && b >= 0
  70   | otherwise = False
  71   where w = isJust $ machine ! W
  72         x = isJust $ machine ! X
  73         y = isJust $ machine ! Y
  74         z = machine ! Z
  75         Just (Interval a b) = z
  76
  77 valid :: CodeMachine -> Bool
  78 valid (CodeMachine{..}) = (mMachine ! Z) == 0
  79
  80
  81 emptyMachine :: LiteralMachine
  82 emptyMachine = M.fromList [(r, 0) | r <- [W .. Z]]
  83
  84 intervalify :: LiteralMachine -> IntervalMachine
  85 intervalify = M.map (\i -> Just (Interval i i))
  86
  87
  88 runLit :: [Instruction] -> [Integer] -> CodeMachine -> [CodeMachine]
  89 -- runLit instrs _digits m0 | trace ((show $ length instrs) ++ " " ++ (show m0)) False = undefined
  90 runLit [] _ machine = [machine]
  91 runLit (Inp reg : instrs) digits (CodeMachine {..}) =
  92   do -- guard (plausible (Inp reg : instrs) mMachine)
  93      i <- digits
  94      let m1 = M.insert reg i mMachine
  95      guard (plausible instrs m1)
  96      mm2 <- runLit instrs digits (CodeMachine { mCode = mCode ++ [i], mMachine = m1})
  97      guard (valid mm2)
  98      return mm2
  99 runLit (Add reg arg : instrs) digits (CodeMachine {..}) =
 100   runLit instrs digits (CodeMachine{mMachine = M.insert reg c mMachine, ..})
 101   where a = mMachine ! reg
 102         b = evaluateLit arg mMachine
 103         c = a + b
 104 runLit (Mul reg arg : instrs) digits (CodeMachine {..}) =
 105   runLit instrs digits (CodeMachine{mMachine = M.insert reg c mMachine, ..})
 106   where a = mMachine ! reg
 107         b = evaluateLit arg mMachine
 108         c = a * b
 109 runLit (Div reg arg : instrs) digits (CodeMachine {..}) =
 110   runLit instrs digits (CodeMachine{mMachine = M.insert reg c mMachine, ..})
 111   where a = mMachine ! reg
 112         b = evaluateLit arg mMachine
 113         c = a `quot` b
 114 runLit (Mod reg arg : instrs) digits (CodeMachine {..}) =
 115   runLit instrs digits (CodeMachine{mMachine = M.insert reg c mMachine, ..})
 116   where a = mMachine ! reg
 117         b = evaluateLit arg mMachine
 118         c = a `rem` b
 119 runLit (Eql reg arg : instrs) digits (CodeMachine {..}) =
 120   runLit instrs digits (CodeMachine{mMachine = M.insert reg c mMachine, ..})
 121   where a = mMachine ! reg
 122         b = evaluateLit arg mMachine
 123         c = if a == b then 1 else 0
 124
 125
 126 runInt :: [Instruction] -> IntervalMachine -> IntervalMachine
 127 runInt instrs machine = foldl' interpretInt machine instrs
 128
 129 interpretInt :: IntervalMachine -> Instruction -> IntervalMachine
 130 -- interpretInt machine instr | trace ("iInt " ++ (show instr) ++ " " ++  (show machine)) False = undefined
 131 interpretInt machine (Inp reg) = M.insert reg (Just (Interval 1 9)) machine
 132 interpretInt machine (Add reg arg) = M.insert reg c machine
 133   where a = machine ! reg
 134         b = evaluateInt arg machine
 135         c = join $ (+:) <$> a <*> b
 136         -- c = join $ (liftM2 (+:)) a b
 137 interpretInt machine (Mul reg arg) = M.insert reg c machine
 138   where a = machine ! reg
 139         b = evaluateInt arg machine
 140         c = join $ (*:) <$> a <*> b
 141 interpretInt machine (Div reg arg) = M.insert reg c machine
 142   where a = machine ! reg
 143         b = evaluateInt arg machine
 144         c = join $ (/:) <$> a <*> b
 145 interpretInt machine (Mod reg arg) = M.insert reg c machine
 146   where a = machine ! reg
 147         b = evaluateInt arg machine
 148         c = join $ (%:) <$> a <*> b
 149 interpretInt machine (Eql reg arg) = M.insert reg c machine
 150   where a = machine ! reg
 151         b = evaluateInt arg machine
 152         c = join $ (=:) <$> a <*> b
 153
 154 (+:), (*:), (/:), (%:), (=:) :: Interval -> Interval -> Maybe Interval
 155 (Interval a b) +: (Interval c d) = Just (Interval (a + c) (b + d))
 156 (Interval a b) *: (Interval c d)
 157   | a >= 0 && c >= 0 = Just ( Interval (a * c) (b * d) )
 158   | b <= 0 && d <= 0 = Just ( Interval (b * d) (a * c) )
 159   | a >= 0 && d <= 0 = Just ( Interval (a * d) (b * c) )
 160   | b <= 0 && c >= 0 = Just ( Interval (b * c) (a * d) )
 161 (Interval a b) /: (Interval c d)
 162   | c > 0 = Just ( Interval (a `quot` d) (b `quot` c) )
 163   | d < 0 = Just ( Interval (a `quot` c) (b `quot` d) )
 164   | otherwise = Nothing
 165 (Interval _a _b) %: (Interval c d)
 166   | c > 0 && c == d = Just ( Interval 0 (c - 1))
 167   | c > 0 && c /= d = Just ( Interval 0 (max (c - 1) (d - 1)))
 168   | otherwise = Nothing
 169 (Interval a b) =: (Interval c d)
 170   | b < c = Just (Interval 0 0)
 171   | a > d = Just (Interval 0 0)
 172   | a == b && a == c && a == d = Just (Interval 1 1)
 173   | otherwise = Just (Interval 0 1)
 174
 175 evaluateLit :: Argument -> LiteralMachine -> Integer
 176 evaluateLit (Reg reg) machine =  machine ! reg
 177 evaluateLit (Lit n) _ = n
 178
 179 evaluateInt :: Argument -> IntervalMachine -> Maybe Interval
 180 evaluateInt (Reg reg) machine =  machine ! reg
 181 evaluateInt (Lit n) _ = Just (Interval n n)
 182
 183
 184 -- Parse the input file
 185
 186 instructionsP:: Parser [Instruction]
 187 instructionsP = instructionP `sepBy` endOfLine
 188
 189 instructionP:: Parser Instruction
 190 instructionP = choice [inpP, addP, mulP, divP, modP, eqlP]
 191
 192 inpP, addP, mulP, divP, modP, eqlP :: Parser Instruction
 193 inpP = Inp <$> ("inp " *> registerP)
 194 addP = Add <$> ("add " *> registerP) <*> (" " *> argumentP)
 195 mulP = Mul <$> ("mul " *> registerP) <*> (" " *> argumentP)
 196 divP = Div <$> ("div " *> registerP) <*> (" " *> argumentP)
 197 modP = Mod <$> ("mod " *> registerP) <*> (" " *> argumentP)
 198 eqlP = Eql <$> ("eql " *> registerP) <*> (" " *> argumentP)
 199
 200 registerP, wP, xP, yP, zP :: Parser Register
 201 registerP = choice [wP, xP, yP, zP]
 202 wP = "w" *> pure W
 203 xP = "x" *> pure X
 204 yP = "y" *> pure Y
 205 zP = "z" *> pure Z
 206
 207 argumentP :: Parser Argument
 208 argumentP = (Reg <$> registerP) <|> (Lit <$> signed decimal)
 209
 210 successfulParse :: Text -> [Instruction]
 211 successfulParse input =
 212   case parseOnly instructionsP input of
 213     Left  _err -> [] -- TIO.putStr $ T.pack $ parseErrorPretty err
 214     Right instrs -> instrs