Day 25

advent-of-code-2023.cabal

@@ -152,3 +152,32 @@ executable day21
     hs-source-dirs:     day21
     default-language:   Haskell2010
     default-extensions: LambdaCase
+
+executable day22
+    main-is:            Main.hs
+    other-modules:      Commons Part1 Part2
+    build-depends:      base ^>=4.15.1.0, containers, MissingH
+    hs-source-dirs:     day22
+    default-language:   Haskell2010
+
+executable day23
+    main-is:            Main.hs
+    other-modules:      Commons Part1 Part2
+    build-depends:      base ^>=4.15.1.0, array, containers
+    hs-source-dirs:     day23
+    default-language:   Haskell2010
+    default-extensions: LambdaCase
+
+executable day24
+    main-is:            Main.hs
+    other-modules:      Commons Part1 Part2
+    build-depends:      base ^>=4.15.1.0, MissingH, mfsolve
+    hs-source-dirs:     day24
+    default-language:   Haskell2010
+
+executable day25
+    main-is:            Main.hs
+    other-modules:      Commons
+    build-depends:      base ^>=4.15.1.0, containers, MissingH
+    hs-source-dirs:     day25
+    default-language:   Haskell2010

day22/Commons.hs

@@ -0,0 +1,59 @@
+module Commons where
+
+import Data.List.Utils (split)
+import GHC.IO.Handle (isEOF)
+import qualified Data.Map.Strict as M
+
+
+data Cube = Cube { z :: Int, y :: Int, x :: Int } deriving (Eq, Ord, Show)
+type Brick = [Cube]
+type Snapshot = M.Map (Int, Int, Int) Brick
+
+
+parseBrick :: [Int] -> [Int] -> Brick
+parseBrick [x1, y1, z1] [x2, y2, z2] = Cube {x = x1, y = y1, z = z1}:
+  if x1 < x2 then parseBrick [x1 + 1, y1, z1] [x2, y2, z2]
+  else if x1 > x2 then parseBrick [x1, y1, z1] [x2 + 1, y2, z2]
+  else if y1 < y2 then parseBrick [x1, y1 + 1, z1] [x2, y2, z2]
+  else if y1 > y2 then parseBrick [x1, y1, z1] [x2, y2 + 1, z2]
+  else if z1 < z2 then parseBrick [x1, y1, z1 + 1] [x2, y2, z2]
+  else if z1 > z2 then parseBrick [x1, y1, z1] [x2, y2, z2 + 1]
+  else []
+
+parseLine :: String -> [((Int, Int, Int), Brick)]
+parseLine line = let (start: end: _) = split "~" line
+                     parsedStart = map read $ split "," start
+                     parsedEnd = map read $ split "," end
+                     brick = parseBrick parsedStart parsedEnd
+                 in map (\ c -> ((z c, y c, x c), brick)) brick
+
+parseSnapshot :: [((Int, Int, Int), Brick)] -> IO Snapshot
+parseSnapshot otherBricks = do done <- isEOF
+                               if done
+                                  then return $ M.fromList otherBricks
+                                  else do line <- getLine
+                                          let brick = parseLine line
+                                          parseSnapshot (otherBricks ++ brick)
+
+parse :: IO Snapshot
+parse = parseSnapshot []
+
+
+getFalling :: Snapshot -> [((Int, Int, Int), Brick)]
+getFalling s = M.toList $ M.filter (\ b ->
+  let minZ = foldl (\ mz c -> min mz (z c)) maxBound b
+  in foldl (\ r c -> r && minZ > 1 && M.notMember (minZ - 1, y c, x c) s) True b) s
+
+getFell :: Snapshot -> [((Int, Int, Int), Brick)] -> [((Int, Int, Int), Brick)]
+getFell s = map (\ ((zk, yk, xk), v) ->
+  ((zk - 1, yk, xk), map (\ c -> Cube {z = z c - 1, y = y c, x = x c}) v))
+
+getPostFall :: Snapshot -> [((Int, Int, Int), Brick)] -> [((Int, Int, Int), Brick)] -> Snapshot
+getPostFall s falling fell = M.union (M.difference s $ M.fromList falling) (M.fromList fell)
+
+fall :: Snapshot -> Snapshot
+fall s =
+  let falling = getFalling s
+      fell = getFell s falling
+  in if null falling then s
+     else fall $ getPostFall s falling fell

day22/Main.hs

