From bc689ec22856749b96406382eac0345f2f71cb40 Mon Sep 17 00:00:00 2001 From: Neil Smith Date: Sat, 6 Jan 2024 14:54:23 +0000 Subject: [PATCH] Done day 25 --- advent-of-code23.cabal | 5 ++ advent25/Main.hs | 104 +++++++++++++++++++++++++++++++++++++++++ 2 files changed, 109 insertions(+) create mode 100644 advent25/Main.hs diff --git a/advent-of-code23.cabal b/advent-of-code23.cabal index 7f69609..a0b2880 100644 --- a/advent-of-code23.cabal +++ b/advent-of-code23.cabal @@ -236,3 +236,8 @@ executable advent24 import: common-extensions, build-directives main-is: advent24/Main.hs build-depends: linear, text, attoparsec, lens + +executable advent25 + import: common-extensions, build-directives + main-is: advent25/Main.hs + build-depends: text, attoparsec, containers, multiset, random diff --git a/advent25/Main.hs b/advent25/Main.hs new file mode 100644 index 0000000..0b9c02a --- /dev/null +++ b/advent25/Main.hs @@ -0,0 +1,104 @@ +-- Writeup at https://work.njae.me.uk/2024/01/06/advent-of-code-2023-day-25/ + +import AoC + +import Data.Text (Text) +import qualified Data.Text.IO as TIO +import Data.Attoparsec.Text hiding (take) +-- import Control.Applicative +import Data.List (foldl', unfoldr, sort, delete) +import qualified Data.Map as M +import Data.Map ((!)) +import qualified Data.Set as S +import Data.Set ((\\)) +import qualified Data.Sequence as Q +import Data.Sequence ( (><), Seq(..) ) +import Data.Foldable (toList) +import Data.Maybe (catMaybes) +import System.Random +import qualified Data.MultiSet as MS +import Data.Tuple (swap) + +type Graph = M.Map String [String] + +main :: IO () +main = + do dataFileName <- getDataFileName + text <- TIO.readFile dataFileName + let halfGraph = successfulParse text + let graph = reverseGraph halfGraph + print $ part1 graph + +part1 :: Graph -> Int +part1 graph = (S.size componentA) * (S.size componentB) + where (ss, gs) = splitAt 200 $ randomNodes graph 400 + paths = fmap toList $ catMaybes $ fmap (bfsPair graph) $ zip ss gs + pathCounts = MS.fromList $ concatMap getEdges paths + populars = fmap snd $ take 3 $ reverse $ sort $ fmap swap $ MS.toOccurList pathCounts + separatedGraph = foldl' removeEdge graph populars + (a, b) = head populars + componentA = componentOf separatedGraph (S.singleton a) S.empty + componentB = componentOf separatedGraph (S.singleton b) S.empty + + +reverseGraph :: Graph -> Graph +reverseGraph graph = M.foldlWithKey' reverseNode graph graph + +reverseNode :: Graph -> String -> [String] -> Graph +reverseNode graph here theres = foldl' (addReversed here) graph theres + +addReversed :: String -> Graph -> String -> Graph +addReversed here graph there = M.insertWith (++) there [here] graph + +bfsPair :: Graph -> (String, String) -> Maybe (Seq String) +bfsPair graph (start, goal) = bfs graph (Q.singleton (Q.singleton start)) goal S.empty + +bfs :: Graph -> Seq (Seq String) -> String -> S.Set String -> Maybe (Seq String) +bfs _ Q.Empty _ _ = Nothing +bfs graph (current :<| agenda) goal closed + | here == goal = Just current + | here `S.member` closed = bfs graph agenda goal closed + | otherwise = bfs graph (agenda >< nexts) goal (S.insert here closed) + where (_ :|> here) = current + nexts = Q.fromList $ fmap (current :|>) $ graph ! here + +componentOf :: Graph -> S.Set String -> S.Set String -> S.Set String +componentOf graph boundary0 found + | S.null boundary0 = found + | otherwise = componentOf graph boundary2 found' + where (here, boundary1) = S.deleteFindMin boundary0 + found' = S.insert here found + boundary2 = S.union boundary1 $ (S.fromList $ graph ! here) \\ found' + +randomNodes :: Graph -> Int -> [String] +randomNodes graph n = fmap (\i -> fst $ M.elemAt i graph) indices + where range = (0, M.size graph - 1) + pureGen = mkStdGen 137 + indices = take n $ unfoldr (Just . uniformR range) pureGen + +getEdges :: [String] -> [(String, String)] +getEdges xs = zipWith go xs (tail xs) + where go a b + | a < b = (a, b) + | otherwise = (b, a) + +removeEdge :: Graph -> (String, String) -> Graph +removeEdge graph (a, b) = M.adjust (delete a) b $ M.adjust (delete b) a graph + + +-- Parse the input file + +graphP :: Parser Graph +nodeP :: Parser (String, [String]) +nameP :: Parser String + +graphP = M.fromList <$> nodeP `sepBy` endOfLine +nodeP = (,) <$> (nameP <* ": ") <*> (nameP `sepBy` " ") + +nameP = many1 letter + +successfulParse :: Text -> Graph +successfulParse input = + case parseOnly graphP input of + Left _err -> M.empty -- TIO.putStr $ T.pack $ parseErrorPretty err + Right matches -> matches \ No newline at end of file -- 2.34.1