--- /dev/null
+-- Writeup at https://work.njae.me.uk/2021/12/29/advent-of-code-2021-day-24/
+-- Based on ideas by Daniel Lin,
+-- taken from https://github.com/ephemient/aoc2021/blob/main/hs/src/Day24.hs
+
+import Debug.Trace
+
+import Data.Text (Text)
+import qualified Data.Text.IO as TIO
+import Data.Attoparsec.Text -- hiding (take, takeWhile)
+import Control.Applicative
+import qualified Data.Map as M
+import Data.Map ((!))
+import Data.List
+import Control.Monad
+import Data.Maybe
+
+data Register = W | X | Y | Z deriving (Eq, Ord, Show, Enum)
+
+data Interval = Interval Integer Integer
+ deriving (Eq, Ord, Show)
+
+data Argument = Reg Register | Lit Integer
+ deriving (Eq, Ord, Show)
+
+data Instruction
+ = Inp Register
+ | Add Register Argument
+ | Mul Register Argument
+ | Div Register Argument
+ | Mod Register Argument
+ | Eql Register Argument
+ deriving (Eq, Ord, Show)
+
+type LiteralMachine = M.Map Register Integer
+type IntervalMachine = M.Map Register (Maybe Interval)
+
+data CodeMachine = CodeMachine
+ { mCode :: [Integer]
+ , mMachine :: LiteralMachine
+ } deriving (Show)
+
+-- Main
+
+main :: IO ()
+main =
+ do text <- TIO.readFile "data/advent24.txt"
+ let instrs = successfulParse text
+ let m0 = CodeMachine {mCode = [], mMachine = emptyMachine}
+ putStrLn $ part1 m0 instrs
+ putStrLn $ part2 m0 instrs
+
+part1 :: CodeMachine -> [Instruction] -> String
+part1 = findCode [9, 8..1]
+
+part2 :: CodeMachine -> [Instruction] -> String
+part2 = findCode [1..9]
+
+findCode :: [Integer] -> CodeMachine -> [Instruction] -> String
+findCode digits machine instrs = concatMap show $ mCode $ head $ runLit instrs digits machine
+
+plausible :: [Instruction] -> LiteralMachine -> Bool
+plausible instrs litMachine = feasible ranMachine
+ where intMachine = intervalify litMachine
+ ranMachine = runInt instrs intMachine
+
+feasible :: IntervalMachine -> Bool
+-- feasible machine | trace ("Feasible " ++ (show machine)) False = undefined
+feasible machine
+ | (w && x && y && isJust z) = a <= 0 && b >= 0
+ | otherwise = False
+ where w = isJust $ machine ! W
+ x = isJust $ machine ! X
+ y = isJust $ machine ! Y
+ z = machine ! Z
+ Just (Interval a b) = z
+
+valid :: CodeMachine -> Bool
+valid (CodeMachine{..}) = (mMachine ! Z) == 0
+
+
+emptyMachine :: LiteralMachine
+emptyMachine = M.fromList [(r, 0) | r <- [W .. Z]]
+
+intervalify :: LiteralMachine -> IntervalMachine
+intervalify = M.map (\i -> Just (Interval i i))
+
+
+runLit :: [Instruction] -> [Integer] -> CodeMachine -> [CodeMachine]
+-- runLit instrs _digits m0 | trace ((show $ length instrs) ++ " " ++ (show m0)) False = undefined
+runLit [] _ machine = [machine]
+runLit (Inp reg : instrs) digits (CodeMachine {..}) =
+ do -- guard (plausible (Inp reg : instrs) mMachine)
+ i <- digits
+ let m1 = M.insert reg i mMachine
+ guard (plausible instrs m1)
+ mm2 <- runLit instrs digits (CodeMachine { mCode = mCode ++ [i], mMachine = m1})
+ guard (valid mm2)
+ return mm2
+runLit (Add reg arg : instrs) digits (CodeMachine {..}) =
+ runLit instrs digits (CodeMachine{mMachine = M.insert reg c mMachine, ..})
+ where a = mMachine ! reg
+ b = evaluateLit arg mMachine
+ c = a + b
+runLit (Mul reg arg : instrs) digits (CodeMachine {..}) =
+ runLit instrs digits (CodeMachine{mMachine = M.insert reg c mMachine, ..})
+ where a = mMachine ! reg
+ b = evaluateLit arg mMachine
+ c = a * b
+runLit (Div reg arg : instrs) digits (CodeMachine {..}) =
+ runLit instrs digits (CodeMachine{mMachine = M.insert reg c mMachine, ..})
+ where a = mMachine ! reg
+ b = evaluateLit arg mMachine
+ c = a `quot` b
+runLit (Mod reg arg : instrs) digits (CodeMachine {..}) =
+ runLit instrs digits (CodeMachine{mMachine = M.insert reg c mMachine, ..})
+ where a = mMachine ! reg
+ b = evaluateLit arg mMachine
+ c = a `rem` b
+runLit (Eql reg arg : instrs) digits (CodeMachine {..}) =
+ runLit instrs digits (CodeMachine{mMachine = M.insert reg c mMachine, ..})
+ where a = mMachine ! reg
+ b = evaluateLit arg mMachine
+ c = if a == b then 1 else 0
+
+
+runInt :: [Instruction] -> IntervalMachine -> IntervalMachine
+runInt instrs machine = foldl' interpretInt machine instrs
+
+interpretInt :: IntervalMachine -> Instruction -> IntervalMachine
+-- interpretInt machine instr | trace ("iInt " ++ (show instr) ++ " " ++ (show machine)) False = undefined
+interpretInt machine (Inp reg) = M.insert reg (Just (Interval 1 9)) machine
+interpretInt machine (Add reg arg) = M.insert reg c machine
+ where a = machine ! reg
+ b = evaluateInt arg machine
+ c = join $ (+:) <$> a <*> b
+ -- c = join $ (liftM2 (+:)) a b
+interpretInt machine (Mul reg arg) = M.insert reg c machine
+ where a = machine ! reg
+ b = evaluateInt arg machine
+ c = join $ (*:) <$> a <*> b
+interpretInt machine (Div reg arg) = M.insert reg c machine
+ where a = machine ! reg
+ b = evaluateInt arg machine
+ c = join $ (/:) <$> a <*> b
+interpretInt machine (Mod reg arg) = M.insert reg c machine
+ where a = machine ! reg
+ b = evaluateInt arg machine
+ c = join $ (%:) <$> a <*> b
+interpretInt machine (Eql reg arg) = M.insert reg c machine
+ where a = machine ! reg
+ b = evaluateInt arg machine
+ c = join $ (=:) <$> a <*> b
+
+(+:), (*:), (/:), (%:), (=:) :: Interval -> Interval -> Maybe Interval
+(Interval a b) +: (Interval c d) = Just (Interval (a + c) (b + d))
+(Interval a b) *: (Interval c d)
+ | a >= 0 && c >= 0 = Just ( Interval (a * c) (b * d) )
+ | b <= 0 && d <= 0 = Just ( Interval (b * d) (a * c) )
+ | a >= 0 && d <= 0 = Just ( Interval (a * d) (b * c) )
+ | b <= 0 && c >= 0 = Just ( Interval (b * c) (a * d) )
+(Interval a b) /: (Interval c d)
+ | c > 0 = Just ( Interval (a `quot` d) (b `quot` c) )
+ | d < 0 = Just ( Interval (a `quot` c) (b `quot` d) )
+ | otherwise = Nothing
+(Interval _a _b) %: (Interval c d)
+ | c > 0 && c == d = Just ( Interval 0 (c - 1))
+ | c > 0 && c /= d = Just ( Interval 0 (max (c - 1) (d - 1)))
+ | otherwise = Nothing
+(Interval a b) =: (Interval c d)
+ | b < c = Just (Interval 0 0)
+ | a > d = Just (Interval 0 0)
+ | a == b && a == c && a == d = Just (Interval 1 1)
+ | otherwise = Just (Interval 0 1)
+
+evaluateLit :: Argument -> LiteralMachine -> Integer
+evaluateLit (Reg reg) machine = machine ! reg
+evaluateLit (Lit n) _ = n
+
+evaluateInt :: Argument -> IntervalMachine -> Maybe Interval
+evaluateInt (Reg reg) machine = machine ! reg
+evaluateInt (Lit n) _ = Just (Interval n n)
+
+
+-- Parse the input file
+
+instructionsP:: Parser [Instruction]
+instructionsP = instructionP `sepBy` endOfLine
+
+instructionP:: Parser Instruction
+instructionP = choice [inpP, addP, mulP, divP, modP, eqlP]
+
+inpP, addP, mulP, divP, modP, eqlP :: Parser Instruction
+inpP = Inp <$> ("inp " *> registerP)
+addP = Add <$> ("add " *> registerP) <*> (" " *> argumentP)
+mulP = Mul <$> ("mul " *> registerP) <*> (" " *> argumentP)
+divP = Div <$> ("div " *> registerP) <*> (" " *> argumentP)
+modP = Mod <$> ("mod " *> registerP) <*> (" " *> argumentP)
+eqlP = Eql <$> ("eql " *> registerP) <*> (" " *> argumentP)
+
+registerP, wP, xP, yP, zP :: Parser Register
+registerP = choice [wP, xP, yP, zP]
+wP = "w" *> pure W
+xP = "x" *> pure X
+yP = "y" *> pure Y
+zP = "z" *> pure Z
+
+argumentP :: Parser Argument
+argumentP = (Reg <$> registerP) <|> (Lit <$> signed decimal)
+
+successfulParse :: Text -> [Instruction]
+successfulParse input =
+ case parseOnly instructionsP input of
+ Left _err -> [] -- TIO.putStr $ T.pack $ parseErrorPretty err
+ Right instrs -> instrs
projects / advent-of-code-21.git / blobdiff