day 24: no more manual :)

Signed-off-by: Amneesh Singh <natto@weirdnatto.in>

aoc2024.cabal

@@ -24,66 +24,66 @@ library libaoc
   hs-source-dirs:  lib
   exposed-modules: AoC
 
-executable day1
+executable day01
   import:         common
   hs-source-dirs: src
-  main-is:        Day1.hs
+  main-is:        Day01.hs
   build-depends:  libaoc
 
-executable day2
+executable day02
   import:         common
   hs-source-dirs: src
-  main-is:        Day2.hs
+  main-is:        Day02.hs
   build-depends:  libaoc
 
-executable day3
+executable day03
   import:         common
   hs-source-dirs: src
-  main-is:        Day3.hs
+  main-is:        Day03.hs
   build-depends:  libaoc
 
-executable day4
+executable day04
   import:         common
   hs-source-dirs: src
-  main-is:        Day4.hs
+  main-is:        Day04.hs
   build-depends:  libaoc
 
-executable day4alt
+executable day04alt
   import:         common
   hs-source-dirs: src
-  main-is:        Day4Alt.hs
+  main-is:        Day04Alt.hs
   build-depends:  libaoc
 
-executable day5
+executable day05
   import:         common
   hs-source-dirs: src
-  main-is:        Day5.hs
+  main-is:        Day05.hs
   build-depends:
     , containers
     , libaoc
 
-executable day6
+executable day06
   import:         common
   hs-source-dirs: src
-  main-is:        Day6.hs
+  main-is:        Day06.hs
   build-depends:  containers
 
-executable day7
+executable day07
   import:         common
   hs-source-dirs: src
-  main-is:        Day7.hs
+  main-is:        Day07.hs
   build-depends:  libaoc
 
-executable day8
+executable day08
   import:         common
   hs-source-dirs: src
-  main-is:        Day8.hs
+  main-is:        Day08.hs
   build-depends:  containers
 
-executable day9
+executable day09
   import:         common
   hs-source-dirs: src
-  main-is:        Day9.hs
+  main-is:        Day09.hs
   build-depends:  containers
 
 executable day10
@@ -152,3 +152,40 @@ executable day19
     , array
     , containers
     , libaoc
+
+executable day20
+  import:         common
+  hs-source-dirs: src
+  main-is:        Day20.hs
+  build-depends:  containers
+
+executable day21
+  import:         common
+  hs-source-dirs: src
+  main-is:        Day21.hs
+  build-depends:  containers
+
+executable day22
+  import:         common
+  hs-source-dirs: src
+  main-is:        Day22.hs
+  build-depends:  containers
+
+executable day23
+  import:         common
+  hs-source-dirs: src
+  main-is:        Day23.hs
+  build-depends:  containers
+
+executable day24
+  import:         common
+  hs-source-dirs: src
+  main-is:        Day24.hs
+  build-depends:
+    , containers
+    , libaoc
+
+executable day25
+  import:         common
+  hs-source-dirs: src
+  main-is:        Day25.hs

fetch.sh

