Day 16, Part 1

README.md

@@ -3,7 +3,7 @@ I started learning Haskell very recently, and I just learned this year that Adve
 
 |Day|Stars|Day|Stars|Day|Stars|Day|Stars|Day|Stars|
 |---|-----|---|-----|---|-----|---|-----|---|-----|
-|01 |★ ★  |06 |★ ★  |11 |★ ★  |16 |     |21 |     |
+|01 |★ ★  |06 |★ ★  |11 |★ ★  |16 |★    |21 |     |
 |02 |★ ★  |07 |★ ★  |12 |★    |17 |★ ★  |22 |★    |
 |03 |★ ★  |08 |★ ★  |13 |★ ★  |18 |★ ★  |23 |     |
 |04 |★ ★  |09 |★ ★  |14 |★ ★  |19 |★    |24 |     |

adventofcode2024.cabal

@@ -53,6 +53,7 @@ executable adventofcode2024
     Day13
     Day14
     Day15
+    Day16
     Day17
     Day18
     Day19

src/Day10.hs

@@ -11,30 +11,30 @@ import Graph
 
 type Coords = (Int, Int)
 
-adjacent :: A.Array Coords Int -> Coords -> Coords -> [Coords]
+adjacent :: (Num a) => A.Array Coords Int -> Coords -> Coords -> [(Coords, Distance a)]
-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) - array A.! (i, j) == 1]
+adjacent array (i, j) (maxI, maxJ) = [((a, b), Dist 1) | (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) - array A.! (i, j) == 1]
 
-findAllPaths :: Graph Coords -> Coords -> Coords -> [Coords] -> [[Coords]]
+findAllPaths :: Graph Coords Int -> Coords -> Coords -> [Coords] -> [[Coords]]
 findAllPaths graph start end path = do
-  node <- edges graph M.! start
+  node <- fst <$> edges graph M.! start
   let path' = path ++ [node]
   if node == end
     then return path'
     else findAllPaths graph node end path'
 
+getTrailGraph :: A.Array Coords Int -> (Graph Coords Int, [Coords], [Coords])
+getTrailGraph trailMap =
+  let trailGraph = Graph {edges = M.fromList [(k, adjacent trailMap k (52, 52)) | k <- A.indices trailMap]}
+      startList = map fst . filter (\(_, y) -> y == 0) $ A.assocs trailMap
+      endList = map fst . filter (\(_, y) -> y == 9) $ A.assocs trailMap
+   in (trailGraph, startList, endList)
+
 parseInput :: IO (A.Array (Int, Int) Int)
 parseInput = do
   contents <- lines <$> readFile "input/day10.txt"
   let trailMap = A.listArray ((0, 0), (52, 52)) . map digitToInt $ concat contents
   return trailMap
 
-getTrailGraph :: A.Array Coords Int -> (Graph Coords, [Coords], [Coords])
-getTrailGraph trailMap =
-  let trailGraph = Graph {edges = M.fromList [(k, adjacent trailMap k (52, 52)) | k <- A.indices trailMap]}
-      startList = map fst . filter (\(_, y) -> y == 0) $ A.assocs trailMap
-      endList = map fst . filter (\(_, y) -> y == 9) $ A.assocs trailMap
-   in (trailGraph, startList, endList)
-
 day10_1 :: IO ()
 day10_1 = do
   trailMap <- parseInput

src/Day16.hs

