fuxino/AdventOfCode2024
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Day 18, Part 2 (very slow)

Browse Source
This commit is contained in:
daniele 2024-12-19 10:10:28 +01:00
parent 0176c6b5df
commit d77f1fdefe
Signed by: fuxino
GPG Key ID: 981A2B2A3BBF5514
4 changed files with 106 additions and 18 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
adventofcode2024.cabal
View File

@ -64,3 +64,4 @@ executable adventofcode2024
Day15.Puzzle1
Day17.Puzzle1
Day18.Puzzle1
Day18.Puzzle2

35
src/Day18/Puzzle1.hs
View File

@ -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))

86
src/Day18/Puzzle2.hs Normal file
View File

@ -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))

2
src/Main.hs
View File

@ -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"