@@ -0,0 +1,38 @@
+#!/usr/bin/env bash
+
+SOURCE_DIR=$(realpath "$(dirname "$0")")
+INPUT_DIR=${INPUT_DIR:="$SOURCE_DIR/inputs"}
+
+help () {
+  echo "usage:   $0 <day1-day25>"
+  echo "example: $0 day15"
+  echo "         $0 15"
+  echo "         $0 all"
+}
+
+fetch () {
+  TMPFILE=$(mktemp)
+  curl "https://adventofcode.com/2024/day/${1}/input"          \
+    -s --fail-with-body --cookie "session=$AOC_SESSION"            \
+    -o "${TMPFILE}"
+
+  mkdir -p "$INPUT_DIR"
+  mv "$TMPFILE" "$INPUT_DIR/day${1}.in"
+  echo "Fetched Day $1"
+}
+
+if [[ $# != 1 || ! "${1#day}" =~ ^([1-9]|1[0-9]|2[0-5]|all)$ ]]; then
+  help
+  exit 1
+fi
+
+if [[ -z "${AOC_SESSION}" ]]; then
+  echo "\$AOC_SESSION is not set"
+  exit 1
+fi
+
+if [[ $1 == "all" ]]; then
+    for x in {1..25}; do fetch "$x"; done
+else
+    fetch "${1#day}"
+fi

flake.nix

@@ -27,6 +27,15 @@
         };
 
         packages.default = self'.packages.aoc2024;
+        apps =
+          let
+            name = n: "day${(if n < 10 then "0" else "" ) + toString n}";
+          in
+          with pkgs.lib; genAttrs (map name (range 1 25))
+            (n: {
+              type = "app";
+              program = "${self'.packages.aoc2024}/bin/${n}";
+            });
       };
     };
 }

src/Day20.hs

@@ -0,0 +1,56 @@
+module Main where
+
+import qualified Data.IntMap as IM
+import qualified Data.Map as M
+
+type Coord = (Int, Int)
+
+type Grid = M.Map Coord Char
+
+type Path = IM.IntMap Coord
+
+manhattan :: Coord -> Coord -> Int
+manhattan (x1, y1) (x2, y2) = abs (x2 - x1) + abs (y2 - y1)
+
+neighbours :: Coord -> [Coord]
+neighbours (x, y) = [(x - 1, y), (x + 1, y), (x, y - 1), (x, y + 1)]
+
+race :: Grid -> Coord -> Path
+race grid = IM.fromList . zip [0 ..] . path (-1, -1)
+  where
+    path :: Coord -> Coord -> [Coord]
+    path prev c = case ch of
+      'E' -> [c, next]
+      '.' -> c : path c next
+      where
+        [(next, ch)] =
+          [ (n, ch)
+            | n <- neighbours c,
+              n /= prev,
+              let Just ch = n `M.lookup` grid,
+              ch /= '#'
+          ]
+
+nCheats :: Path -> Int -> Int
+nCheats path n =
+  let l = IM.size path
+   in length
+        [ ()
+          | i <- [0 .. l - 1],
+            j <- [i + 100 .. l - 1],
+            let d = manhattan (path IM.! i) (path IM.! j),
+            d <= n,
+            100 <= j - i - d
+        ]
+
+main :: IO ()
+main =
+  do
+    raw <- lines <$> readFile "./inputs/day20.in"
+
+    let [start] = [(x, y) | (y, row) <- zip [0 ..] raw, (x, ch) <- zip [0 ..] row, ch == 'S']
+        grid = M.fromList [((x, y), ch) | (y, row) <- zip [0 ..] raw, (x, ch) <- zip [0 ..] row]
+        path = race grid start
+
+    putStr "Part 1: " >> print (nCheats path 2)
+    putStr "Part 2: " >> print (nCheats path 20)

src/Day21.hs

