Fix output for Day 25

README.md

@@ -1,10 +1,10 @@
 # Advent of Code 2024
-I started learning Haskell very recently, and I just learned this year that Advent of Code is a thing, so I'm using this to practice. I won't be able to solve all problems, but let's see how far I can get.
+I started learning Haskell very recently, and I just learned this year that [Advent of Code](https://adventofcode.com 'Advent of Code website') is a thing, so I used AoC to practice Haskell. I got 38 out of 50 stars, which is more than I though I could get, so I'm quite satisfied. Solutions are not optimal, but most of them run in less than a second, while there are a few that take longer than a minute.
 
 |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 |     |
-|05 |★ ★  |10 |★ ★  |15 |★    |20 |     |25 |     |
+|03 |★ ★  |08 |★ ★  |13 |★ ★  |18 |★ ★  |23 |★    |
+|04 |★ ★  |09 |★ ★  |14 |★ ★  |19 |★    |24 |★    |
+|05 |★ ★  |10 |★ ★  |15 |★    |20 |     |25 |★    |

adventofcode2024.cabal

@@ -53,8 +53,12 @@ executable adventofcode2024
     Day13
     Day14
     Day15
+    Day16
     Day17
     Day18
     Day19
     Day22
+    Day23
+    Day24
+    Day25
     Graph

src/Day01.hs

@@ -1,4 +1,4 @@
-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns -Wno-x-partial #-}
 
 module Day01
   ( day01_1,
@@ -6,15 +6,14 @@ module Day01
   )
 where
 
-import Data.List (group, sort, transpose, uncons)
-import Data.Maybe (fromJust)
+import Data.List (group, sort, transpose)
 
 listDistance :: [Int] -> [Int] -> Int
 listDistance xs ys = sum $ map abs $ zipWith (-) (sort xs) (sort ys)
 
 similarityScore :: [Int] -> [Int] -> Int
 similarityScore xs ys =
-  let elemsY = [(fst . fromJust $ uncons y, length y) | y <- (group . sort) ys]
+  let elemsY = [(head y, length y) | y <- (group . sort) ys]
    in sum [x * snd y | x <- xs, y <- elemsY, x == fst y]
 
 parseInput :: IO [[Int]]

src/Day06.hs

@@ -1,10 +1,12 @@
+{-# OPTIONS_GHC -Wno-x-partial #-}
+
 module Day06
   ( day06_1,
     day06_2,
   )
 where
 
-import Data.List (elemIndex, uncons)
+import Data.List (elemIndex)
 import Data.Maybe (fromJust, fromMaybe, isJust)
 
 type Grid = [String]
@@ -36,7 +38,7 @@ getGridVal :: Position -> Grid -> Char
 getGridVal (x, y) grid = (grid !! x) !! y
 
 isInside :: Position -> Grid -> Bool
-isInside (x, y) grid = x >= 0 && y >= 0 && x < length grid && y < length (fst . fromJust $ uncons grid)
+isInside (x, y) grid = x >= 0 && y >= 0 && x < length grid && y < length (head grid)
 
 getNextPosition :: Position -> Direction -> Grid -> (Position, Direction)
 getNextPosition (x, y) U grid =
@@ -64,12 +66,6 @@ getNextPosition (x, y) L grid =
         then getNextPosition (x, y) U grid
         else (newPos, L)
 
--- markVisited :: Position -> Char -> Grid -> Grid
--- markVisited (x, y) c grid =
---  let row = grid !! x
---      newRow = take y row ++ [c] ++ drop (y + 1) row
---   in take x grid ++ [newRow] ++ drop (x + 1) grid
---
 markVisited :: Position -> Char -> Grid -> Grid
 markVisited (x, y) c grid =
   let gridVal = getGridVal (x, y) grid
@@ -100,14 +96,14 @@ checkGridLoop startPosition direction grid =
 
 setGridObstacles :: Position -> Grid -> [Grid]
 setGridObstacles startPosition grid =
-  let positions = [(x, y) | x <- [0 .. (length grid - 1)], y <- [0 .. (length (fst . fromJust $ uncons grid) - 1)], (x, y) /= startPosition, getGridVal (x, y) grid == 'X']
+  let positions = [(x, y) | x <- [0 .. (length grid - 1)], y <- [0 .. (length (head grid) - 1)], (x, y) /= startPosition, getGridVal (x, y) grid == 'X']
    in zipWith (`markVisited` '#') positions (replicate (length positions) grid)
 
 parseInput :: IO (Int, Int, Direction, [String])
 parseInput = do
   contents <- lines <$> readFile "input/day6.txt"
   let (x, y) =
-        (\a b c d -> fst . fromJust . uncons $ filter ((>= 0) . fst) [a, b, c, d])
+        (\a b c d -> head $ filter ((>= 0) . fst) [a, b, c, d])
           <$> getStartPosition 'v'
           <*> getStartPosition '^'
           <*> getStartPosition '<'

src/Day08.hs

@@ -1,3 +1,5 @@
+{-# OPTIONS_GHC -Wno-x-partial #-}
+
 module Day08
   ( day08_1,
     day08_2,
@@ -6,8 +8,6 @@ where
 
 import Control.Applicative
 import Data.Bifunctor (bimap)
-import Data.List (uncons)
-import Data.Maybe (fromJust)
 import Data.Set (fromList)
 
 type Freq = Char
@@ -66,7 +66,7 @@ parseInput = do
   contents <- lines <$> readFile "input/day8.txt"
   let antennas = getAntennas contents
       x = length contents
-      y = length $ fst . fromJust $ uncons contents
+      y = length $ head contents
   return (x, y, antennas)
 
 day08_1 :: IO ()

src/Day10.hs

@@ -11,30 +11,30 @@ import Graph
 
 type Coords = (Int, Int)
 
-adjacent :: A.Array Coords Int -> 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) - array A.! (i, j) == 1]
+adjacent :: (Num a) => A.Array Coords Int -> Coords -> Coords -> [(Coords, Distance a)]
+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/Day12.hs

@@ -1,10 +1,10 @@
+{-# OPTIONS_GHC -Wno-x-partial #-}
+
 module Day12 (day12_1) where
 
 import Data.Foldable (toList)
 import Data.Graph (Tree, Vertex, graphFromEdges, scc)
-import Data.List (uncons)
 import Data.List.Split (chunksOf)
-import Data.Maybe (fromJust)
 
 type Coords = (Int, Int)
 
@@ -16,12 +16,12 @@ getValue grid (i, j) = grid !! i !! j
 getEdges :: [[V]] -> Coords -> [Int]
 getEdges grid (i, j) =
   let value = fst $ grid !! i !! j
-      adjI = filter (\x -> fst x >= 0 && fst x < length grid && snd x >= 0 && snd x < length (fst . fromJust $ uncons grid)) [(i, j + 1), (i + 1, j), (i, j - 1), (i - 1, j)]
-   in [snd x | x <- map (getValue grid) adjI, (fst . fromJust $ uncons value) == (fst . fromJust $ uncons (fst x))]
+      adjI = filter (\x -> fst x >= 0 && fst x < length grid && snd x >= 0 && snd x < length (head grid)) [(i, j + 1), (i + 1, j), (i, j - 1), (i - 1, j)]
+   in [snd x | x <- map (getValue grid) adjI, head value == head (fst x)]
 
 listVertices :: [String] -> [[V]]
 listVertices grid =
-  let l = length $ fst . fromJust $ uncons grid
+  let l = length $ head grid
    in chunksOf l $ zip (map (: []) (concat grid)) [0 ..]
 
 calculatePerimeter :: (Vertex -> (String, Vertex, [Vertex])) -> Tree Vertex -> Int
@@ -34,7 +34,7 @@ day12_1 :: IO ()
 day12_1 = do
   contents <- lines <$> readFile "input/day12.txt"
   let grid = listVertices contents
-      edgeCoords = [(x, y) | x <- [0 .. length grid - 1], y <- [0 .. length (fst . fromJust $ uncons grid) - 1]]
+      edgeCoords = [(x, y) | x <- [0 .. length grid - 1], y <- [0 .. length (head grid) - 1]]
       edgeList = [(x, y, z) | ((x, y), z) <- zip (concat grid) (map (getEdges grid) edgeCoords)]
       (graph, nodeFromVertex, _) = graphFromEdges edgeList
       plots = scc graph

src/Day13.hs

@@ -1,4 +1,4 @@
-{-# OPTIONS_GHC -Wno-type-defaults #-}
+{-# OPTIONS_GHC -Wno-type-defaults -Wno-x-partial #-}
 
 module Day13
   ( day13_1,
@@ -8,10 +8,9 @@ where
 
 import Data.Char (isDigit)
 import Data.Either (fromRight)
-import Data.List (uncons)
 import Data.List.Split (chunksOf, splitOn)
 import Data.Matrix (Matrix, fromLists, rref, toList, zero)
-import Data.Maybe (fromJust, mapMaybe)
+import Data.Maybe (mapMaybe)
 
 isAlmostInt :: (RealFrac a) => a -> Bool
 isAlmostInt x =
@@ -25,14 +24,14 @@ multRes xs = xs
 getMatrix :: (Read a) => String -> Matrix a
 getMatrix s =
   let nValues = map (map read . splitOn ",") . splitOn ":" . drop 1 $ filter (\x -> isDigit x || x == ',' || x == ':') s
-      eq1 = map (fst . fromJust . uncons) nValues
+      eq1 = map head nValues
       eq2 = map last nValues
    in fromLists [eq1, eq2]
 
 getMatrix' :: (Num a, Read a) => String -> Matrix a
 getMatrix' s =
   let nValues = map (map read . splitOn ",") . splitOn ":" . drop 1 $ filter (\x -> isDigit x || x == ',' || x == ':') s
-      eq1 = multRes $ map (fst . fromJust . uncons) nValues
+      eq1 = multRes $ map head nValues
       eq2 = multRes $ map last nValues
    in fromLists [eq1, eq2]
 

src/Day15.hs

@@ -1,8 +1,8 @@
-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns -Wno-x-partial #-}
 
 module Day15 (day15_1) where
 
-import Data.List (elemIndex, elemIndices, transpose, uncons)
+import Data.List (elemIndex, elemIndices, transpose)
 import Data.List.Split (splitOn)
 import Data.Maybe (fromJust, fromMaybe, isJust)
 
@@ -70,8 +70,8 @@ shiftUp p1 grid =
             then markPosition p1 '.' (markPosition p2 '@' (markPosition p3 'O' grid))
             else
               let column = reverse $ transpose grid !! snd p1
-                  nextDot = fst . fromMaybe (-1, []) $ uncons $ dropWhile (< length column - fst p1) $ elemIndices '.' column
-                  nextHash = fst . fromMaybe (-1, []) $ uncons $ dropWhile (< length column - fst p1) $ elemIndices '#' column
+                  nextDot = head $ dropWhile (< length column - fst p1) $ elemIndices '.' column
+                  nextHash = head $ dropWhile (< length column - fst p1) $ elemIndices '#' column
                in if nextDot == -1 || nextDot > nextHash
                     then grid
                     else markPosition p1 '.' (markPosition p2 '@' (markPosition (length column - 1 - nextDot, snd p1) 'O' grid))
@@ -88,8 +88,8 @@ shiftRight p1 grid =
             then markPosition p1 '.' (markPosition p2 '@' (markPosition p3 'O' grid))
             else
               let row = grid !! fst p1
-                  nextDot = fst . fromMaybe (-1, []) $ uncons $ dropWhile (< snd p1) $ elemIndices '.' row
-                  nextHash = fst . fromMaybe (-1, []) $ uncons $ dropWhile (< snd p1) $ elemIndices '#' row
+                  nextDot = head $ dropWhile (< snd p1) $ elemIndices '.' row
+                  nextHash = head $ dropWhile (< snd p1) $ elemIndices '#' row
                in if nextDot == -1 || nextDot > nextHash
                     then grid
                     else markPosition p1 '.' (markPosition p2 '@' (markPosition (fst p1, nextDot) 'O' grid))
@@ -106,8 +106,8 @@ shiftDown p1 grid =
             then markPosition p1 '.' (markPosition p2 '@' (markPosition p3 'O' grid))
             else
               let column = transpose grid !! snd p1
-                  nextDot = fst . fromMaybe (-1, []) $ uncons $ dropWhile (< fst p1) $ elemIndices '.' column
-                  nextHash = fst . fromMaybe (-1, []) $ uncons $ dropWhile (< fst p1) $ elemIndices '#' column
+                  nextDot = head $ dropWhile (< fst p1) $ elemIndices '.' column
+                  nextHash = head $ dropWhile (< fst p1) $ elemIndices '#' column
                in if nextDot == -1 || nextDot > nextHash
                     then grid
                     else markPosition p1 '.' (markPosition p2 '@' (markPosition (nextDot, snd p1) 'O' grid))
@@ -124,8 +124,8 @@ shiftLeft p1 grid =
             then markPosition p1 '.' (markPosition p2 '@' (markPosition p3 'O' grid))
             else
               let row = reverse $ grid !! fst p1
-                  nextDot = fst . fromMaybe (-1, []) $ uncons $ dropWhile (< length row - snd p1) $ elemIndices '.' row
-                  nextHash = fst . fromMaybe (-1, []) $ uncons $ dropWhile (< length row - snd p1) $ elemIndices '#' row
+                  nextDot = head $ dropWhile (< length row - snd p1) $ elemIndices '.' row
+                  nextHash = head $ dropWhile (< length row - snd p1) $ elemIndices '#' row
                in if nextDot == -1 || nextDot > nextHash
                     then grid
                     else markPosition p1 '.' (markPosition p2 '@' (markPosition (fst p1, length row - 1 - nextDot) 'O' grid))
@@ -195,7 +195,7 @@ gpsCoords (x, y) = 100 * x + y
 
 boxCoords :: Grid -> [Int]
 boxCoords grid =
-  let coords = [(x, y) | x <- [0 .. length grid - 1], y <- [0 .. length (fst . fromJust $ uncons grid) - 1], getGridVal (x, y) grid == 'O']
+  let coords = [(x, y) | x <- [0 .. length grid - 1], y <- [0 .. length (head grid) - 1], getGridVal (x, y) grid == 'O']
    in map gpsCoords coords
 
 day15_1 :: IO ()

src/Day16.hs

@@ -0,0 +1,53 @@
+{-# LANGUAGE DeriveGeneric #-}
+
+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 (minimum shortestPaths)

src/Day17.hs

@@ -1,14 +1,11 @@
-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
-{-# OPTIONS_GHC -Wno-type-defaults #-}
+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns -Wno-type-defaults -Wno-x-partial #-}
 
 module Day17 (day17_1, day17_2) where
 
 import Control.Monad.State
 import Data.Bits
 import Data.Char (isDigit)
-import Data.List (uncons)
 import Data.List.Split (splitOn)
-import Data.Maybe (fromJust)
 
 type Program = [Int]
 
@@ -132,7 +129,7 @@ parseInput = do
 day17_1 :: IO ()
 day17_1 = do
   (registers, prog) <- parseInput
-  let computer = Computer {registerA = fst . fromJust $ uncons registers, registerB = registers !! 1, registerC = registers !! 2, pointer = 0, program = prog, output = ""}
+  let computer = Computer {registerA = head registers, registerB = registers !! 1, registerC = registers !! 2, pointer = 0, program = prog, output = ""}
   putStr "Day 17, Puzzle 1 solution: "
   print . drop 1 . output $ execState runProgram computer
 
@@ -143,4 +140,4 @@ day17_2 = do
       regA = [805464 * 2 ^ 27 ..] -- Threshold derived empirically, a better threshold must be possible because this is very slow, but got the correct answer.
   putStrLn $
     "Day 17, Puzzle 2 solution: "
-      ++ show (fst . fromJust . uncons $ dropWhile (\x -> not (checkIfCreatesCopy computer {registerA = x})) regA)
+      ++ show (head $ dropWhile (\x -> not (checkIfCreatesCopy computer {registerA = x})) regA)

src/Day18.hs

@@ -13,8 +13,8 @@ import Graph
 
 type Coords = (Int, Int)
 
-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) /= '#']
+adjacent :: (Num a) => A.Array Coords Char -> Coords -> Coords -> [(Coords, Distance a)]
+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/Day23.hs

@@ -0,0 +1,40 @@
+module Day23 (day23_1) where
+
+import Control.Monad
+import Data.Containers.ListUtils (nubOrd)
+import Data.List (nub, sort)
+import Data.List.Split (splitOn)
+
+startsWithT :: String -> Bool
+startsWithT [] = False
+startsWithT (x : _)
+  | x == 't' = True
+  | otherwise = False
+
+getConns3 :: [[String]] -> [[String]]
+getConns3 connections = do
+  conn1 <- connections
+  conn2 <- connections
+
+  guard $
+    conn1 /= conn2
+      && length (nub (conn1 ++ conn2)) == 3
+      && any startsWithT (conn1 ++ conn2)
+
+  conn3 <- connections
+
+  guard $
+    conn1 /= conn3
+      && conn2 /= conn3
+      && length (nub (conn1 ++ conn2 ++ conn3)) == 3
+      && any startsWithT (conn1 ++ conn2 ++ conn3)
+
+  return . nub $ conn1 ++ conn2 ++ conn3
+
+day23_1 :: IO ()
+day23_1 = do
+  contents <- lines <$> readFile "input/day23.txt"
+  let connections = map (splitOn "-") contents
+  putStrLn $
+    "Day 23, Puzzle 1 solution: "
+      ++ show (length . nubOrd . map sort $ getConns3 connections)

src/Day24.hs

@@ -0,0 +1,34 @@
+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
+
+module Day24 (day24_1) where
+
+import Data.Bits
+import qualified Data.HashMap.Strict as M
+import Data.List (sort)
+import Data.List.Split (splitOn)
+
+getWireValue :: String -> M.HashMap String (Maybe Int) -> M.HashMap String String -> Int
+getWireValue w wm cm =
+  case wm M.! w of
+    Just x -> x
+    Nothing ->
+      let (w1 : op : w2 : _) = words $ cm M.! w
+       in if op == "AND"
+            then getWireValue w1 wm cm .&. getWireValue w2 wm cm
+            else
+              if op == "OR"
+                then getWireValue w1 wm cm .|. getWireValue w2 wm cm
+                else getWireValue w1 wm cm `xor` getWireValue w2 wm cm
+
+toDecimal :: [Int] -> Int
+toDecimal n = sum $ zipWith (*) n (iterate (*2) 1)
+
+day24_1 :: IO ()
+day24_1 = do
+  [inputs, connections] <- splitOn [""] . lines <$> readFile "input/day24.txt"
+  let inputsList = [(i, Just (read v)) | [i, v] <- map (splitOn ": ") inputs]
+      wireConnections = [(w, c) | [c, w] <- map (splitOn " -> ") connections]
+      connectionsMap = M.fromList wireConnections
+      wiresMap = M.fromList $ [(fst wc, Nothing) | wc <- wireConnections] ++ inputsList
+      outputs = map (\x -> getWireValue x wiresMap connectionsMap) (filter (\(x : _) -> x == 'z') . sort $ M.keys wiresMap)
+  putStrLn $ "Day 24, Puzzle 1 solution: " ++ show (toDecimal outputs)

src/Day25.hs

@@ -0,0 +1,31 @@
+{-# OPTIONS_GHC -Wno-x-partial #-}
+
+module Day25 (day25_1) where
+
+import Control.Monad (guard)
+import Data.List (transpose)
+import Data.List.Split (splitOn)
+
+parseSchematics :: [String] -> [Int]
+parseSchematics s =
+  let s' = transpose . init $ tail s
+   in map (length . filter (== '#')) s'
+
+keyLockCombinations :: [[Int]] -> [[Int]] -> [[Int]]
+keyLockCombinations keys locks = do
+  key <- keys
+  lock <- locks
+
+  guard $ all (< 6) $ zipWith (+) key lock
+
+  return $ zipWith (+) key lock
+
+day25_1 :: IO ()
+day25_1 = do
+  contents <- lines <$> readFile "input/day25.txt"
+  let schematics = splitOn [""] contents
+      locks = map parseSchematics $ filter (\x -> head x == "#####" && last x == ".....") schematics
+      keys = map parseSchematics $ filter (\x -> head x == "....." && last x == "#####") schematics
+  putStrLn $
+    "Day 25, Puzzle 1 solution: "
+      ++ show (length $ keyLockCombinations keys locks)

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,10 +15,14 @@ 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)
 import Day22 (day22_1)
+import Day23 (day23_1)
+import Day24 (day24_1)
+import Day25 (day25_1)
 import System.Environment (getArgs)
 
 main :: IO ()
@@ -92,6 +96,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
@@ -104,4 +109,46 @@ main = do
       day18_2
     "19" : "1" : _ -> day19_1
     "22" : "1" : _ -> day22_1
+    "23" : "1" : _ -> day23_1
+    "24" : "1" : _ -> day24_1
+    "25" : "1" : _ -> day25_1
+    "all" : _ -> do
+      day01_1
+      day01_2
+      day02_1
+      day02_2
+      day03_1
+      day03_2
+      day04_1
+      day04_2
+      day05_1
+      day05_2
+      day06_1
+      day06_2
+      day07_1
+      day07_2
+      day08_1
+      day08_2
+      day09_1
+      day09_2
+      day10_1
+      day10_2
+      day11_1
+      day11_2
+      day12_1
+      day13_1
+      day13_2
+      day14_1
+      day14_2
+      day15_1
+      day16_1
+      day17_1
+      day17_2
+      day18_1
+      day18_2
+      day19_1
+      day22_1
+      day23_1
+      day24_1
+      day25_1
     _ -> error "Not implemented"