Done day 25

diff --git a/advent-of-code23.cabal b/advent-of-code23.cabal
index 7f69609c11958efcb76440d499b14656b77acd63..a0b288042abc30c380fe18855a0aa5aa5128e368 100644 (file)
--- 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 (file)
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