@@ -0,0 +1,77 @@
+module Main where
+
+import Data.List (foldl', nub)
+import qualified Data.Map as M
+
+type Vec = (Int, Int)
+
+type Table = M.Map (Char, Char) [String]
+
+type Memo = M.Map (Int, Char, Char) Int
+
+coord :: Char -> Vec
+-- keypad
+coord '0' = (1, 3)
+coord 'A' = (2, 3)
+coord '1' = (0, 2)
+coord '2' = (1, 2)
+coord '3' = (2, 2)
+coord '4' = (0, 1)
+coord '5' = (1, 1)
+coord '6' = (2, 1)
+coord '7' = (0, 0)
+coord '8' = (1, 0)
+coord '9' = (2, 0)
+-- direction
+coord 'a' = (2, 0)
+coord '^' = (1, 0)
+coord '<' = (0, 1)
+coord 'v' = (1, 1)
+coord '>' = (2, 1)
+coord _ = error "what?"
+
+path :: Char -> Char -> [String]
+path a b =
+  let ((x1, y1), (x2, y2)) = (coord a, coord b)
+      moves =
+        replicate (abs (y2 - y1)) (if y2 > y1 then 'v' else '^')
+          ++ replicate (abs (x2 - x1)) (if x2 > x1 then '>' else '<')
+   in if
+        | a == '<' || x1 == 0 && y2 == 3 -> [reverse moves ++ "a"]
+        | b == '<' || y1 == 3 && x2 == 0 -> [moves ++ "a"]
+        | otherwise -> nub [reverse moves ++ "a", moves ++ "a"]
+
+seqc :: Table -> Int -> String -> Int
+seqc table n = fst . seqc' M.empty (n + 1) 'A'
+  where
+    seqc' :: Memo -> Int -> Char -> String -> (Int, Memo)
+    seqc' memo 0 _ s = (length s, memo)
+    seqc' memo n start s = foldl' loop (0, memo) $ zip (start : s) s
+      where
+        loop :: (Int, Memo) -> (Char, Char) -> (Int, Memo)
+        loop (total, memo) (a, b) = case (n, a, b) `M.lookup` memo of
+          Just x -> (total + x, memo)
+          Nothing ->
+            let (x, memo') = case table M.! (a, b) of
+                  [p] -> seqc' memo (n - 1) 'a' p
+                  [p1, p2] ->
+                    let (x1, m1) = seqc' memo (n - 1) 'a' p1
+                        (x2, m2) = seqc' m1 (n - 1) 'a' p2
+                     in if x1 < x2 then (x1, m2) else (x2, m2)
+             in (total + x, M.insert (n, a, b) x memo')
+
+complexity :: Table -> Int -> String -> Int
+complexity table n s = a * b
+  where
+    a = read $ init s
+    b = seqc table n s
+
+main :: IO ()
+main =
+  do
+    input <- words <$> readFile "./inputs/day21.in"
+    let keys = "A0123456789a<v>^"
+        table = M.fromList [((a, b), path a b) | a <- keys, b <- keys]
+
+    putStr "Part 1: " >> print (sum $ map (complexity table 2) input)
+    putStr "Part 2: " >> print (sum $ map (complexity table 25) input)

src/Day22.hs

@@ -0,0 +1,46 @@
+module Main where
+
+import Data.Bits (Bits (xor))
+import qualified Data.Map as M
+
+type Bananas = M.Map Int Int
+
+evolve :: Int -> Int
+evolve =
+  (`mod` 16777216)
+    . (xor <*> (* 2048))
+    . (`mod` 16777216)
+    . (xor <*> (`div` 32))
+    . (`mod` 16777216)
+    . (xor <*> (* 64))
+
+part1 :: [Int] -> Int
+part1 = sum . map ((!! 2000) . iterate evolve)
+
+hash :: (Int, Int, Int, Int) -> Int
+hash (a, b, c, d) = a + 19 * (b + 19 * (c + 19 * d))
+
+bananas :: Bananas -> [Int] -> Bananas
+bananas f (a : b : c : d : e : xs) =
+  let key = hash (b - a, c - b, d - c, e - d)
+      next = bananas f (b : c : d : e : xs)
+   in case M.lookup key f of
+        Nothing -> M.insert key e next
+        Just _ -> next
+bananas f _ = f
+
+part2 :: [Int] -> Int
+part2 =
+  maximum
+    . M.elems
+    . M.unionsWith (+)
+    . map
+      (bananas M.empty . map (`mod` 10) . take 2001 . iterate evolve)
+
+main :: IO ()
+main =
+  do
+    buyers <- map read . words <$> readFile "./inputs/day22.in"
+
+    putStr "Part 1: " >> print (part1 buyers)
+    putStr "Part 2: " >> print (part2 buyers)

src/Day23.hs

@@ -0,0 +1,67 @@
+module Main where
+
+import Data.Char (chr, ord)
+import qualified Data.IntMap as M
+import qualified Data.IntSet as S
+import Data.List (intercalate, mapAccumL, maximumBy)
+import Data.Ord (comparing)
+
+type Set = S.IntSet
+
+type Connections = M.IntMap Set
+
+hash :: Char -> Char -> Int
+hash a b = (ord a - ord 'a') * 26 + (ord b - ord 'a')
+
+unhash :: Int -> String
+unhash x = [chr $ x `div` 26 + ord 'a', chr $ x `mod` 26 + ord 'a']
+
+parse :: [String] -> Connections
+parse [] = M.empty
+parse ([a, b, '-', c, d] : xs) =
+  let x = hash a b
+      y = hash c d
+   in insert x y . insert y x $ parse xs
+  where
+    insert :: Int -> Int -> Connections -> Connections
+    insert x y m = case x `M.lookup` m of
+      Just s -> M.insert x (y `S.insert` s) m
+      Nothing -> M.insert x (S.singleton y) m
+
+bornKerbosch :: (Set -> Bool) -> Connections -> [Set]
+bornKerbosch terminate connections = go S.empty (M.keysSet connections) S.empty
+  where
+    go :: Set -> Set -> Set -> [Set]
+    go r p x
+      | (S.null p && S.null x) || terminate r = [r]
+      | otherwise = concat . snd . mapAccumL loop (p, x) $ S.elems p
+      where
+        loop :: (Set, Set) -> Int -> ((Set, Set), [Set])
+        loop (p', x') v =
+          let n = connections M.! v
+           in ( (v `S.delete` p', v `S.insert` x'),
+                go (v `S.insert` r) (p' `S.intersection` n) (x' `S.intersection` n)
+              )
+
+part1 :: Connections -> Int
+part1 =
+  length
+    . filter (any ((== 't') . head . unhash) . S.elems)
+    . filter ((== 3) . S.size)
+    . bornKerbosch ((== 3) . S.size)
+
+part2 :: Connections -> String
+part2 =
+  intercalate ","
+    . map unhash
+    . S.elems
+    . maximumBy (comparing S.size)
+    . bornKerbosch (const False)
+
+main :: IO ()
+main =
+  do
+    connections <- parse . words <$> readFile "./inputs/day23.in"
+
+    putStr "Part 1: " >> print (part1 connections)
+    putStr "Part 2: " >> print (part2 connections)

src/Day24.hs

@@ -0,0 +1,121 @@
+module Main where
+
+import qualified AoC as A
+import Control.Arrow (Arrow (second))
+import Data.Bits (shiftL, xor, (.|.))
+import Data.Char (digitToInt)
+import Data.Either (rights)
+import Data.List (foldl', mapAccumL, sort)
+import qualified Data.Map as M
+import Text.Parsec (char, digit, letter, many1, newline, parse, sepEndBy1, string, try, (<|>))
+import Text.Parsec.String (Parser)
+
+data Gate = And | Or | Xor deriving (Eq, Enum)
+
+type Connection = (String, Gate, String)
+
+type States = M.Map String (Either Connection Bool)
+
+parseInitial :: Parser (String, Bool)
+parseInitial =
+  (,)
+    <$> many1 (letter <|> digit)
+    <*> (string ": " *> (toEnum . digitToInt <$> digit))
+
+parseConnection :: Parser (String, (String, Gate, String))
+parseConnection = do
+  a <- many1 (letter <|> digit)
+  char ' '
+  op <-
+    (try (string "AND") >> return And)
+      <|> (try (string "OR") >> return Or)
+      <|> (try (string "XOR") >> return Xor)
+  char ' '
+  b <- many1 (letter <|> digit)
+  string " -> "
+  c <- many1 (letter <|> digit)
+  return (c, (a, op, b))
+
+parseInput :: Parser States
+parseInput =
+  do
+    initial <- parseInitial `sepEndBy1` newline
+    let m = M.fromList (map (second Right) initial)
+    newline
+    connections <- parseConnection `sepEndBy1` newline
+    return $ foldr (\(a, b) -> M.insert a (Left b)) m connections
+
+simulate :: States -> String -> (States, Bool)
+simulate s line = case s M.! line of
+  Right bit -> (s, bit)
+  Left (lineA, op, lineB) ->
+    let (s', a) = simulate s lineA
+        (s'', b) = simulate s' lineB
+        operator = [(&&), (||), xor] !! fromEnum op
+        value = a `operator` b
+     in (M.insert line (Right value) s'', value)
+
+simulateAll :: States -> States
+simulateAll states = fst . mapAccumL simulate states $ M.keys states
+
+wires :: Char -> States -> [Bool]
+wires ch = rights . map snd . filter ((== ch) . head . fst) . M.toDescList
+
+binToDec :: [Bool] -> Int
+binToDec = foldl' (\num b -> num `shiftL` 1 .|. fromEnum b) 0
+
+part1 :: States -> Int
+part1 = binToDec . wires 'z' . simulateAll
+
+fullAdder :: States -> String -> Maybe [String]
+fullAdder states num =
+  let z = 'z' : num
+      x = 'x' : num
+      y = 'y' : num
+      Left (a, fn1, b) = states M.! z
+      Left (_, fn2, _) = states M.! a
+      Left (_, fn3, _) = states M.! b
+      xor1 = rLookup (x, Xor, y)
+      xor2 = rLookupP (xor1, Xor)
+   in case fn1 of
+        Xor -> case (fn2, fn3) of
+          (And, Or) -> Just [a, xor1]
+          (Or, And) -> Just [b, xor1]
+          _ -> Nothing
+        _ -> Just [z, xor2]
+  where
+    rLookup :: Connection -> String
+    rLookup (a, op, b) =
+      head
+        [ s
+          | (s, c) <- M.assocs states,
+            c `elem` [Left (a, op, b), Left (b, op, a)]
+        ]
+    rLookupP :: (String, Gate) -> String
+    rLookupP (a, g) =
+      head
+        [ s
+          | (s, c) <- M.assocs states,
+            Left (x, op, y) <- [c],
+            (a, g) `elem` [(x, op), (y, op)]
+        ]
+
+part2 :: States -> [String]
+part2 states =
+  let zLength = length (wires 'x' states) + 1
+   in sort
+        [ line
+          | x <- [1 .. zLength - 2],
+            let num = if x < 10 then '0' : show x else show x,
+            Just lines <- [fullAdder states num],
+            line <- lines
+        ]
+
+main :: IO ()
+main =
+  do
+    raw <- readFile "./inputs/day24.in"
+    let states = A.extract $ parse parseInput "" raw
+
+    putStr "Part 1: " >> print (part1 states)
+    putStr "Part 2: " >> print (part2 states)

src/Day25.hs

@@ -0,0 +1,33 @@
+module Main where
+
+import Data.List (partition)
+
+group :: [[a]] -> [[[a]]]
+group [] = []
+group ([] : xs) = group xs
+group xs = take 7 xs : group (drop 7 xs)
+
+part1 :: [[String]] -> [[String]] -> Int
+part1 locks keys =
+  length
+    [ ()
+      | lock <- locks,
+        key <- keys,
+        and
+          [ l == '.' || k == '.'
+            | (lrow, krow) <- zip lock key,
+              (l, k) <- zip lrow krow
+          ]
+    ]
+
+main :: IO ()
+main =
+  do
+    (locks, keys) <-
+      partition ((== '#') . head . head)
+        . group
+        . lines
+        <$> readFile "./inputs/day25.in"
+
+    putStr "Part 1: " >> print (part1 locks keys)
+    putStrLn "Part 2: See you next year :D"