@@ -0,0 +1,55 @@
+{-# LANGUAGE DeriveGeneric #-}
+{-# OPTIONS_GHC -Wno-incomplete-patterns -Wno-type-defaults #-}
+
+module Day16 (day16_1) where
+
+import qualified Data.Array as A
+import qualified Data.HashMap.Strict as M
+import Data.Hashable
+import Data.Ix
+import GHC.Generics (Generic)
+import Graph
+
+data Direction = N | S | E | W deriving (Eq, Ord, Generic, Ix)
+
+instance Hashable Direction
+
+type Coords = (Int, Int, Direction)
+
+getCost :: Direction -> Direction -> Int
+getCost a b
+  | a == b = 1
+  | otherwise = 1000
+
+adjacent :: A.Array Coords Char -> Coords -> (Int, Int) -> [(Coords, Distance Int)]
+adjacent array (i, j, N) (maxI, maxJ) =
+  [((a, b, d), Dist (getCost N d)) | i >= 0, j >= 0, i <= maxI, j <= maxJ, (a, b, d) <- [(i - 1, j, N), (i, j, W), (i, j, E)], array A.! (i, j, d) /= '#']
+adjacent array (i, j, S) (maxI, maxJ) =
+  [((a, b, d), Dist (getCost S d)) | i >= 0, j >= 0, i <= maxI, j <= maxJ, (a, b, d) <- [(i + 1, j, S), (i, j, W), (i, j, E)], array A.! (i, j, d) /= '#']
+adjacent array (i, j, E) (maxI, maxJ) =
+  [((a, b, d), Dist (getCost E d)) | i >= 0, j >= 0, i <= maxI, j <= maxJ, (a, b, d) <- [(i, j + 1, E), (i, j, N), (i, j, S)], array A.! (i, j, d) /= '#']
+adjacent array (i, j, W) (maxI, maxJ) =
+  [((a, b, d), Dist (getCost W d)) | i >= 0, j >= 0, i <= maxI, j <= maxJ, (a, b, d) <- [(i, j - 1, W), (i, j, N), (i, j, S)], array A.! (i, j, d) /= '#']
+
+getMazeGraph :: A.Array Coords Char -> Int -> Int -> (Graph Coords Int, Coords, [Coords])
+getMazeGraph mazeMap nRow nCol =
+  let mazeGraph = Graph {edges = M.fromList [(k, adjacent mazeMap k (nRow, nCol)) | k <- A.indices mazeMap]}
+      start = fst . last . filter (\((_, _, d), c) -> d == E && c == 'S') $ A.assocs mazeMap
+      end = map fst $ filter (\(_, c) -> c == 'E') $ A.assocs mazeMap
+   in (mazeGraph, start, end)
+
+parseInput :: IO (A.Array (Int, Int, Direction) Char, Int, Int)
+parseInput = do
+  contents <- lines <$> readFile "input/day16.txt"
+  let nRow = length contents - 1
+      nCol = length (last contents) - 1
+      mazeMap = A.listArray ((0, 0, N), (nRow, nCol, W)) (concatMap (replicate 4) $ concat contents)
+  return (mazeMap, nRow, nCol)
+
+day16_1 :: IO ()
+day16_1 = do
+  (mazeMap, nRow, nCol) <- parseInput
+  let (mazeGraph, start, end) = getMazeGraph mazeMap nRow nCol
+      shortestPaths = [findShortestPath mazeGraph start e | e <- end]
+  --  putStrLn $ "Day 16, Puzzle 1 solution: " ++ show (findShortestPath mazeGraph start end)
+  putStrLn $ "Day 16, Puzzle 1 solution: " ++ show (minimum shortestPaths)

src/Day18.hs

@@ -13,8 +13,8 @@ import Graph
 
 type Coords = (Int, Int)
 
-adjacent :: A.Array Coords Char -> Coords -> Coords -> [Coords]
+adjacent :: (Num a) => A.Array Coords Char -> Coords -> Coords -> [(Coords, Distance a)]
-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) /= '#']
+adjacent array (i, j) (maxI, maxJ) = [((a, b), Dist 1) | (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, '#')])
@@ -32,7 +32,7 @@ getCorruptedMemoryMap fallingBytes =
   let memory = A.listArray ((0, 0), (70, 70)) $ replicate 5041 '.'
       bytesCoords = take 1024 [(read x, read y) | (x : y : _) <- fallingBytes]
       corruptedMemory = corruptMemory memory bytesCoords
-  in corruptedMemory
+   in corruptedMemory
 
 day18_1 :: IO ()
 day18_1 = do

src/Graph.hs

@@ -10,8 +10,6 @@ import Data.Hashable (Hashable)
 import Data.Maybe (fromJust)
 import qualified Data.PSQueue as PQ
 
