Haskell

import Control.Arrow
import Data.Char
import Text.ParserCombinators.ReadP

import Data.Array qualified as A
import Data.Map.Strict qualified as M

parse = M.fromList . fst . last . readP_to_S (((,) <$> (munch1 isAlpha <* string ": ") <*> (munch1 isAlpha `sepBy` char ' ')) `endBy` char '\n')

out = 0 :: Int -- index of out node

buildAdjList m = (keys, adj)
  where
    keys = M.insert "out" out . snd . M.mapAccumWithKey (\a k _ -> (succ a, a)) (succ out) $ m
    adj = A.listArray (out, out + M.size m) $ [] : (fmap (keys M.!) <$> M.elems m)

findPaths adj src dest = go src
  where
    go i
      | i == dest = 1 :: Int
      | otherwise = sum $ (r A.!) <$> (adj A.! i)

    r = A.listArray bounds $ go <$> A.range bounds
    bounds = A.bounds adj

part1 (keys, adj) = findPaths adj (keys M.! "you") out

-- Since graph must be acyclic, one of fft_dac or dac_fft will be 0
part2 (keys, adj)
  | fft_dac /= 0 = svr_fft * fft_dac * dac_out
  | otherwise = svr_dac * dac_fft * fft_out
    where
      [svr, fft, dac] = (keys M.!) <$> ["svr", "fft", "dac"]
      svr_fft = findPaths adj svr fft
      fft_dac = findPaths adj fft dac
      dac_out = findPaths adj dac out

      svr_dac = findPaths adj svr dac
      dac_fft = findPaths adj dac fft
      fft_out = findPaths adj fft out

main = getContents >>= print . (part1 &&& part2) . buildAdjList . parse

Haskell

import Control.Arrow
import Control.Monad
import Data.Char
import Data.List
import Data.Maybe
import Data.Ord
import Text.ParserCombinators.ReadP

import Data.Array.Unboxed qualified as A
import Data.Map.Strict qualified as M

parse = fst . last . readP_to_S (endBy (sepBy (read <$> munch1 isDigit) (char ',')) (char '\n'))

sortedPairs l = sortOn dist [(x, y) | (x : ys) <- tails l, y <- ys]
  where
    dist = uncurry $ (sum .) . zipWith (\a b -> (b - a) ^ 2)

merge l = scanl' f (initialAssocs, initialSizes)
  where
    f s@(assocs, sizes) (a, b) = case compare ia ib of
        GT -> f s (b, a)
        LT ->
            ( M.map (\x -> if x == ib then ia else x) assocs
            , sizes A.// [(ib, 0), (ia, (sizes A.! ia) + (sizes A.! ib))]
            )
        EQ -> s
      where
        (ia, ib) = (assocs M.! a, assocs M.! b)

    initialAssocs = M.fromList $ zip l [1 ..]
    initialSizes = A.listArray (1, length l) $ repeat 1 :: A.UArray Int Int

main = do
    contents <- parse <$> getContents
    let pairs = sortedPairs contents
        merged = merge contents pairs
        n = findIndex ((== length contents) . (A.! 1) . snd) merged

    print $ product . take 3 . sortBy (comparing Down) . A.elems . snd <$> merged !? 1000
    print $ uncurry (*) . (head *** head) . (pairs !!) . pred <$> n

Haskell

import Control.Arrow
import Control.Monad
import Control.Monad.Writer.Strict
import Data.Array
import Data.Functor
import Data.List
import Data.Maybe
import Data.Monoid

parse content = (elemIndices 'S' x, filter (not . null) $ elemIndices '^' <$> xs)
  where
    (x : xs) = lines content

split :: [Int] -> Int -> Writer (Sum Int) [Int]
split splitters beam
    | beam `elem` splitters = tell 1 $> [pred beam, succ beam]
    | otherwise = pure [beam]

part1 = getSum . execWriter . uncurry process
  where
    process start =
        foldl'
            (\beams splitters -> nub . concat <$> (beams >>= mapM (split splitters)))
            (pure start)

