2024-24 part 2 in haskell and a bit of manual execution

2024/24-Crossed_Wires/second.hs

@@ -0,0 +1,142 @@
+-- requires cabal install --lib megaparsec parser-combinators heap vector
+module Main (main) where
+
+import           Control.Monad        (void, when)
+import           Data.Functor
+import qualified Data.List            as L
+import qualified Data.Map             as M
+import           Data.Maybe
+import           Data.Ord             (comparing)
+import qualified Data.Set             as S
+import           Data.Void            (Void)
+import           Text.Megaparsec
+import           Text.Megaparsec.Char
+
+import           Debug.Trace
+
+type In = (String, Bool)
+data Op = And | Or | Xor deriving (Eq, Ord, Show)
+type Gate = (String, Op, String, String)
+data Input = Input [In] [Gate] deriving Show
+
+type Parser = Parsec Void String
+
+parseIn :: Parser (String, Bool)
+parseIn = (,) <$> some alphaNumChar <* string ": "
+              <*> (char '1' $> True <|> char '0' $> False)
+
+parseOp :: Parser Op
+parseOp = string "AND" $> And
+      <|> string "OR" $> Or
+      <|> string "XOR" $> Xor
+
+parseGate :: Parser Gate
+parseGate = (,,,) <$> some alphaNumChar <* space
+                  <*> parseOp <* space
+                  <*> some alphaNumChar <* string " -> "
+                  <*> some alphaNumChar
+
+parseInput' :: Parser Input
+parseInput' = Input <$> some (parseIn <* eol) <* eol
+                    <*> some (parseGate <* eol) <* eof
+
+parseInput :: String -> IO Input
+parseInput filename = do
+  input <- readFile filename
+  case runParser parseInput' filename input of
+    Left bundle  -> error $ errorBundlePretty bundle
+    Right input' -> return input'
+
+exec And = ( && )
+exec Or  = ( || )
+exec Xor = ( /= )
+
+intToStringPad2 :: Int -> String
+intToStringPad2 i | i < 10 = '0':show i
+                  | otherwise = show i
+
+--type GatesMap = M.Map String (String, Op, String)
+type GatesMap = M.Map (String, Op, String) String
+
+-- The gates could be in the wrong order around the operation
+get :: GatesMap -> (String, Op, String) -> (GatesMap, String)
+get gates g@(a, op, b) = case M.lookup g gates of
+  Just o -> (M.delete g gates, o)
+  Nothing -> let g' = (b, op, a) in case M.lookup g' gates of
+    Just o  -> (M.delete g' gates, o)
+    Nothing -> trace ("gate not found: " ++ show g) undefined
+
+type SignalsMap = M.Map String String
+
+getXYs :: String -> Op -> (GatesMap, SignalsMap) -> (GatesMap, SignalsMap)
+getXYs prefix op acc = L.foldl' getXY acc [0..44]
+  where
+    getXY :: (GatesMap, SignalsMap) -> Int -> (GatesMap, SignalsMap)
+    getXY (gates, signals) i = let is          = intToStringPad2 i
+                                   (gates', s) = get gates ('x':is, op, 'y':is)
+                               in (gates', M.insert (prefix ++ is) s signals)
+
+getSmbs :: (GatesMap, SignalsMap) -> (GatesMap, SignalsMap)
+getSmbs = getXYs "smb" Xor
+
+getCarryBit0s :: (GatesMap, SignalsMap) -> (GatesMap, SignalsMap)
+getCarryBit0s = getXYs "cb0" And
+
+solve :: (GatesMap, SignalsMap) -> (GatesMap, SignalsMap)
+solve acc = L.foldl' solveOne acc [1..44]
+  where
+    solveOne :: (GatesMap, SignalsMap) -> Int -> (GatesMap, SignalsMap)
+    solveOne (gates, signals) i = let is = intToStringPad2 i
+                                      js = intToStringPad2 $ i - 1
+                                      cbp = signals M.! ("cb" ++ js)
+                                      smb = signals M.! ("smb" ++ is)
+                                      cb0 = signals M.! ("cb0" ++ is)
+                                      (gates', cb1) = get gates (cbp, And, smb)
+                                      signals' = M.insert ("cb1" ++ is) cb1 signals
+                                      (gates'', cbn) = get gates' (cb1, Or, cb0)
+                                      signals'' = M.insert ("cb" ++ is) cbn signals'
+                                  in (gates'', signals'')
+
+swapSignals :: [Gate] -> String -> String -> [Gate]
+swapSignals gates x y = let gm = M.fromList $ map (\(a, op, b, out) -> (out, (a, op, b))) gates
+                            xo = gm M.! x
+                            yo = gm M.! y
+                            gm' = M.insert x yo $ M.insert y xo gm
+                        in map (\(out, (a, op, b)) -> (a, op, b, out)) $ M.toList gm'
+
+-- I build the adder from the available gates, following the structure in the
+-- svg file along this code. The swapSignals arguments have been determined by
+-- rerunning manually this program 4 times.
+--
+-- When I got a 'gate not found: ("z11",Or,"dpf")' error, I ran:
+-- ```
+-- grep z11 input                                                                                          (base)
+-- gkc AND qqw -> z11
+-- ```
+-- followed by
+-- ```
+-- grep dpf input                                                                                             (base)
+-- wpd OR dpf -> dtq
+-- y11 AND x11 -> dpf
+-- ```
+--
+-- The only OR operation is the oen between wpd and dpf, with dpf as a common
+-- signal. The two signals to swap are therefore z11 and wpd which I add bellow.
+-- Rince and repeat until all four swaps are identified.
+compute :: Input -> String
+compute (Input _ gates) = trace (show $ gs''') $ L.intercalate "," $ L.sort ["z11", "wpd", "skh", "jqf", "z19", "mdd", "z37", "wts"]
+  where
+    gates' = swapSignals gates "z11" "wpd"
+    gates'' = swapSignals gates' "skh" "jqf"
+    gates''' = swapSignals gates'' "z19" "mdd"
+    gates'''' = swapSignals gates''' "z37" "wts"
+    gatesMap = M.fromList $ map (\(a, op, b, out) -> ((a, op, b), out)) gates''''
+    (gm, gs) = getSmbs (gatesMap, M.empty)
+    (gm', gs') = getCarryBit0s (gm, gs)
+    gs'' = M.insert "cb00" (gs' M.! "cb000") gs'
+    (gm'', gs''') = solve (gm', gs'')
+
+main :: IO ()
+main = do
+  input <- parseInput "input"
+  print $ compute input