@@ -0,0 +1,13 @@
+module Main where
+
+import Commons
+import qualified Part1
+import qualified Part2
+
+
+main = do snapshot <- parse
+          let afterFallSnapshot = fall snapshot
+          let part1Res = Part1.getDestroyables afterFallSnapshot
+          print $ length part1Res
+          let part2Res = Part2.getReactions afterFallSnapshot
+          print $ sum $ map length part2Res

day22/Part1.hs

@@ -0,0 +1,13 @@
+module Part1 where
+
+import Commons
+import qualified Data.Map.Strict as M
+import qualified Data.Set as S
+
+
+canDestroy :: Snapshot -> Brick -> Bool
+canDestroy s b = let newSnapshot = M.difference s $ M.fromList $ map (\ c -> ((z c, y c, x c), b)) b
+                 in null $ getFalling newSnapshot
+
+getDestroyables :: Snapshot -> S.Set Brick
+getDestroyables s = S.fromList $ filter (canDestroy s) $ M.elems s

day22/Part2.hs

@@ -0,0 +1,23 @@
+module Part2 where
+
+import Commons
+import qualified Data.Map.Strict as M
+import qualified Data.Set as S
+import Data.Foldable (maximumBy)
+import Data.Function (on)
+
+
+getFutureFall' :: Snapshot -> S.Set Brick -> S.Set Brick
+getFutureFall' s sFell =
+  let falling = getFalling s
+  in if null falling then sFell
+     else let fell = getFell s falling
+              newSFell = S.union (S.difference sFell (S.fromList $ map snd falling)) $ S.fromList $ map snd fell
+          in getFutureFall' (getPostFall s falling fell) newSFell
+
+getFutureFall :: Snapshot -> Brick -> S.Set Brick
+getFutureFall s b = let newSnapshot = M.difference s $ M.fromList $ map (\ c -> ((z c, y c, x c), b)) b
+                    in getFutureFall' newSnapshot S.empty
+
+getReactions :: Snapshot -> [S.Set Brick]
+getReactions s = S.toList $ S.fromList $ map (getFutureFall s) $ M.elems s

day23/Commons.hs

@@ -0,0 +1,32 @@
+module Commons where
+
+import GHC.IO.Handle (isEOF)
+import Data.Array (Array, listArray, (!), Ix (inRange), bounds)
+
+
+data Direction = North | South | West | East deriving (Eq, Ord, Show)
+data Tile = Empty | Rock | Slope { direction :: Direction } deriving (Eq, Show)
+type Trails = Array (Int, Int) Tile
+
+
+parseLine :: String -> [Tile]
+parseLine = map (\case
+                  '.' -> Empty
+                  '#' -> Rock
+                  '>' -> Slope {direction = East}
+                  'v' -> Slope {direction = South}
+                  '<' -> Slope {direction = West}
+                  '^' -> Slope {direction = North})
+
+parseTrails :: IO [[Tile]]
+parseTrails = do done <- isEOF
+                 if done
+                    then return []
+                    else do line <- getLine
+                            let trailsLine = parseLine line
+                            trails <- parseTrails
+                            return (trailsLine: trails)
+
+parse :: IO Trails
+parse = do trails <- parseTrails
+           return $ listArray ((1, 1), (length trails, length $ head trails)) $ concat trails

day23/Main.hs

@@ -0,0 +1,13 @@
+module Main where
+
+import Commons
+import qualified Part1
+import qualified Part2
+
+
+main = do trailsMap <- parse
+          let part1Res = Part1.getAllTrails trailsMap
+          print $ maximum $ map length part1Res
+          let compactPaths = Part2.getCompactPaths trailsMap part1Res
+          let part2Res = Part2.getAllTrails trailsMap compactPaths
+          print $ maximum $ map (foldl (\ s t -> s + snd t) 0) part2Res

day23/Part1.hs

