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)

Haskell

Merry Christmas!

{-# LANGUAGE OverloadedStrings #-} module Main where import Data.Either import Data.Text hiding (all, head, zipWith) import Data.Text qualified as T import Data.Text.IO as TIO type Pins = [Int] toKeyLock :: [Text] -> Either Pins Pins toKeyLock v = (if T.head (head v) == '#' then Left else Right) $ fmap (pred . count "#") v solve keys locks = sum [1 | k <- keys, l <- locks, fit k l] where fit a b = all (<= 5) $ zipWith (+) a b main = TIO.getContents >>= print . uncurry solve . partitionEithers . fmap (toKeyLock . transpose . T.lines) . splitOn "\n\n"

Haskell

For part2 I compared the bits in the solution of part1 with the sum of x and y. With that, I could check the bits that did not match in a graphviz diagram and work from there.

code

haskell import Control.Arrow import Control.Monad.RWS import Data.Bits (shiftL) import Data.Char (digitToInt) import Data.Functor import Data.List import Data.Map qualified as M import Data.Tuple import Text.ParserCombinators.ReadP hiding (get) import Text.ParserCombinators.ReadP qualified as ReadP type Cable = String data Connection = And Cable Cable | Or Cable Cable | Xor Cable Cable deriving (Show) cable = count 3 ReadP.get eol = char ‘\n’ initial :: ReadP (M.Map Cable Bool) initial = M.fromList <$> endBy ((,) <$> cable <*> (string ": " *> (toEnum . digitToInt <$> ReadP.get))) eol wires = M.fromList <$> endBy wire eol wire = do a <- cable <* char ’ ’ op <- choice [string “AND” $> And, string “OR” $> Or, string “XOR” $> Xor] b <- char ’ ’ *> cable c <- string " -> " *> cable return (c, op a b) parse = fst . last . readP_to_S ((,) <$> initial <*> (eol *> wires <* eof)) type Problem = RWS (M.Map Cable Connection) () (M.Map Cable Bool) getConnection :: Connection -> Problem Bool getConnection (And a b) = (&&) <$> getWire a <*> getWire b getConnection (Or a b) = (||) <$> getWire a <*> getWire b getConnection (Xor a b) = xor <$> getWire a <*> getWire b xor True False = True xor False True = True xor _ _ = False getWire :: Cable -> Problem Bool getWire cable = do let computed = do a <- asks (M.! cable) >>= getConnection modify (M.insert cable a) return a gets (M.!? cable) >>= maybe computed return fromBin :: [Bool] -> Int fromBin = sum . fmap fst . filter snd . zip (iterate (`shiftL` 1) 1) toBin :: Int -> [Bool] toBin = unfoldr (\v -> if v == 0 then Nothing else Just (first (== 1) (swap (divMod v 2)))) part1 initial wiring = fst $ evalRWS (mapM getWire zs) wiring initial where zs = filter ((== ‘z’) . head) . sort $ M.keys wiring part2 initial wiring = fmap fst . filter snd $ zip [0…] (zipWith (/=) p1 expect) where xs = fromBin . fmap (initial M.!) . filter ((== ‘x’) . head) $ sort $ M.keys initial ys = fromBin . fmap (initial M.!) . filter ((== ‘y’) . head) $ sort $ M.keys initial zs = filter ((== ‘z’) . head) . sort $ M.keys wiring p1 = part1 initial wiring expect = toBin $ xs + ys main = getContents >>= print . (fromBin . uncurry part1 &&& uncurry part2) . parse

Haskell

solution

haskell import Control.Arrow import Data.Bits import Data.List import qualified Data.Map as M parse = fmap (secretNums . read) . lines secretNums :: Int -> [Int] secretNums = take 2001 . iterate (step1 >>> step2 >>> step3) where step1 n = ((n `shiftL` 06) `xor` n) .&. 0xFFFFFF step2 n = ((n `shiftR` 05) `xor` n) .&. 0xFFFFFF step3 n = ((n `shiftL` 11) `xor` n) .&. 0xFFFFFF part1 = sum . fmap last part2 = maximum . M.elems . M.unionsWith (+) . fmap (deltas . fmap (`mod` 10)) deltas l = M.fromListWith (\n p -> p) $ flip zip (drop 4 l) $ zip4 diffs (tail diffs) (drop 2 diffs) (drop 3 diffs) where diffs = zipWith (-) (tail l) l main = getContents >>= print . (part1 &&& part2) . parse