From 1b58223225780b57def23d6fd72b998622962319 Mon Sep 17 00:00:00 2001 From: Neil Smith Date: Wed, 8 Jan 2025 13:20:37 +0000 Subject: [PATCH] Rebuilt soluion to day 24 --- advent24/Main.hs | 215 +++++++----------- advent24/MainOriginal.hs | 246 ++++++++++++++++++++ advent24/MainWithInvestigations.hs | 345 +++++++++++++++++++++++++++++ advent24/notes.hs | 5 + adventofcode24.cabal | 8 + 5 files changed, 684 insertions(+), 135 deletions(-) create mode 100644 advent24/MainOriginal.hs create mode 100644 advent24/MainWithInvestigations.hs diff --git a/advent24/Main.hs b/advent24/Main.hs index ab75a2e..bf0bff3 100644 --- a/advent24/Main.hs +++ b/advent24/Main.hs @@ -7,16 +7,19 @@ import qualified Data.Text.IO as TIO import Data.Attoparsec.Text hiding (take) import Control.Applicative import qualified Data.Map.Strict as M -import qualified Data.Set as S import Data.List -import Data.Bits (xor, (.&.), (.|.), (.<<.), bit, testBit) +import Data.Bits (xor, (.&.), (.|.), (.<<.), testBit) import Data.Tree import Data.Maybe import Data.Char +import Control.Monad (foldM) + +-- import Debug.Trace + type Wires = M.Map String Int -data GateType = And | Or | Xor +data GateType = And | Or | Xor | Carry | Output deriving (Show, Eq, Ord) data Gate = Gate { gType :: GateType, inputs :: [String], output :: String } @@ -36,34 +39,19 @@ main = -- print $ simulate wires device -- print $ wiresOutput $ simulate wires device print $ part1 wires device - putStrLn part2 - -rd :: IO (Wires, Device) -rd = do - text <- TIO.readFile "../data/advent24.txt" - return $ successfulParse text - -rdn :: IO Device -rdn = do - text <- TIO.readFile "../data/advent24.txt" - let (_, device) = successfulParse text - let r1 = swapWires "vss" "z14" device - let r2 = swapWires "kdh" "hjf" r1 - let r3 = swapWires "z31" "kpp" r2 - let r4 = swapWires "z35" "sgj" r3 - return $ renamings r4 - + putStrLn $ part2 device part1 :: Wires -> Device -> Int part1 wires device = wiresOutput $ simulate wires device -part2 :: String -part2 = intercalate "," $ sort ["vss", "z14", "kdh", "hjf", "z31", "kpp", "z35", "sgj"] +part2 :: Device -> String +part2 device = intercalate "," $ sort $ concatMap (\(a, b) -> [a, b]) swaps + where swaps = repairAdder device 3 [] simulate :: Wires -> Device -> Wires simulate wires device = wires' - where (wires', []) = until (null . snd) simulateOnce (wires, device) + where (wires', _) = until (null . snd) simulateOnce (wires, device) simulateOnce :: (Wires, Device) -> (Wires, Device) simulateOnce (wires, device) = (wires', remaining) @@ -81,6 +69,8 @@ simulateGate wires gate = M.insert gate.output result wires And -> (wires M.! i1) .&. (wires M.! i2) Or -> (wires M.! i1) .|. (wires M.! i2) Xor -> (wires M.! i1) `xor` (wires M.! i2) + Carry -> error "Carry not implemented" + Output -> error "Output not implemented" isOutputWire :: String -> Bool isOutputWire (x:_) = x == 'z' @@ -88,76 +78,61 @@ isOutputWire (x:_) = x == 'z' wiresOutput :: Wires -> Int wiresOutput wires = M.foldlWithKey' go 0 outWires where outWires = M.filterWithKey (\k _ -> isOutputWire k) wires - -- outShift w = read $ drop 1 w - -- go acc w v = acc .|. (v .<<. outShift w) go acc w v = acc .|. (v .<<. codeOfName w) -unfoldFromWire :: Device -> String -> DeviceTree -unfoldFromWire device wire = - unfoldTree unfoldDevice (device, fromJust $ gateForWire device wire) - -unfoldDevice :: (Device, Gate) -> (Gate, [(Device, Gate)]) -unfoldDevice (device, gate) = - ( gate - , fmap (\g -> (device, g)) feedGates - ) - where feedGates = sort $ catMaybes $ fmap (gateForWire device) gate.inputs - - -showFragment :: DeviceTree -> IO () -showFragment t = putStrLn $ unlines $ take 15 $ lines $ drawTree $ fmap show t - -gateForWire :: Device -> String -> Maybe Gate -gateForWire device wire = find ((== wire) . output) device - -setInputs :: Int -> Int -> Wires -setInputs x y = M.union (bitsOf "x" x) (bitsOf "y" y) - -bitsOf :: String -> Int -> Wires -bitsOf p n = M.fromList [(p ++ (show2d i), testBitI n i) | i <- [0..44]] - -testBitI n i - | testBit n i = 1 - | otherwise = 0 - show2d :: Int -> String show2d n | length (show n) == 1 = "0" ++ (show n) | otherwise = show n -equivalentTree :: DeviceTree -> DeviceTree -> Bool -equivalentTree (Node (Gate g1 i1 _) []) (Node (Gate g2 i2 _) []) = - g1 == g2 && i1 == i2 -equivalentTree (Node (Gate g1 _ _) sub1@(_:_)) - (Node (Gate g2 _ _) sub2@(_:_)) = - g1 == g2 && ( (all (uncurry equivalentTree) $ zip sub1 sub2) - || (all (uncurry equivalentTree) $ zip sub1 (reverse sub2)) - ) -equivalentTree _ _ = False - - -makeAdder :: Int -> String -> Int -> DeviceTree -makeAdder 0 o _ = Node {rootLabel = Gate {gType = Xor, inputs = ["x00","y00"], output = o}, subForest = []} -makeAdder depth o n = Node {rootLabel = Gate {gType = Xor, inputs = [n0, n1], output = o}, subForest = [gAdd, gCarry]} - where gAdd = Node {rootLabel = Gate {gType = Xor, inputs = ["x" ++ show2d depth,"y" ++ show2d depth], output = n0}, subForest = []} - gCarry = makeCarry (depth-1) n1 (n + 2) - n0 = nonceStr n - n1 = nonceStr (n+1) - -makeCarry :: Int -> String -> Int -> DeviceTree -makeCarry 0 o _ = Node {rootLabel = Gate {gType = And, inputs = ["x00","y00"], output = o}, subForest = []} -makeCarry depth o n = Node {rootLabel = Gate {gType = Or, inputs = [n0, n1], output = o}, subForest = [c0, c1]} - where c0 = Node {rootLabel = Gate {gType = And, inputs = [n2, n3], output = n0}, subForest = [c2, c3]} - c1 = Node {rootLabel = Gate {gType = And, inputs = ["x" ++ show2d depth,"y" ++ show2d depth], output = n1}, subForest = []} - c2 = makeCarry (depth-1) n2 (n + 4) - c3 = Node {rootLabel = Gate {gType = Xor, inputs = ["x" ++ show2d depth,"y" ++ show2d depth], output = n3}, subForest = []} - n0 = nonceStr n - n1 = nonceStr (n+1) - n2 = nonceStr (n+2) - n3 = nonceStr (n+3) - -nonceStr :: Int -> String -nonceStr n = "n" ++ show n +repairAdder :: Device -> Int -> [(String, String)] -> [(String, String)] +-- repairAdder device n acc | traceShow ("repair", n, acc) False = undefined +repairAdder _device 44 acc = acc +repairAdder device n acc = + case adder of + Left (o1, o2) -> repairAdder (swapWires o1 o2 device) n ((o1, o2) : acc) + Right _ -> repairAdder device (n + 1) acc + where d1 = replaceCarry (n - 1) device + adder = growFromCarry n d1 + +growFromCarry :: Int -> Device -> Either (String, String) DeviceTree +growFromCarry n device = + do let c = Node {rootLabel = fromJust $ find ((== Carry) . gType) device, subForest = []} + let x0 = "x" ++ show2d (n - 1) + let y0 = "y" ++ show2d (n - 1) + let x1 = "x" ++ show2d n + let y1 = "y" ++ show2d n + let z1 = "z" ++ show2d n + let spineGates = [ (And, (Gate Xor [x0, y0] "")) + , (Or, (Gate And [x0, y0] "")) + , (Xor, (Gate Xor [x1, y1] "")) + ] + grown <- foldM (growSpine device) c spineGates + let grownOut = grown.rootLabel.output + if grownOut == z1 then Right grown else Left (grownOut, z1) + +-- the left is a swap +growSpine :: Device -> DeviceTree -> (GateType, Gate) -> Either (String, String) DeviceTree +-- growSpine device spine (spineType, leafGate) | traceShow ("spine", spine, spineType, leafGate) False = undefined +growSpine device + spine + ( spineType -- next spine template + , (Gate leafType leafInput _) -- next leaf template + ) + | null spineParents = Left (spineOut, otherParentInput) + | null nextLeafParents = Left (nextLeaf.output, otherParentInput) + | not $ null commonSpineCandidates = Right (Node {rootLabel = head commonSpineCandidates, subForest = [nextLeafTree, spine]}) + | otherwise = Left ("", "") + where + spineParents = filter (\g -> g.gType == spineType && spineOut `elem` g.inputs) device + nextLeaf = head $ filter (\g -> g.gType == leafType && leafInput == g.inputs) device + nextLeafParents = filter (\g -> g.gType == spineType && nextLeaf.output `elem` g.inputs) device + nextLeafTree = Node {rootLabel = nextLeaf, subForest = []} + commonSpineCandidates = spineParents `intersect` nextLeafParents + spineOut = spine.rootLabel.output + otherParentInput = if null spineParents + then head $ delete nextLeaf.output (inputs $ head nextLeafParents) + else head $ delete spineOut (inputs $ head spineParents) codeOfName :: String -> Int codeOfName s -- = read . filter isDigit @@ -165,56 +140,26 @@ codeOfName s -- = read . filter isDigit | otherwise = read ds where ds = filter isDigit s +replaceCarry :: Int -> Device -> Device +replaceCarry n device = (Gate Carry [] carryGate.output) : filter (/= carryGate) device + where outWire = "z" ++ show2d n + outGate = head $ filter ((== outWire) . output) device + carryGate = head $ filter (\g -> (g.output `elem` outGate.inputs) && g.gType == Or) device + + +-- swapWires :: String -> String -> Device -> Device +-- swapWires w1 w2 = renameOutput "swap" w2 . renameOutput w2 w1 . renameOutput w1 "swap" +-- where renameOutput from to = fmap rename +-- where rename (Gate g i o) = Gate g i (renameName o) +-- renameName n | n == from = to +-- | otherwise = n swapWires :: String -> String -> Device -> Device -swapWires w1 w2 = renameOutput "swap" w2 . renameOutput w2 w1 . renameOutput w1 "swap" - where renameOutput from to = fmap rename - where rename (Gate g i o) = Gate g i (renameName o) - renameName n | n == from = to - | otherwise = n - -renameWire :: String -> String -> Device -> Device -renameWire from to = fmap rename - where rename (Gate g i o) = Gate g (fmap renameName i) (renameName o) - renameName n | n == from = to - | otherwise = n - -existingOutput :: GateType -> String -> String -> Device -> Maybe String -existingOutput gType i1 i2 device - | null gates = Nothing - | otherwise = Just $ output $ head gates - where - f (Gate g i _o) = g == gType && i1 `elem` i && i2 `elem` i - gates = filter f device - -renameAll :: GateType -> String -> String -> String -> Device -> Device -renameAll gType i1 i2 newO device = - case mo of - Nothing -> device - Just o -> renameWire o newO device - where mo = existingOutput gType i1 i2 device - -renameAllN :: GateType -> String -> String -> String -> Int -> Device -> Device -renameAllN gType p1 p2 po n device = renameAll gType i1 i2 pn device - where i1 = p1 ++ show2d n - i2 = p2 ++ show2d n - pn = po ++ show2d n - -renameCarryI :: Int -> Device -> Device -renameCarryI n device = renameAll And ("xor" ++ show2d n) ("carry" ++ show2d (n-1)) ("int_carry" ++ show2d n) device - -renameCarry :: Device -> Int -> Device -renameCarry device n = d2 - where d1 = renameCarryI n device - d2 = renameAll Or ("int_carry" ++ show2d n) ("and" ++ show2d n) ("carry" ++ show2d n) d1 - -renamings :: Device -> Device -renamings device = d5 - where - d1 = foldr (renameAllN Xor "x" "y" "xor") device [0..44] - d2 = foldr (renameAllN And "x" "y" "and") d1 [0..44] - d3 = foldr (renameAllN Or "x" "y" "or") d2 [0..44] - d4 = renameWire "and00" "carry00" d3 - d5 = foldl renameCarry d4 [1..44] +swapWires w1 w2 = + renameOutput "swap" w2 . renameOutput w2 w1 . renameOutput w1 "swap" + where renameOutput from to = fmap (rename from to) + rename from to (Gate g i o) + | o == from = Gate g i to + | otherwise = Gate g i o -- parse the input file diff --git a/advent24/MainOriginal.hs b/advent24/MainOriginal.hs new file mode 100644 index 0000000..ab75a2e --- /dev/null +++ b/advent24/MainOriginal.hs @@ -0,0 +1,246 @@ +-- Writeup at https://work.njae.me.uk/2024/12/29/advent-of-code-2024-day-24/ + +import AoC + +import Data.Text (Text) +import qualified Data.Text.IO as TIO +import Data.Attoparsec.Text hiding (take) +import Control.Applicative +import qualified Data.Map.Strict as M +import qualified Data.Set as S +import Data.List +import Data.Bits (xor, (.&.), (.|.), (.<<.), bit, testBit) +import Data.Tree +import Data.Maybe +import Data.Char + +type Wires = M.Map String Int + +data GateType = And | Or | Xor + deriving (Show, Eq, Ord) + +data Gate = Gate { gType :: GateType, inputs :: [String], output :: String } + deriving (Show, Eq, Ord) + +type Device = [Gate] + +type DeviceTree = Tree Gate + +main :: IO () +main = + do dataFileName <- getDataFileName + text <- TIO.readFile dataFileName + let (wires, device) = successfulParse text + -- print wires + -- print device + -- print $ simulate wires device + -- print $ wiresOutput $ simulate wires device + print $ part1 wires device + putStrLn part2 + +rd :: IO (Wires, Device) +rd = do + text <- TIO.readFile "../data/advent24.txt" + return $ successfulParse text + +rdn :: IO Device +rdn = do + text <- TIO.readFile "../data/advent24.txt" + let (_, device) = successfulParse text + let r1 = swapWires "vss" "z14" device + let r2 = swapWires "kdh" "hjf" r1 + let r3 = swapWires "z31" "kpp" r2 + let r4 = swapWires "z35" "sgj" r3 + return $ renamings r4 + + +part1 :: Wires -> Device -> Int +part1 wires device = wiresOutput $ simulate wires device + +part2 :: String +part2 = intercalate "," $ sort ["vss", "z14", "kdh", "hjf", "z31", "kpp", "z35", "sgj"] + + +simulate :: Wires -> Device -> Wires +simulate wires device = wires' + where (wires', []) = until (null . snd) simulateOnce (wires, device) + +simulateOnce :: (Wires, Device) -> (Wires, Device) +simulateOnce (wires, device) = (wires', remaining) + where + (run, remaining) = partition (canActivateGate wires) device + wires' = foldl simulateGate wires run + +canActivateGate :: Wires -> Gate -> Bool +canActivateGate wires gate = all (`M.member` wires) gate.inputs + +simulateGate :: Wires -> Gate -> Wires +simulateGate wires gate = M.insert gate.output result wires + where [i1, i2] = gate.inputs + result = case gate.gType of + And -> (wires M.! i1) .&. (wires M.! i2) + Or -> (wires M.! i1) .|. (wires M.! i2) + Xor -> (wires M.! i1) `xor` (wires M.! i2) + +isOutputWire :: String -> Bool +isOutputWire (x:_) = x == 'z' + +wiresOutput :: Wires -> Int +wiresOutput wires = M.foldlWithKey' go 0 outWires + where outWires = M.filterWithKey (\k _ -> isOutputWire k) wires + -- outShift w = read $ drop 1 w + -- go acc w v = acc .|. (v .<<. outShift w) + go acc w v = acc .|. (v .<<. codeOfName w) + +unfoldFromWire :: Device -> String -> DeviceTree +unfoldFromWire device wire = + unfoldTree unfoldDevice (device, fromJust $ gateForWire device wire) + +unfoldDevice :: (Device, Gate) -> (Gate, [(Device, Gate)]) +unfoldDevice (device, gate) = + ( gate + , fmap (\g -> (device, g)) feedGates + ) + where feedGates = sort $ catMaybes $ fmap (gateForWire device) gate.inputs + + +showFragment :: DeviceTree -> IO () +showFragment t = putStrLn $ unlines $ take 15 $ lines $ drawTree $ fmap show t + +gateForWire :: Device -> String -> Maybe Gate +gateForWire device wire = find ((== wire) . output) device + +setInputs :: Int -> Int -> Wires +setInputs x y = M.union (bitsOf "x" x) (bitsOf "y" y) + +bitsOf :: String -> Int -> Wires +bitsOf p n = M.fromList [(p ++ (show2d i), testBitI n i) | i <- [0..44]] + +testBitI n i + | testBit n i = 1 + | otherwise = 0 + +show2d :: Int -> String +show2d n | length (show n) == 1 = "0" ++ (show n) + | otherwise = show n + + +equivalentTree :: DeviceTree -> DeviceTree -> Bool +equivalentTree (Node (Gate g1 i1 _) []) (Node (Gate g2 i2 _) []) = + g1 == g2 && i1 == i2 +equivalentTree (Node (Gate g1 _ _) sub1@(_:_)) + (Node (Gate g2 _ _) sub2@(_:_)) = + g1 == g2 && ( (all (uncurry equivalentTree) $ zip sub1 sub2) + || (all (uncurry equivalentTree) $ zip sub1 (reverse sub2)) + ) +equivalentTree _ _ = False + + +makeAdder :: Int -> String -> Int -> DeviceTree +makeAdder 0 o _ = Node {rootLabel = Gate {gType = Xor, inputs = ["x00","y00"], output = o}, subForest = []} +makeAdder depth o n = Node {rootLabel = Gate {gType = Xor, inputs = [n0, n1], output = o}, subForest = [gAdd, gCarry]} + where gAdd = Node {rootLabel = Gate {gType = Xor, inputs = ["x" ++ show2d depth,"y" ++ show2d depth], output = n0}, subForest = []} + gCarry = makeCarry (depth-1) n1 (n + 2) + n0 = nonceStr n + n1 = nonceStr (n+1) + +makeCarry :: Int -> String -> Int -> DeviceTree +makeCarry 0 o _ = Node {rootLabel = Gate {gType = And, inputs = ["x00","y00"], output = o}, subForest = []} +makeCarry depth o n = Node {rootLabel = Gate {gType = Or, inputs = [n0, n1], output = o}, subForest = [c0, c1]} + where c0 = Node {rootLabel = Gate {gType = And, inputs = [n2, n3], output = n0}, subForest = [c2, c3]} + c1 = Node {rootLabel = Gate {gType = And, inputs = ["x" ++ show2d depth,"y" ++ show2d depth], output = n1}, subForest = []} + c2 = makeCarry (depth-1) n2 (n + 4) + c3 = Node {rootLabel = Gate {gType = Xor, inputs = ["x" ++ show2d depth,"y" ++ show2d depth], output = n3}, subForest = []} + n0 = nonceStr n + n1 = nonceStr (n+1) + n2 = nonceStr (n+2) + n3 = nonceStr (n+3) + +nonceStr :: Int -> String +nonceStr n = "n" ++ show n + +codeOfName :: String -> Int +codeOfName s -- = read . filter isDigit + | null ds = 1000 + | otherwise = read ds + where ds = filter isDigit s + +swapWires :: String -> String -> Device -> Device +swapWires w1 w2 = renameOutput "swap" w2 . renameOutput w2 w1 . renameOutput w1 "swap" + where renameOutput from to = fmap rename + where rename (Gate g i o) = Gate g i (renameName o) + renameName n | n == from = to + | otherwise = n + +renameWire :: String -> String -> Device -> Device +renameWire from to = fmap rename + where rename (Gate g i o) = Gate g (fmap renameName i) (renameName o) + renameName n | n == from = to + | otherwise = n + +existingOutput :: GateType -> String -> String -> Device -> Maybe String +existingOutput gType i1 i2 device + | null gates = Nothing + | otherwise = Just $ output $ head gates + where + f (Gate g i _o) = g == gType && i1 `elem` i && i2 `elem` i + gates = filter f device + +renameAll :: GateType -> String -> String -> String -> Device -> Device +renameAll gType i1 i2 newO device = + case mo of + Nothing -> device + Just o -> renameWire o newO device + where mo = existingOutput gType i1 i2 device + +renameAllN :: GateType -> String -> String -> String -> Int -> Device -> Device +renameAllN gType p1 p2 po n device = renameAll gType i1 i2 pn device + where i1 = p1 ++ show2d n + i2 = p2 ++ show2d n + pn = po ++ show2d n + +renameCarryI :: Int -> Device -> Device +renameCarryI n device = renameAll And ("xor" ++ show2d n) ("carry" ++ show2d (n-1)) ("int_carry" ++ show2d n) device + +renameCarry :: Device -> Int -> Device +renameCarry device n = d2 + where d1 = renameCarryI n device + d2 = renameAll Or ("int_carry" ++ show2d n) ("and" ++ show2d n) ("carry" ++ show2d n) d1 + +renamings :: Device -> Device +renamings device = d5 + where + d1 = foldr (renameAllN Xor "x" "y" "xor") device [0..44] + d2 = foldr (renameAllN And "x" "y" "and") d1 [0..44] + d3 = foldr (renameAllN Or "x" "y" "or") d2 [0..44] + d4 = renameWire "and00" "carry00" d3 + d5 = foldl renameCarry d4 [1..44] + +-- parse the input file + +wiresDeviceP :: Parser (Wires, Device) +wiresP :: Parser Wires +wireP :: Parser (String, Int) +nameP :: Parser String +deviceP :: Parser Device +gateP :: Parser Gate +gateTypeP :: Parser GateType + +wiresDeviceP = (,) <$> wiresP <* endOfLine <* endOfLine <*> deviceP + +wiresP = M.fromList <$> wireP `sepBy` endOfLine +wireP = (,) <$> nameP <* string ": " <*> decimal + +nameP = many1 (letter <|> digit) + +deviceP = gateP `sepBy` endOfLine +gateP = gateify <$> nameP <* space <*> gateTypeP <* space <*> nameP <* string " -> " <*> nameP + where gateify i1 g i2 o = Gate g (sort [i1, i2]) o + +gateTypeP = (And <$ "AND") <|> (Or <$ "OR") <|> (Xor <$ "XOR") + +successfulParse :: Text -> (Wires, Device) +successfulParse input = + case parseOnly wiresDeviceP input of + Left _err -> (M.empty, []) -- TIO.putStr $ T.pack $ parseErrorPretty err + Right wiresDevice -> wiresDevice diff --git a/advent24/MainWithInvestigations.hs b/advent24/MainWithInvestigations.hs new file mode 100644 index 0000000..c91ec7e --- /dev/null +++ b/advent24/MainWithInvestigations.hs @@ -0,0 +1,345 @@ +-- Writeup at https://work.njae.me.uk/2024/12/29/advent-of-code-2024-day-24/ + +import AoC + +import Data.Text (Text) +import qualified Data.Text.IO as TIO +import Data.Attoparsec.Text hiding (take) +import Control.Applicative +import qualified Data.Map.Strict as M +-- import qualified Data.Set as S +import Data.List +import Data.Bits (xor, (.&.), (.|.), (.<<.), testBit) +import Data.Tree +import Data.Maybe +import Data.Char +-- import Data.Either +import Control.Monad (foldM) + +-- import Debug.Trace + + +type Wires = M.Map String Int + +data GateType = And | Or | Xor | Carry | Output + deriving (Show, Eq, Ord) + +data Gate = Gate { gType :: GateType, inputs :: [String], output :: String } + deriving (Show, Eq, Ord) + +type Device = [Gate] + +type DeviceTree = Tree Gate + +main :: IO () +main = + do dataFileName <- getDataFileName + text <- TIO.readFile dataFileName + let (wires, device) = successfulParse text + -- print wires + -- print device + -- print $ simulate wires device + -- print $ wiresOutput $ simulate wires device + print $ part1 wires device + putStrLn $ part2 device + +-- convenience for debugging +rd :: IO (Wires, Device) +rd = do + text <- TIO.readFile "../data/advent24.txt" + return $ successfulParse text + +rdn :: IO Device +rdn = do + text <- TIO.readFile "../data/advent24.txt" + let (_, device) = successfulParse text + let r1 = swapWires "vss" "z14" device + let r2 = swapWires "kdh" "hjf" r1 + let r3 = swapWires "z31" "kpp" r2 + let r4 = swapWires "z35" "sgj" r3 + return $ renamings r4 + + +part1 :: Wires -> Device -> Int +part1 wires device = wiresOutput $ simulate wires device + +part2 :: Device -> String +part2 device = intercalate "," $ sort $ concatMap (\(a, b) -> [a, b]) swaps + where swaps = repairAdder device 3 [] + + +simulate :: Wires -> Device -> Wires +simulate wires device = wires' + where (wires', _) = until (null . snd) simulateOnce (wires, device) + +simulateOnce :: (Wires, Device) -> (Wires, Device) +simulateOnce (wires, device) = (wires', remaining) + where + (run, remaining) = partition (canActivateGate wires) device + wires' = foldl simulateGate wires run + +canActivateGate :: Wires -> Gate -> Bool +canActivateGate wires gate = all (`M.member` wires) gate.inputs + +simulateGate :: Wires -> Gate -> Wires +simulateGate wires gate = M.insert gate.output result wires + where [i1, i2] = gate.inputs + result = case gate.gType of + And -> (wires M.! i1) .&. (wires M.! i2) + Or -> (wires M.! i1) .|. (wires M.! i2) + Xor -> (wires M.! i1) `xor` (wires M.! i2) + Carry -> error "Carry not implemented" + Output -> error "Output not implemented" + +isOutputWire :: String -> Bool +isOutputWire (x:_) = x == 'z' + +wiresOutput :: Wires -> Int +wiresOutput wires = M.foldlWithKey' go 0 outWires + where outWires = M.filterWithKey (\k _ -> isOutputWire k) wires + -- outShift w = read $ drop 1 w + -- go acc w v = acc .|. (v .<<. outShift w) + go acc w v = acc .|. (v .<<. codeOfName w) + +unfoldFromWire :: Device -> String -> DeviceTree +unfoldFromWire device wire = + unfoldTree unfoldDevice (device, fromJust $ gateForWire device wire) + +unfoldDevice :: (Device, Gate) -> (Gate, [(Device, Gate)]) +unfoldDevice (device, gate) = + ( gate + , fmap (\g -> (device, g)) feedGates + ) + where feedGates = sort $ catMaybes $ fmap (gateForWire device) gate.inputs + + +showFragment :: DeviceTree -> IO () +showFragment t = putStrLn $ unlines $ take 15 $ lines $ drawTree $ fmap show t + +gateForWire :: Device -> String -> Maybe Gate +gateForWire device wire = find ((== wire) . output) device + +setInputs :: Int -> Int -> Wires +setInputs x y = M.union (bitsOf "x" x) (bitsOf "y" y) + +bitsOf :: String -> Int -> Wires +bitsOf p n = M.fromList [(p ++ (show2d i), testBitI n i) | i <- [0..44]] + +testBitI n i + | testBit n i = 1 + | otherwise = 0 + +show2d :: Int -> String +show2d n | length (show n) == 1 = "0" ++ (show n) + | otherwise = show n + + +equivalentTree :: DeviceTree -> DeviceTree -> Bool +equivalentTree (Node (Gate Carry _ _) []) (Node (Gate And _ _) []) = True -- carry level 1 +equivalentTree (Node (Gate And _ _) []) (Node (Gate Carry _ _) []) = True +equivalentTree (Node (Gate Carry _ _) []) (Node (Gate Or _ _) _) = True -- carry level n +equivalentTree (Node (Gate Or _ _) _) (Node (Gate Carry _ _) []) = True +equivalentTree (Node (Gate g1 i1 _) []) (Node (Gate g2 i2 _) []) = + g1 == g2 && i1 == i2 +equivalentTree (Node (Gate g1 _ _) sub1@(_:_)) + (Node (Gate g2 _ _) sub2@(_:_)) = + g1 == g2 && ( (all (uncurry equivalentTree) $ zip sub1 sub2) + || (all (uncurry equivalentTree) $ zip sub1 (reverse sub2)) + ) +equivalentTree _ _ = False + + +makeAdder :: Int -> String -> Int -> DeviceTree +makeAdder 0 o _ = Node {rootLabel = Gate {gType = Xor, inputs = ["x00","y00"], output = o}, subForest = []} +makeAdder depth o n = Node {rootLabel = Gate {gType = Xor, inputs = [n0, n1], output = o}, subForest = [gAdd, gCarry]} + where gAdd = Node {rootLabel = Gate {gType = Xor, inputs = ["x" ++ show2d depth,"y" ++ show2d depth], output = n0}, subForest = []} + gCarry = makeCarry (depth-1) n1 (n + 2) + n0 = nonceStr n + n1 = nonceStr (n+1) + +makeCarry :: Int -> String -> Int -> DeviceTree +makeCarry 0 o _ = Node {rootLabel = Gate {gType = And, inputs = ["x00","y00"], output = o}, subForest = []} +makeCarry depth o n = Node {rootLabel = Gate {gType = Or, inputs = [n0, n1], output = o}, subForest = [c0, c1]} + where c0 = Node {rootLabel = Gate {gType = And, inputs = [n2, n3], output = n0}, subForest = [c2, c3]} + c1 = Node {rootLabel = Gate {gType = And, inputs = ["x" ++ show2d depth,"y" ++ show2d depth], output = n1}, subForest = []} + c2 = makeCarry (depth-1) n2 (n + 4) + c3 = Node {rootLabel = Gate {gType = Xor, inputs = ["x" ++ show2d depth,"y" ++ show2d depth], output = n3}, subForest = []} + n0 = nonceStr n + n1 = nonceStr (n+1) + n2 = nonceStr (n+2) + n3 = nonceStr (n+3) + +makeAdderStub :: Int -> DeviceTree +makeAdderStub 0 = Node {rootLabel = Gate {gType = Xor, inputs = ["x00","y00"], output = "z00"}, subForest = []} +makeAdderStub 1 = Node {rootLabel = Gate {gType = Xor, inputs = [n0, n1], output = "z01"}, subForest = [gAdd, gCarry]} + where gAdd = Node {rootLabel = Gate {gType = Xor, inputs = ["x01","y01"], output = n0}, subForest = []} + gCarry = Node {rootLabel = Gate {gType = And, inputs = ["x00","y00"], output = n1}, subForest = []} + n0 = nonceStr 0 + n1 = nonceStr 1 +makeAdderStub depth = Node {rootLabel = Gate {gType = Xor, inputs = [n0, n1], output = "z" ++ show2d depth}, subForest = [gAdd, gCarry]} + where gAdd = Node {rootLabel = Gate {gType = Xor, inputs = ["x" ++ show2d depth,"y" ++ show2d depth], output = n0}, subForest = []} + n0 = nonceStr 0 + n1 = nonceStr 1 + gCarry = Node {rootLabel = Gate {gType = Or, inputs = [nc0, nc1], output = n1}, subForest = [c0, c1]} + c0 = Node {rootLabel = Gate {gType = And, inputs = [nc2, nc3], output = nc0}, subForest = [c2, c3]} + c1 = Node {rootLabel = Gate {gType = And, inputs = ["x" ++ show2d depth1,"y" ++ show2d depth1], output = nc1}, subForest = []} + c2 = Node {rootLabel = Gate {gType = Carry, inputs = [], output = nc2}, subForest = []} + c3 = Node {rootLabel = Gate {gType = Xor, inputs = ["x" ++ show2d depth1,"y" ++ show2d depth1], output = nc3}, subForest = []} + nc0 = nonceStr 2 + nc1 = nonceStr 3 + nc2 = nonceStr 4 + nc3 = nonceStr 5 + depth1 = depth - 1 + + +repairAdder :: Device -> Int -> [(String, String)] -> [(String, String)] +-- repairAdder device n acc | traceShow ("repair", n, acc) False = undefined +repairAdder _device 44 acc = acc +repairAdder device n acc = + case adder of + Left (o1, o2) -> repairAdder (swapWires o1 o2 device) n ((o1, o2) : acc) + Right _ -> repairAdder device (n + 1) acc + where d1 = replaceCarry (n - 1) device + adder = growFromCarry n d1 + -- swaps = + -- case adder of + -- Left (o1, o2) -> (o1, o2) : repairAdder (swapWires o1 o2 device) n + -- Right t -> repairAdder device (n + 1) + + +growFromCarry :: Int -> Device -> Either (String, String) DeviceTree +growFromCarry n device = + do let c = Node {rootLabel = fromJust $ find ((== Carry) . gType) device, subForest = []} + let x0 = "x" ++ show2d (n - 1) + let y0 = "y" ++ show2d (n - 1) + let x1 = "x" ++ show2d n + let y1 = "y" ++ show2d n + let z1 = "z" ++ show2d n + let spineGates = [ (And, (Gate Xor [x0, y0] "")) + , (Or, (Gate And [x0, y0] "")) + , (Xor, (Gate Xor [x1, y1] "")) + ] + grown <- foldM (growSpine device) c spineGates + let grownOut = output $ rootLabel grown + if grownOut == z1 then Right grown else Left (grownOut, z1) + + +-- the left is a swap +growSpine :: Device -> DeviceTree -> (GateType, Gate) -> Either (String, String) DeviceTree +-- growSpine device spine (spineType, leafGate) | traceShow ("spine", spine, spineType, leafGate) False = undefined +growSpine device + spine + ( spineType -- next spine template + , (Gate leafType leafInput _) -- next leaf template + ) + | null spineParents = Left (spineOut, otherParentInput) + | null nextLeafParents = Left (nextLeaf.output, otherParentInput) + | not $ null commonSpineCandidates = Right (Node {rootLabel = head commonSpineCandidates, subForest = [nextLeafTree, spine]}) + | otherwise = Left ("", "") + where + spineParents = filter (\g -> g.gType == spineType && spineOut `elem` g.inputs) device + nextLeaf = head $ filter (\g -> g.gType == leafType && leafInput == g.inputs) device + nextLeafParents = filter (\g -> g.gType == spineType && nextLeaf.output `elem` g.inputs) device + nextLeafTree = Node {rootLabel = nextLeaf, subForest = []} + commonSpineCandidates = spineParents `intersect` nextLeafParents + spineOut = spine.rootLabel.output + otherParentInput = if null spineParents + then head $ delete nextLeaf.output (inputs $ head nextLeafParents) + else head $ delete spineOut (inputs $ head spineParents) + + +nonceStr :: Int -> String +nonceStr n = "n" ++ show n + +codeOfName :: String -> Int +codeOfName s -- = read . filter isDigit + | null ds = 1000 + | otherwise = read ds + where ds = filter isDigit s + +replaceCarry :: Int -> Device -> Device +replaceCarry n device = (Gate Carry [] carryGate.output) : filter (/= carryGate) device + where outWire = "z" ++ show2d n + outGate = head $ filter ((== outWire) . output) device + carryGate = head $ filter (\g -> (g.output `elem` outGate.inputs) && g.gType == Or) device + + +swapWires :: String -> String -> Device -> Device +swapWires w1 w2 = renameOutput "swap" w2 . renameOutput w2 w1 . renameOutput w1 "swap" + where renameOutput from to = fmap rename + where rename (Gate g i o) = Gate g i (renameName o) + renameName n | n == from = to + | otherwise = n + +renameWire :: String -> String -> Device -> Device +renameWire from to = fmap rename + where rename (Gate g i o) = Gate g (fmap renameName i) (renameName o) + renameName n | n == from = to + | otherwise = n + +existingOutput :: GateType -> String -> String -> Device -> Maybe String +existingOutput gType i1 i2 device + | null gates = Nothing + | otherwise = Just $ output $ head gates + where + f (Gate g i _o) = g == gType && i1 `elem` i && i2 `elem` i + gates = filter f device + +renameAll :: GateType -> String -> String -> String -> Device -> Device +renameAll gType i1 i2 newO device = + case mo of + Nothing -> device + Just o -> renameWire o newO device + where mo = existingOutput gType i1 i2 device + +renameAllN :: GateType -> String -> String -> String -> Int -> Device -> Device +renameAllN gType p1 p2 po n device = renameAll gType i1 i2 pn device + where i1 = p1 ++ show2d n + i2 = p2 ++ show2d n + pn = po ++ show2d n + +renameCarryI :: Int -> Device -> Device +renameCarryI n device = renameAll And ("xor" ++ show2d n) ("carry" ++ show2d (n-1)) ("int_carry" ++ show2d n) device + +renameCarry :: Device -> Int -> Device +renameCarry device n = d2 + where d1 = renameCarryI n device + d2 = renameAll Or ("int_carry" ++ show2d n) ("and" ++ show2d n) ("carry" ++ show2d n) d1 + +renamings :: Device -> Device +renamings device = d5 + where + d1 = foldr (renameAllN Xor "x" "y" "xor") device [0..44] + d2 = foldr (renameAllN And "x" "y" "and") d1 [0..44] + d3 = foldr (renameAllN Or "x" "y" "or") d2 [0..44] + d4 = renameWire "and00" "carry00" d3 + d5 = foldl renameCarry d4 [1..44] + +-- parse the input file + +wiresDeviceP :: Parser (Wires, Device) +wiresP :: Parser Wires +wireP :: Parser (String, Int) +nameP :: Parser String +deviceP :: Parser Device +gateP :: Parser Gate +gateTypeP :: Parser GateType + +wiresDeviceP = (,) <$> wiresP <* endOfLine <* endOfLine <*> deviceP + +wiresP = M.fromList <$> wireP `sepBy` endOfLine +wireP = (,) <$> nameP <* string ": " <*> decimal + +nameP = many1 (letter <|> digit) + +deviceP = gateP `sepBy` endOfLine +gateP = gateify <$> nameP <* space <*> gateTypeP <* space <*> nameP <* string " -> " <*> nameP + where gateify i1 g i2 o = Gate g (sort [i1, i2]) o + +gateTypeP = (And <$ "AND") <|> (Or <$ "OR") <|> (Xor <$ "XOR") + +successfulParse :: Text -> (Wires, Device) +successfulParse input = + case parseOnly wiresDeviceP input of + Left _err -> (M.empty, []) -- TIO.putStr $ T.pack $ parseErrorPretty err + Right wiresDevice -> wiresDevice diff --git a/advent24/notes.hs b/advent24/notes.hs index 15a6bec..4f049a3 100644 --- a/advent24/notes.hs +++ b/advent24/notes.hs @@ -28,3 +28,8 @@ putStrLn $ unlines $ fmap show $ sortOn (codeOfName . head . inputs) $ device +(wires, device) <- rd +dc2 = replaceCarry 2 device + + + diff --git a/adventofcode24.cabal b/adventofcode24.cabal index dcde33d..2a0f3b4 100644 --- a/adventofcode24.cabal +++ b/adventofcode24.cabal @@ -250,6 +250,14 @@ executable advent24 import: warnings, common-extensions, build-directives, common-modules main-is: advent24/Main.hs build-depends: attoparsec, text, containers +executable advent24wi + import: warnings, common-extensions, build-directives, common-modules + main-is: advent24/MainWithInvestigations.hs + build-depends: attoparsec, text, containers +executable advent24orig + import: warnings, common-extensions, build-directives, common-modules + main-is: advent24/MainOriginal.hs + build-depends: attoparsec, text, containers executable advent25 import: warnings, common-extensions, build-directives, common-modules -- 2.34.1