-newtype Graph a = Graph {edges :: M.HashMap a [a]} deriving (Show)
-
 data Distance a = Dist a | Infinity deriving (Eq)
 
 instance (Ord a) => Ord (Distance a) where
@@ -24,6 +22,8 @@ instance (Show a) => Show (Distance a) where
   show Infinity = "Infinity"
   show (Dist x) = show x
 
+newtype Graph a b = Graph {edges :: M.HashMap a [(a, Distance b)]} deriving (Show)
+
 addDistance :: (Num a) => Distance a -> Distance a -> Distance a
 addDistance (Dist x) (Dist y) = Dist (x + y)
 addDistance _ _ = Infinity
@@ -33,23 +33,26 @@ data DijkstraState a b = DijkstraState
     distances :: M.HashMap a (Distance b)
   }
 
-updateDistances :: (Hashable a) => M.HashMap a (Distance b) -> [a] -> Distance b -> M.HashMap a (Distance b)
+updateDistances :: (Hashable a, Num b) => M.HashMap a (Distance b) -> [(a, Distance b)] -> Distance b -> M.HashMap a (Distance b)
 updateDistances dists [] _ = dists
 updateDistances dists (n : nodes) startD =
-  updateDistances (M.adjust (const startD) n dists) nodes startD
+  let newD = addDistance startD (snd n)
+   in updateDistances (M.adjust (const newD) (fst n) dists) nodes startD
 
-visit :: (Ord a, Ord b) => PQ.PSQ a (Distance b) -> a -> [a] -> Distance b -> PQ.PSQ a (Distance b)
+visit :: (Ord a, Num b, Ord b) => PQ.PSQ a (Distance b) -> a -> [(a, Distance b)] -> Distance b -> PQ.PSQ a (Distance b)
 visit us node [] _ = PQ.delete node us
-visit us node (e : es) dist = visit (PQ.adjust (const dist) e us) node es dist
+visit us node (e : es) startD =
+  let newD = addDistance startD (snd e)
+   in visit (PQ.adjust (const newD) (fst e) us) node es startD
 
-visitNode :: (Hashable a, Ord a, Ord b) => DijkstraState a b -> Graph a -> a -> Distance b -> DijkstraState a b
+visitNode :: (Hashable a, Ord a, Num b, Ord b) => DijkstraState a b -> Graph a b -> a -> Distance b -> DijkstraState a b
 visitNode state graph node d =
   let es = edges graph M.! node
       ds = updateDistances (distances state) es d
       us = visit (unvisited state) node es d
    in state {unvisited = us, distances = ds}
 
-findShortestPath :: (Hashable a, Ord a, Ord b, Num b) => Graph a -> a -> a -> Distance b
+findShortestPath :: (Hashable a, Ord a, Ord b, Num b) => Graph a b -> a -> a -> Distance b
 findShortestPath graph start end =
   let nodesDist = (start PQ.:-> Dist 0) : [k PQ.:-> Infinity | k <- M.keys $ edges graph, k /= start]
       dists = (start, Dist 0) : [(k, Infinity) | k <- M.keys $ edges graph, k /= start]
@@ -65,4 +68,4 @@ findShortestPath graph start end =
             else
               if d == Infinity
                 then Infinity
-                else dijkstra $ visitNode s graph n (addDistance d (Dist 1))
+                else dijkstra $ visitNode s graph n d

src/Main.hs

@@ -15,6 +15,7 @@ import Day12 (day12_1)
 import Day13 (day13_1, day13_2)
 import Day14 (day14_1, day14_2)
 import Day15 (day15_1)
+import Day16 (day16_1)
 import Day17 (day17_1, day17_2)
 import Day18 (day18_1, day18_2)
 import Day19 (day19_1)
@@ -92,6 +93,7 @@ main = do
       day14_1
       day14_2
     "15" : "1" : _ -> day15_1
+    "16" : "1" : _ -> day16_1
     "17" : "1" : _ -> day17_1
     "17" : "2" : _ -> day17_2
     "17" : _ -> do