diff --git a/adventofcode2024.cabal b/adventofcode2024.cabal index 2bf8d99..836c9ed 100644 --- a/adventofcode2024.cabal +++ b/adventofcode2024.cabal @@ -64,3 +64,4 @@ executable adventofcode2024 Day15.Puzzle1 Day17.Puzzle1 Day18.Puzzle1 + Day18.Puzzle2 diff --git a/src/Day18/Puzzle1.hs b/src/Day18/Puzzle1.hs index 708bb09..803a510 100644 --- a/src/Day18/Puzzle1.hs +++ b/src/Day18/Puzzle1.hs @@ -1,6 +1,6 @@ module Day18.Puzzle1 (day18_1) where -import Data.Array (Array, indices, listArray, (!), (//)) +import qualified Data.Array as A import Data.Function (on) import Data.List (minimumBy) import Data.List.Split (splitOn) @@ -23,22 +23,16 @@ instance (Show a) => Show (Distance a) where show Infinity = "Infinity" show (Dist x) = show x +addDistance :: (Num a) => Distance a -> Distance a -> Distance a +addDistance (Dist x) (Dist y) = Dist (x + y) +addDistance _ _ = Infinity + data DijkstraState = DijkstraState { unvisited :: S.Set Coords, distances :: M.Map Coords (Distance Int) } deriving (Show) -addDistance :: (Num a) => Distance a -> Distance a -> Distance a -addDistance (Dist x) (Dist y) = Dist (x + y) -addDistance _ _ = Infinity - -corruptMemory :: Array Coords Char -> [Coords] -> Array Coords Char -corruptMemory = foldl (\a b -> a // [(b, '#')]) - -adjacent :: Array Coords Char -> Coords -> Coords -> [Coords] -adjacent array (i, j) (maxI, maxJ) = [(a, b) | (a, b) <- [(i, j + 1), (i, j - 1), (i + 1, j), (i - 1, j)], a >= 0, b >= 0, a <= maxI, b <= maxJ, array ! (a, b) /= '#'] - initDijkstraState :: Coords -> Graph -> DijkstraState initDijkstraState start g = let s = @@ -50,13 +44,12 @@ initDijkstraState start g = updateDistances :: Graph -> M.Map Coords (Distance Int) -> [Coords] -> Distance Int -> M.Map Coords (Distance Int) updateDistances _ dists [] _ = dists -updateDistances graph dists (n:nodes) startD = - updateDistances graph (M.adjust (const (addDistance startD (Dist 1))) n dists) nodes startD +updateDistances graph dists (n : nodes) startD = + updateDistances graph (M.adjust (const (addDistance startD (Dist 1))) n dists) nodes startD findShortestPath :: Graph -> DijkstraState -> Coords -> Coords -> Distance Int findShortestPath graph state start end | start == end = distances state M.! end - | S.null (unvisited state) = distances state M.! end | distances state M.! start == Infinity = Infinity | otherwise = let newState = @@ -68,12 +61,18 @@ findShortestPath graph state start end next = fst $ minimumBy (compare `on` snd) [(n, distances newState M.! n) | n <- nodes] in findShortestPath graph newState next end +adjacent :: A.Array Coords Char -> Coords -> Coords -> [Coords] +adjacent array (i, j) (maxI, maxJ) = [(a, b) | (a, b) <- [(i, j + 1), (i, j - 1), (i + 1, j), (i - 1, j)], a >= 0, b >= 0, a <= maxI, b <= maxJ, array A.! (a, b) /= '#'] + +corruptMemory :: A.Array Coords Char -> [Coords] -> A.Array Coords Char +corruptMemory = foldl (\a b -> a A.// [(b, '#')]) + day18_1 :: IO () day18_1 = do contents <- map (splitOn ",") . lines <$> readFile "input/day18.txt" - let memory = listArray ((0, 0), (70, 70)) $ replicate 5041 '.' + let memory = A.listArray ((0, 0), (70, 70)) $ replicate 5041 '.' coords = take 1024 [(read x, read y) | (x : y : _) <- contents] memory' = corruptMemory memory coords - memoryMap = Graph {edges = M.fromList [(k, adjacent memory' k (70, 70)) | k <- indices memory']} - state = initDijkstraState (0, 0) memoryMap - putStrLn $ "Day 18, Puzzle 1 solution: " ++ show (findShortestPath memoryMap state (0, 0) (70, 70)) + memoryGraph = Graph {edges = M.fromList [(k, adjacent memory' k (70, 70)) | k <- A.indices memory']} + state = initDijkstraState (0, 0) memoryGraph + putStrLn $ "Day 18, Puzzle 1 solution: " ++ show (findShortestPath memoryGraph state (0, 0) (70, 70)) diff --git a/src/Day18/Puzzle2.hs b/src/Day18/Puzzle2.hs new file mode 100644 index 0000000..6b3fc90 --- /dev/null +++ b/src/Day18/Puzzle2.hs @@ -0,0 +1,86 @@ +module Day18.Puzzle2 (day18_2) where + +import qualified Data.Array as A +import Data.Function (on) +import Data.List (minimumBy) +import Data.List.Split (splitOn) +import qualified Data.Map.Strict as M +import qualified Data.Set as S + +type Coords = (Int, Int) + +newtype Graph = Graph {edges :: M.Map Coords [Coords]} deriving (Show) + +data Distance a = Dist a | Infinity deriving (Eq) + +instance (Ord a) => Ord (Distance a) where + Infinity <= Infinity = True + Infinity <= Dist _ = False + Dist _ <= Infinity = True + Dist x <= Dist y = x <= y + +instance (Show a) => Show (Distance a) where + show Infinity = "Infinity" + show (Dist x) = show x + +addDistance :: (Num a) => Distance a -> Distance a -> Distance a +addDistance (Dist x) (Dist y) = Dist (x + y) +addDistance _ _ = Infinity + +data DijkstraState = DijkstraState + { unvisited :: S.Set Coords, + distances :: M.Map Coords (Distance Int) + } + deriving (Show) + +initDijkstraState :: Coords -> Graph -> DijkstraState +initDijkstraState start g = + let s = + DijkstraState + { unvisited = S.fromList . M.keys $ edges g, + distances = M.fromList $ zip (M.keys $ edges g) (repeat Infinity) + } + in s {distances = M.adjust (const (Dist 0)) start (distances s)} + +updateDistances :: Graph -> M.Map Coords (Distance Int) -> [Coords] -> Distance Int -> M.Map Coords (Distance Int) +updateDistances _ dists [] _ = dists +updateDistances graph dists (n : nodes) startD = + updateDistances graph (M.adjust (const (addDistance startD (Dist 1))) n dists) nodes startD + +findShortestPath :: Graph -> DijkstraState -> Coords -> Coords -> Distance Int +findShortestPath graph state start end + | start == end = distances state M.! end + | distances state M.! start == Infinity = Infinity + | otherwise = + let newState = + state + { unvisited = S.delete start (unvisited state), + distances = updateDistances graph (distances state) (edges graph M.! start) (distances state M.! start) + } + nodes = S.toList $ unvisited newState + next = fst $ minimumBy (compare `on` snd) [(n, distances newState M.! n) | n <- nodes] + in findShortestPath graph newState next end + +adjacent :: A.Array Coords Char -> Coords -> Coords -> [Coords] +adjacent array (i, j) (maxI, maxJ) = [(a, b) | (a, b) <- [(i, j + 1), (i, j - 1), (i + 1, j), (i - 1, j)], a >= 0, b >= 0, a <= maxI, b <= maxJ, array A.! (a, b) /= '#'] + +corruptMemory :: A.Array Coords Char -> [Coords] -> A.Array Coords Char +corruptMemory = foldl (\a b -> a A.// [(b, '#')]) + +findFirstBlocker :: A.Array Coords Char -> [Coords] -> Coords -> Coords -> Coords +findFirstBlocker memory (c:cs) start end = + let memory' = corruptMemory memory [c] + memoryGraph = Graph {edges = M.fromList [(k, adjacent memory' k (70, 70)) | k <- A.indices memory']} + state = initDijkstraState (0, 0) memoryGraph + in if findShortestPath memoryGraph state start end == Infinity + then c + else findFirstBlocker memory' cs start end + +day18_2 :: IO () +day18_2 = do + contents <- map (splitOn ",") . lines <$> readFile "input/day18.txt" + let memory = A.listArray ((0, 0), (70, 70)) $ replicate 5041 '.' + coords = take 1024 [(read x, read y) | (x : y : _) <- contents] + coords' = drop 1024 [(read x, read y) | (x : y : _) <- contents] + memory' = corruptMemory memory coords + putStrLn $ "Day 18, Puzzle 2 solution: " ++ show (findFirstBlocker memory' coords' (0, 0) (70, 70)) diff --git a/src/Main.hs b/src/Main.hs index af16dd4..f10130c 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -29,6 +29,7 @@ import Day14.Puzzle2 import Day15.Puzzle1 import Day17.Puzzle1 import Day18.Puzzle1 +import Day18.Puzzle2 import System.Environment (getArgs) main :: IO () @@ -64,4 +65,5 @@ main = do "15" : "1" : _ -> day15_1 "17" : "1" : _ -> day17_1 "18" : "1" : _ -> day18_1 + "18" : "2" : _ -> day18_2 _ -> error "Not implemented"