@@ -0,0 +1,31 @@
+module Part1 where
+
+import Commons
+import Data.Array (Ix (inRange), bounds, (!))
+
+
+cleanNext :: Trails -> [(Int, Int)] -> [((Int, Int), Direction)] -> [((Int, Int), Direction)]
+cleanNext tr hist [] = []
+cleanNext tr hist ((ch, dh): t) =
+  if inRange (bounds tr) ch && (tr ! ch == Slope dh || tr ! ch == Empty) && notElem ch hist
+  then (ch, dh): cleanNext tr hist t else cleanNext tr hist t
+
+getNext :: Trails -> [(Int, Int)] -> Direction -> [((Int, Int), Direction)]
+getNext tr ((y, x): t) North = cleanNext tr t [((y - 1, x), North), ((y, x - 1), West), ((y, x + 1), East)]
+getNext tr ((y, x): t) East = cleanNext tr t [((y - 1, x), North), ((y, x + 1), East), ((y + 1, x), South)]
+getNext tr ((y, x): t) South = cleanNext tr t [((y + 1, x), South), ((y, x - 1), West), ((y, x + 1), East)]
+getNext tr ((y, x): t) West = cleanNext tr t [((y - 1, x), North), ((y, x - 1), West), ((y + 1, x), South)]
+
+getNextTrails' :: Trails -> (Int, Int) -> (Int, Int) -> [(Int, Int)] -> [((Int, Int), Direction)] -> [[(Int, Int)]]
+getNextTrails' _ _ _ _ [] = []
+getNextTrails' tr f s hist ((ch, dh): t)
+  | ch == f   = hist: getNextTrails' tr f ch hist t
+  | otherwise = getNextTrails tr f ch (ch: hist) dh ++ getNextTrails' tr f ch hist t
+
+getNextTrails :: Trails -> (Int, Int) -> (Int, Int) -> [(Int, Int)] -> Direction -> [[(Int, Int)]]
+getNextTrails tr f s hist d = let next = getNext tr hist d
+                              in getNextTrails' tr f s hist next
+
+getAllTrails :: Trails -> [[(Int, Int)]]
+getAllTrails tr = let ((yMin, xMin), (yMax, xMax)) = bounds tr
+                  in getNextTrails tr (yMax, xMax - 1) (yMin, xMin + 1) [(yMin, xMin + 1)] South

day23/Part2.hs

@@ -0,0 +1,68 @@
+module Part2 where
+
+import Commons
+import Data.Array (Ix (inRange), bounds, (!))
+import qualified Data.Map as M
+
+
+type CompactPaths = M.Map ((Int, Int), Direction) ((Int, Int), Direction, Int)
+
+
+invertDirection :: Direction -> Direction
+invertDirection North = South
+invertDirection East = West
+invertDirection South = North
+invertDirection West = East
+
+findCompactPaths :: Trails -> [(Int, Int)] -> (Int, Int) -> Direction -> Int -> CompactPaths
+findCompactPaths _ [(yF, xF)] (y, x) d n =
+  let iD = invertDirection d
+  in M.insert ((yF, xF), South) ((y, x), d, n + 1) $ M.singleton ((y, x), iD) ((yF, xF), North, n + 1)
+findCompactPaths tr ((yF, xF): t) (y, x) d n
+  | let t = tr ! (yF, xF) in t /= Empty && t /= Rock =
+      let Slope nD = tr ! (yF, xF)
+          iD = invertDirection d
+          iND = invertDirection nD
+      in if n <= 2 then findCompactPaths tr t (yF, xF) nD 1
+         else M.union (M.insert ((yF, xF), nD) ((y, x), d, n + 1) $ M.singleton ((y, x), iD) ((yF, xF), iND, n + 1))
+                      $ findCompactPaths tr t (yF, xF) nD 1
+  | otherwise = findCompactPaths tr t (y, x) d (n + 1)
+
+getCompactPaths :: Trails -> [[(Int, Int)]] -> CompactPaths
+getCompactPaths _ [] = M.empty
+getCompactPaths tr (h: t) = let (y, x) = head h
+                            in M.union (getCompactPaths tr t) $ findCompactPaths tr h (y + 1, x) North 0
+
+
+cleanNext :: Trails -> CompactPaths -> [(Int, Int)] -> [((Int, Int), Direction)] -> [((Int, Int), Direction, Int)]
+cleanNext _ _ _ [] = []
+cleanNext tr cp hist ((ch, dh): t) =
+  if inRange (bounds tr) ch && (tr ! ch /= Rock) && notElem ch hist
+  then let actualNext = M.lookup (ch, dh) cp
+       in case actualNext of
+               Just v -> v: cleanNext tr cp hist t
+               _      -> (ch, dh, 1): cleanNext tr cp hist t
+  else cleanNext tr cp hist t
+
+getNext :: Trails -> CompactPaths -> [(Int, Int)] -> Direction -> [((Int, Int), Direction, Int)]
+getNext tr cp ((y, x): t) North = cleanNext tr cp t [((y - 1, x), North), ((y, x - 1), West), ((y, x + 1), East)]
+getNext tr cp ((y, x): t) East = cleanNext tr cp t [((y - 1, x), North), ((y, x + 1), East), ((y + 1, x), South)]
+getNext tr cp ((y, x): t) South = cleanNext tr cp t [((y + 1, x), South), ((y, x - 1), West), ((y, x + 1), East)]
+getNext tr cp ((y, x): t) West = cleanNext tr cp t [((y - 1, x), North), ((y, x - 1), West), ((y + 1, x), South)]
+
+getNextTrails' :: Trails -> CompactPaths -> (Int, Int) -> (Int, Int) -> [((Int, Int), Int)] ->
+                  [((Int, Int), Direction, Int)] -> [[((Int, Int), Int)]]
+getNextTrails' _ _ _ _ _ [] = []
+getNextTrails' tr cp f s hist ((ch, dh, nh): t)
+  | ch == f   = ((ch, nh): hist): getNextTrails' tr cp f ch hist t
+  | otherwise = getNextTrails tr cp f ch ((ch, nh): hist) dh ++ getNextTrails' tr cp f ch hist t
+
+getNextTrails :: Trails -> CompactPaths -> (Int, Int) -> (Int, Int) -> [((Int, Int), Int)] -> Direction ->
+                 [[((Int, Int), Int)]]
+getNextTrails tr cp f s hist d = let histWithoutDist = map fst hist
+                                     next = getNext tr cp histWithoutDist d
+                                 in getNextTrails' tr cp f s hist next
+
+getAllTrails :: Trails -> CompactPaths -> [[((Int, Int), Int)]]
+getAllTrails tr cp = let ((yMin, xMin), (yMax, xMax)) = bounds tr
+                     in getNextTrails tr cp (yMax, xMax - 1) (yMin - 1, xMin + 1) [((yMin - 1, xMin + 1), 0)] South

