Day 21

Y2022.cabal

@@ -55,6 +55,7 @@ library
         Days.D18
         Days.D19
         Days.D20
+        Days.D21
     build-depends:
         bytestring
       , either

app/Main.hs

@@ -28,6 +28,7 @@ paths =
     , "./data/18.in"
     , "./data/19.in"
     , "./data/20.in"
+    , "./data/21.in"
     ]
 
 solutions :: [(Int, Day, FilePath)]

bench/Bench.hs

@@ -27,6 +27,7 @@ paths =
     , "./data/18.in"
     , "./data/19.in"
     , "./data/20.in"
+    , "./data/21.in"
     ]
 
 solutions :: [(Integer, [Day], FilePath)]

src/Days/D21.hs

@@ -0,0 +1,117 @@
+{-# LANGUAGE ImportQualifiedPost #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Days.D21 where
+
+import Common
+import Data.Char (isAlpha)
+import Data.Functor ((<&>))
+import Data.Map (Map)
+import Data.Map qualified as Map
+import Data.Maybe (fromJust)
+import Data.Text (Text)
+import Parse
+import Text.Megaparsec (oneOf, takeWhile1P, (<|>))
+import Text.Megaparsec.Char (space, string)
+import Text.Megaparsec.Char.Lexer qualified as Lexer
+
+type Name = Text
+
+data Op = Add | Sub | Mul | Div
+  deriving (Show)
+
+data Operand = Ref Name | Val Integer
+  deriving (Show)
+
+data Operation = Binary Operand Op Operand | Constant Integer
+  deriving (Show)
+
+parser :: Parser [(Name, Operation)]
+parser = someLines monkey
+  where
+    lexeme = Lexer.lexeme space
+
+    name = takeWhile1P Nothing isAlpha
+
+    operation = binary <|> constant
+    binary = Binary <$> (Ref <$> lexeme name) <*> lexeme op <*> (Ref <$> name)
+    op =
+      oneOf ['+', '-', '*', '/']
+        <&> \case
+          '+' -> Add
+          '-' -> Sub
+          '*' -> Mul
+          '/' -> Div
+          _ -> error "Invalid operation"
+
+    constant = Constant . toInteger <$> int
+
+    monkey = (,) <$> name <* string ": " <*> operation
+
+toFun :: (Integral a) => Op -> (a -> a -> a)
+toFun Add = (+)
+toFun Sub = (-)
+toFun Mul = (*)
+toFun Div = div
+
+force :: Map Name Operation -> Operand -> (Operand, Map Name Operation)
+force context (Val c) = (Val c, context)
+force context (Ref ident) =
+  case Map.lookup ident context of
+    Nothing -> (Ref ident, context)
+    Just (Constant c) -> (Val c, context)
+    Just (Binary left op right) ->
+      let (leftForced, context') = force context left
+          (rightForced, context'') = force context' right
+       in case (leftForced, rightForced) of
+            (Val l, Val r) ->
+              let v = toFun op l r
+               in (Val v, Map.insert ident (Constant v) context'')
+            _ ->
+              ( Ref ident,
+                Map.insert ident (Binary leftForced op rightForced) context''
+              )
+
+unwrapVal :: Operand -> Integer
+unwrapVal (Val c) = c
+unwrapVal _ = error "Can't unwrap Ref"
+
+inverse :: Operation -> Integer -> (Name, Integer)
+inverse (Binary (Val c) Add (Ref i)) target = (i, target - c)
+inverse (Binary (Ref i) Add (Val c)) target = (i, target - c)
+inverse (Binary (Val c) Mul (Ref i)) target = (i, target `div` c)
+inverse (Binary (Ref i) Mul (Val c)) target = (i, target `div` c)
+inverse (Binary (Val c) Sub (Ref i)) target = (i, c - target)
+inverse (Binary (Ref i) Sub (Val c)) target = (i, c + target)
+inverse (Binary (Val c) Div (Ref i)) target = (i, c `div` target)
+inverse (Binary (Ref i) Div (Val c)) target = (i, c * target)
+inverse _ _ = error "Can not invert"
+
+coerce :: Map Name Operation -> Name -> Integer -> Maybe Integer
+coerce context name target =
+  case Map.lookup name context of
+    Nothing -> Just target
+    Just (Constant _) -> Nothing
+    Just binOp ->
+      uncurry (coerce context) (inverse binOp target)
+
+part1 :: [(Name, Operation)] -> Integer
+part1 shouts =
+  let context = Map.fromList shouts
+   in unwrapVal . fst $ force context (Ref "root")
+
+part2 :: [(Name, Operation)] -> Integer
+part2 shouts =
+  let context = Map.fromList $ filter ((/= "humn") . fst) shouts
+      (_, forcedContext) = force context (Ref "root")
+   in fromJust $
+        case Map.lookup "root" forcedContext of
+          Just (Binary (Val c) _ (Ref right)) ->
+            coerce forcedContext right c
+          Just (Binary (Ref left) _ (Val c)) ->
+            coerce forcedContext left c
+          _ -> Nothing
+
+day :: Day
+day = parsecDay parser (definitive . part1, definitive . part2)

src/Lib.hs

@@ -32,6 +32,7 @@ import Days.D17 qualified as D17
 import Days.D18 qualified as D18
 import Days.D19 qualified as D19
 import Days.D20 qualified as D20
+import Days.D21 qualified as D21
 
 import Data.ByteString.Char8 qualified as BS
 import Data.Text.IO qualified as T
@@ -64,4 +65,5 @@ days =
     , [D18.day]
     , [D19.day]
     , [D20.day]
+    , [D21.day]
     ]

src/Print.hs

@@ -4,14 +4,14 @@ import Common
 import Text.Printf (printf)
 
 printHeader :: IO ()
-printHeader = putStrLn "[ Day ]------(1)-----+-------(2)------"
+printHeader = putStrLn "[ Day ]-------(1)------+-------(2)------"
 
 printFooter :: IO ()
-printFooter = putStrLn "[-----]--------------+----------------"
+printFooter = putStrLn "[-----]----------------+----------------"
 
 printDR :: Int -> DayResult -> IO ()
 printDR day (Left errorString) = printf "[  %2d ] ====== PARSER ERROR =======\n%s" day errorString
 printDR day (Right (sol1, sol2)) =
     let r1 = maybe "unsolved" show sol1
         r2 = maybe "unsolved" show sol2
-     in printf "[  %2d ] %12s | %14s\n" day r1 r2
+     in printf "[  %2d ] %14s | %14s\n" day r1 r2