part2 :: ([Int], [[Int]]) -> Int
part2 (start, splitterList) = go (head start, 0)
  where
    go (i, j)
        | j >= depth = 1
        | hasSplitter i j = r ! (pred i, succ j) + r ! (succ i, succ j)
        | otherwise = r ! (i, succ j)

    r = listArray bounds [go (i, j) | (i, j) <- range bounds]
    bounds = ((0, 0), (width, depth))

    hasSplitter i j = j < length splitterList && i `elem` splitterList !! j

    depth = length splitterList
    width = succ . maximum $ concat splitterList

main = getContents >>= print . (part1 &&& part2) . parse

Haskell

import Control.Arrow
import Data.Char
import Data.List
import Text.ParserCombinators.ReadP

op "*" = product
op "+" = sum

part1 s = sum $ zipWith ($) (op <$> a) (transpose $ fmap read <$> as)
  where
    (a : as) = reverse . fmap words . lines $ s

parseGroups = fst . last . readP_to_S (sepBy (endBy int eol) eol) . filter (/= ' ')
  where
    eol = char '\n'
    int = read <$> munch1 isDigit :: ReadP Int

part2 s = sum $ zipWith ($) (op <$> words a) (parseGroups . unlines $ reverse <$> transpose as)
  where
    (a : as) = reverse $ lines s

main = getContents >>= print . (part1 &&& part2)

Haskell

import Data.Array.Unboxed
import Control.Arrow
import Data.Foldable

type Coord = (Int, Int)
type Diagram = UArray Coord Char

moves :: Coord -> [Coord]
moves pos = (.+. pos) <$> deltas
  where
    deltas = [(x, y) | x <- [-1, 0, 1], y <- [-1, 0, 1], not (x == 0 && y == 0)]
    (ax, ay) .+. (bx, by) = (ax + bx, ay + by)

parse :: String -> Diagram
parse s = listArray ((1, 1), (n, m)) $ concat l
  where
    l = lines s
    n = length l
    m = length $ head l

isRoll = (== '@')
numRolls = length . filter isRoll

neighbors d p = (d !) <$> filter (inRange (bounds d)) (moves p)

removable d = filter ((<4) . numRolls . neighbors d . fst) . filter (isRoll . snd) $ assocs d

part1 :: Diagram -> Int
part1 = length . removable

part2 d = fmap ((initial -) . fst) . find (uncurry (==)) $ zip stages (tail stages)
  where
    initial = numRolls $ elems d
    stages = numRolls . elems <$> iterate (\x -> x // toX (removable x)) d
    toX = fmap (second (const 'x'))

main = getContents >>= print . (part1 &&& part2) . parse

Haskell

I think I could have avoided the minimumBy hack by doing another reverse and changing the indices.

import Data.List
import Data.Function
import Control.Arrow

parse = fmap (fmap (read . pure)) . lines

solve n = sum . fmap (sum . zipWith (*) (iterate (*10) 1) . reverse . go n)
  where
    go :: Int -> [Int] -> [Int]
    go 0 l = pure $ maximum l
    go n l = mx : go (n-1) (drop idx l)
      where
        -- use minimumBy since if there are multiple least elements, we want the leftmost one.
        (idx, mx) = minimumBy (compare `on` (negate . snd)) . zip [1..] . take (length l - n) $ l

main = getContents >>= print . (solve 1 &&& solve 11) . parse

Haskell

import Control.Arrow
import Control.Monad
import Control.Monad.Writer.Strict
import Data.Char
import Data.Functor
import Text.ParserCombinators.ReadP

n = 100
start = 50

parse = fst . last . readP_to_S (endBy rotation (char '\n'))
  where
    rotation = (*) <$> ((char 'L' $> (-1)) <++ (char 'R' $> 1)) <*> (read <$> munch isDigit)

part1 = length . filter (== 0) . fmap (`mod` n) . scanl (+) start

spins :: Int -> Int -> Writer [Int] Int
spins acc x = do
    when (abs x >= n) . tell . pure $ abs x `div` n -- full loops
    let res = acc + (x `rem` n)
        res' = res `mod` n

    when (res /= res') . tell . pure $ 1

    return res'

part2 = sum . execWriter . foldM spins start

main = getContents >>= (print . (part1 &&& part2) . parse)