day24/Commons.hs

@@ -0,0 +1,24 @@
+module Commons where
+
+import GHC.IO.Handle (isEOF)
+import Data.List.Utils (split)
+
+
+data Hailstone = Hailstone { x :: Int, y :: Int, z :: Int, vx :: Int, vy :: Int, vz :: Int } deriving Show
+
+
+parseHail :: String -> String -> Hailstone
+parseHail pos speed = let (rX: rY: rZ: _) = split ", " pos
+                          (rVx: rVy: rVz: _) = split ", " speed
+                      in Hailstone { x = read rX, y = read rY, z = read rZ,
+                                     vx = read rVx, vy = read rVy, vz = read rVz }
+
+parse :: IO [Hailstone]
+parse = do done <- isEOF
+           if done
+              then return []
+              else do line <- getLine
+                      let (rawPos: rawSpeed: _) = split " @ " line
+                      let hail = parseHail rawPos rawSpeed
+                      otherHail <- parse
+                      return $ hail: otherHail

day24/Main.hs

@@ -0,0 +1,12 @@
+module Main where
+
+import Commons
+import qualified Part1
+import qualified Part2
+
+
+main = do hail <- parse
+          let part1Res = Part1.findIntersections (200000000000000, 400000000000000) hail
+          print $ length part1Res
+          let part2Res = Part2.getCoords hail
+          print $ sum part2Res

day24/Part1.hs

