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 }
-- 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)
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 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
| 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
--- /dev/null
+-- 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
--- /dev/null
+-- 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
+(wires, device) <- rd
+dc2 = replaceCarry 2 device
+
+
+
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
projects / advent-of-code-24.git / commitdiff