@@ -0,0 +1,52 @@
+module Part1 where
+
+import Commons
+
+
+getCoords :: (Int, Int) -> Hailstone -> ((Double, Double), (Double, Double))
+getCoords (minP, maxP) h =
+  let xSteps = if vx h > 0 then fromIntegral (abs (maxP - x h)) / fromIntegral (vx h)
+               else fromIntegral (abs (minP - x h)) / fromIntegral (-1 * vx h)
+      ySteps = if vy h > 0 then fromIntegral (abs (maxP - y h)) / fromIntegral (vy h)
+               else fromIntegral (abs (minP - y h)) / fromIntegral (-1 * vy h)
+      ((x1, y1), (x2, y2)) = if xSteps < ySteps
+                             then ((fromIntegral $ x h, fromIntegral $ y h),
+                                   (fromIntegral (x h) + xSteps * fromIntegral (vx h),
+                                    fromIntegral (y h) + xSteps * fromIntegral (vy h)))
+                             else ((fromIntegral $ x h, fromIntegral $ y h),
+                                   (fromIntegral (x h) + ySteps * fromIntegral (vx h),
+                                    fromIntegral (y h) + ySteps * fromIntegral (vy h)))
+  in ((x1, y1), (x2, y2))
+
+getIntersection :: ((Double, Double), (Double, Double)) -> ((Double, Double), (Double, Double)) ->
+                   Maybe (Double, Double)
+getIntersection ((x1, y1), (x2, y2)) ((x3, y3), (x4, y4)) =
+  let c = (x1 - x2) * (y3 - y4) - (y1 - y2) * (x3 - x4)
+  in if abs c < 0.01 then Nothing
+     else let a = x1 * y2 - y1 * x2
+              b = x3 * y4 - y3 * x4
+              x = (a * (x3 - x4) - b * (x1 - x2)) / c
+              y = (a * (y3 - y4) - b * (y1 - y2)) / c
+          in Just (x, y)
+
+checkIntersect :: (Int, Int) -> Hailstone -> Hailstone -> Maybe (Double, Double)
+checkIntersect (minP, maxP) h1 h2 =
+  let ((x1, y1), (x2, y2)) = getCoords (minP, maxP) h1
+      ((x3, y3), (x4, y4)) = getCoords (minP, maxP) h2
+      dMinP                = fromIntegral minP
+      dMaxP                = fromIntegral maxP
+  in case getIntersection ((x1, y1), (x2, y2)) ((x3, y3), (x4, y4)) of
+          Nothing     -> Nothing
+          Just (x, y) -> if x >= min x1 x2 && x <= max x1 x2 && x >= min x3 x4 && x <= max x3 x4
+                            && x >= dMinP && x <= dMaxP && y >= dMinP && y <= dMaxP
+                         then Just (x, y) else Nothing
+
+getIntersections :: (Int, Int) -> [Hailstone] -> [Hailstone] -> [(Double, Double)]
+getIntersections _ [_] _ = []
+getIntersections p (_: h: t) [] = getIntersections p (h: t) t
+getIntersections p (h1: t1) (h2: t2) = case checkIntersect p h1 h2 of
+                                            Just (x, y) -> (x, y): getIntersections p (h1: t1) t2
+                                            Nothing     -> getIntersections p (h1: t1) t2
+
+findIntersections :: (Int, Int) -> [Hailstone] -> [(Double, Double)]
+findIntersections p (h: t) = getIntersections p (h: t) t

day24/Part2.hs

@@ -0,0 +1,26 @@
+module Part2 where
+
+import Commons
+import Math.MFSolve
+import Data.Foldable (find)
+
+
+solve :: [Hailstone] -> Either (DepError SimpleVar Double) (Dependencies SimpleVar Double)
+solve [h1, h2, h3, h4, h5, h6] =
+  let [x0, y0, z0, vx0, vy0, vz0] = map (makeVariable . SimpleVar) ["x0", "y0", "z0", "vx0", "vy0", "vz0"]
+  in flip execSolver noDeps $
+     do x0 * fromIntegral (vy h2 - vy h1) + y0 * fromIntegral (vx h1 - vx h2) + vx0 * fromIntegral (y h1 - y h2) + vy0 * fromIntegral (x h2 - x h1) === fromIntegral (y h1 * vx h1 - x h1 * vy h1 + x h2 * vy h2 - y h2 * vx h2)
+        x0 * fromIntegral (vy h4 - vy h3) + y0 * fromIntegral (vx h3 - vx h4) + vx0 * fromIntegral (y h3 - y h4) + vy0 * fromIntegral (x h4 - x h3) === fromIntegral (y h3 * vx h3 - x h3 * vy h3 + x h4 * vy h4 - y h4 * vx h4)
+        x0 * fromIntegral (vy h6 - vy h5) + y0 * fromIntegral (vx h5 - vx h6) + vx0 * fromIntegral (y h5 - y h6) + vy0 * fromIntegral (x h6 - x h5) === fromIntegral (y h5 * vx h5 - x h5 * vy h5 + x h6 * vy h6 - y h6 * vx h6)
+        x0 * fromIntegral (vz h2 - vz h1) + z0 * fromIntegral (vx h1 - vx h2) + vx0 * fromIntegral (z h1 - z h2) + vz0 * fromIntegral (x h2 - x h1) === fromIntegral (z h1 * vx h1 - x h1 * vz h1 + x h2 * vz h2 - z h2 * vx h2)
+        x0 * fromIntegral (vz h4 - vz h3) + z0 * fromIntegral (vx h3 - vx h4) + vx0 * fromIntegral (z h3 - z h4) + vz0 * fromIntegral (x h4 - x h3) === fromIntegral (z h3 * vx h3 - x h3 * vz h3 + x h4 * vz h4 - z h4 * vx h4)
+        x0 * fromIntegral (vz h6 - vz h5) + z0 * fromIntegral (vx h5 - vx h6) + vx0 * fromIntegral (z h5 - z h6) + vz0 * fromIntegral (x h6 - x h5) === fromIntegral (z h5 * vx h5 - x h5 * vz h5 + x h6 * vz h6 - z h6 * vx h6)
+
+getCoords :: [Hailstone] -> [Int]
+getCoords h = let (h1: h2: h3: h4: h5: h6: _) = h
+                  (Right d) = solve [h1, h2, h3, h4, h5, h6]
+                  vars = knownVars d
+                  (Just x) = find (\ (v, _) -> v == SimpleVar "x0") vars
+                  (Just y) = find (\ (v, _) -> v == SimpleVar "y0") vars
+                  (Just z) = find (\ (v, _) -> v == SimpleVar "z0") vars
+              in [floor $ snd x, floor $ snd y, floor $ snd z]

day25/Commons.hs

@@ -0,0 +1,57 @@
+module Commons where
+
+import Data.List ((\\), delete, nub)
+import Data.List.Utils (split)
+import Data.Map (Map, singleton, insert, filterWithKey, empty, unionWith, fromList, union, (!), keys, member, size)
+import GHC.IO.Handle (isEOF)
+
+
+type Component = String
+type Network = Map Component [Component]
+
+
+parseLine :: Component -> [Component] -> Network
+parseLine c dest = foldl (\ n newC -> insert newC [c] n) (singleton c dest) dest
+
+parse :: IO Network
+parse = do done <- isEOF
+           if done
+              then return empty
+              else do line <- getLine
+                      let (c: dest: _) = split ": " line
+                      let n = parseLine c $ split " " dest
+                      unionWith (++) n <$> parse
+
+
+getDistances' :: Int -> [Component] -> Network -> Map Component Int -> Map Component Int
+getDistances' _ [] _ cd = cd
+getDistances' d dest n cd = let currentDistances = union cd $ fromList [(c, d) | c <- dest]
+                                next = nub (foldl (\ l c -> l ++ (n ! c)) [] dest) \\ keys currentDistances
+                            in getDistances' (d + 1) next n currentDistances
+
+getDistances :: Component -> Network -> Map Component Int
+getDistances c n = getDistances' 0 [c] n empty
+
+getPath :: Component -> Network -> Map Component Int -> [Component]
+getPath c n d | d ! c == 0 = [c]
+              | otherwise  = let newC = head $ keys $ Data.Map.filterWithKey
+                                                      (\ src dest -> c `elem` dest && d ! src < d ! c) n
+                             in getPath newC n d ++ [c]
+
+removePath :: [Component] -> Network -> Network
+removePath [_] n = n
+removePath (h1: h2: t) n = let n1 = delete h2 (n ! h1)
+                               n2 = delete h1 (n ! h2)
+                           in removePath (h2: t) (insert h1 n1 $ insert h2 n2 n)
+
+removeNPaths :: Int -> Component -> Component -> Network -> Network
+removeNPaths 0 _ _ net = net
+removeNPaths n c1 c2 net = let newNet = removePath (getPath c2 net (getDistances c1 net)) net
+                           in removeNPaths (n - 1) c1 c2 newNet
+
+iterateUntilPartition :: [Component] -> Network -> (Int, Int)
+iterateUntilPartition (h1: h2: t) n = let removed = removeNPaths 3 h1 h2 n
+                                          d1 = getDistances h1 removed
+                                          d2 = getDistances h2 removed
+                                      in if member h2 d1 then iterateUntilPartition (h1: t) n
+                                         else (size d1, size d2)

day25/Main.hs

@@ -0,0 +1,9 @@
+module Main where
+
+import Commons
+import Data.Map (keys)
+
+
+main = do network <- parse
+          let part1Res = iterateUntilPartition (keys network) network
+          print $ uncurry (*) part1Res