Haskell

{-# LANGUAGE LambdaCase #-}

module Main where

import Control.Arrow
import Control.Monad.State
import Data.Char
import Data.List
import Data.Map qualified as M
import Data.Monoid
import Text.ParserCombinators.ReadP

parse = fst . last . readP_to_S ((,) <$> (patterns <* eol <* eol) <*> designs)
  where
    eol = char '\n'
    patterns = sepBy word (string ", ")
    designs = endBy word eol
    word = munch1 isLetter

part1 patterns = length . filter (valid patterns)
part2 patterns = getSum . combinations patterns

dropPrefix = drop . length

valid :: [String] -> String -> Bool
valid patterns design = go design
  where
    go "" = True
    go design = case filter (`isPrefixOf` design) patterns of
        [] -> False
        l -> any (go . (`dropPrefix` design)) l

combinations :: [String] -> [String] -> Sum Int
combinations patterns designs = evalState (fmap mconcat . mapM go $ designs) mempty
  where
    go "" = return $ Sum 1
    go design =
        gets (M.lookup design) >>= \case
            Just c -> return c
            Nothing -> case filter (`isPrefixOf` design) patterns of
                [] -> return $ Sum 0
                l -> do
                    res <- mconcat <$> mapM (go . (`dropPrefix` design)) l
                    modify (M.insert design res)
                    return res

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

Haskell

import Control.Arrow
import Control.Monad
import Control.Monad.RWS
import Control.Monad.Trans.Maybe
import Data.Array (inRange)
import Data.Char
import Data.Set qualified as S
import Text.ParserCombinators.ReadP hiding (get)

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

bounds = ((0, 0), (70, 70))

bfs :: MaybeT (RWS (S.Set (Int, Int)) () (S.Set (Int, Int), [(Int, (Int, Int))])) Int
bfs = do
  (seen, (c, x) : xs) <- get
  modify . second $ const xs
  isCorrupt <- asks (S.member x)

  when (not (x `S.member` seen) && not isCorrupt && inRange bounds x) $
    modify (S.insert x *** (++ ((succ c,) <$> neighbors x)))

  if x == snd bounds
    then return c
    else bfs

neighbors (x, y) = [(succ x, y), (pred x, y), (x, succ y), (x, pred y)]

findPath = fst . flip (evalRWS (runMaybeT bfs)) (mempty, [(0, (0, 0))]) . S.fromList

part1 = findPath . take 1024

search corrupt = go 0 (length corrupt)
 where
  go l r = case (findPath $ take (pred m) corrupt, findPath $ take m corrupt) of
    (Just _, Just _) -> go m r
    (Just _, Nothing) -> Just $ pred m
    (Nothing, Nothing) -> go l m
   where
    m = (l + r) `div` 2

part2 = liftM2 fmap (!!) search

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

Haskell

import Control.Arrow
import Control.Monad
import Control.Monad.RWS
import Control.Monad.Trans.Maybe
import Data.Array.Unboxed
import Data.List
import Data.Map qualified as M
import Data.Maybe
import Data.Set qualified as S

data Dir = N | S | W | E deriving (Show, Eq, Ord)
type Maze = UArray Pos Char
type Pos = (Int, Int)
type Node = (Pos, Dir)
type CostNode = (Int, Node)
type Problem = RWS Maze [(Node, [Node])] (M.Map Node Int, S.Set (CostNode, Maybe Node))

parse = toMaze . lines

toMaze :: [String] -> Maze
toMaze b = listArray ((0, 0), (n - 1, m - 1)) $ concat b
  where
    n = length b
    m = length $ head b

next :: Int -> (Pos, Dir) -> Problem [CostNode]
next c (p, d) = do
    m <- ask

    let straigth = fmap ((1,) . (,d)) . filter ((/= '#') . (m !)) . return $ move d p
        turn = (1000,) . (p,) <$> rot d

    return $ first (+ c) <$> straigth ++ turn

move N = first (subtract 1)
move S = first (+ 1)
move W = second (subtract 1)
move E = second (+ 1)

rot d
    | d `elem` [N, S] = [E, W]
    | otherwise = [N, S]

dijkstra :: MaybeT Problem ()
dijkstra = do
    m <- ask
    visited <- gets fst
    Just (((cost, vertex@(p, _)), father), queue) <- gets (S.minView . snd)

    let (prevCost, visited') = M.insertLookupWithKey (\_ a _ -> a) vertex cost visited

    case prevCost of
        Nothing -> do
            queue' <- lift $ foldr S.insert queue <$> (fmap (,Just vertex) <$> next cost vertex)
            put (visited', queue')
            tell [(vertex, maybeToList father)]
        Just c -> do
            if c == cost
                then tell [(vertex, maybeToList father)]
                else guard $ m ! p /= 'E'
            put (visited, queue)
    dijkstra

solve b = do
    start <- getStart b
    end <- getEnd b
    let ((m, _), w) = execRWS (runMaybeT dijkstra) b (M.empty, S.singleton (start, Nothing))
        parents = M.fromListWith (++) w
        endDirs = (end,) <$> [N, S, E, W]
        min = minimum $ mapMaybe (`M.lookup` m) endDirs
        ends = filter ((== Just min) . (`M.lookup` m)) endDirs
        part2 =
            S.size . S.fromList . fmap fst . concat . takeWhile (not . null) $
                iterate (>>= flip (M.findWithDefault []) parents) ends
    return (min, part2)

getStart :: Maze -> Maybe CostNode
getStart = fmap ((0,) . (,E) . fst) . find ((== 'S') . snd) . assocs

getEnd :: Maze -> Maybe Pos
getEnd = fmap fst . find ((== 'E') . snd) . assocs

main = getContents >>= print . solve . parse

Haskell

import Data.Monoid
import Control.Arrow

data Tree v = Tree (Tree v) v (Tree v)

-- https://stackoverflow.com/questions/3208258
memo1 f = index nats
  where
    nats = go 0 1
    go i s = Tree (go (i + s) s') (f i) (go (i + s') s')
      where
        s' = 2 * s
    index (Tree l v r) i
        | i < 0 = f i
        | i == 0 = v
        | otherwise = case (i - 1) `divMod` 2 of
            (i', 0) -> index l i'
            (i', 1) -> index r i'

memo2 f = memo1 (memo1 . f)

blink = memo2 blink'
  where
    blink' c n
        | c == 0 = 1
        | n == 0 = blink c' 1
        | even digits = blink c' l <> blink c' r
        | otherwise = blink c' $ n * 2024
      where
        digits = succ . floor . logBase 10 . fromIntegral $ n
        (l, r) = n `divMod` (10 ^ (digits `div` 2))
        c' = pred c

doBlinks n = getSum . mconcat . fmap (blink n)
part1 = doBlinks 25
part2 = doBlinks 75

main = getContents >>= print . (part1 &&& part2) . fmap read . words

Haskell

Quite messy

{-# LANGUAGE LambdaCase #-}

module Main where

import Control.Applicative
import Control.Arrow
import Control.Monad
import Control.Monad.ST
import Control.Monad.Trans
import Control.Monad.Trans.Maybe
import Data.Array.ST
import Data.Array.Unboxed
import Data.Char
import Data.List
import Data.Maybe

parse = zip ids . fmap digitToInt . takeWhile (/= '\n')

ids = intersperse Nothing $ Just <$> [0 ..]

expand :: [(a, Int)] -> [a]
expand = foldMap (uncurry $ flip replicate)

process l = runSTArray $ do
    arr <- newListArray (1, length l) l
    getBounds arr >>= uncurry (go arr)
  where
    go arr iL iR = do
        (iL', iR') <- advance arr (iL, iR)
        if iL' < iR'
            then swap arr iL' iR' *> go arr iL' iR'
            else return arr

swap arr i j = do
    a <- readArray arr i
    readArray arr j >>= writeArray arr i
    writeArray arr j a

advance arr (h, t) = (,) <$> advanceHead arr h <*> advanceTail arr t
  where
    advanceHead arr i =
        readArray arr i >>= \case
            Nothing -> return i
            _ -> advanceHead arr (succ i)

    advanceTail arr i =
        readArray arr i >>= \case
            Nothing -> advanceTail arr (pred i)
            _ -> return i

checksum = sum . zipWith (*) [0 ..]

process2 l = runSTArray $ do
    let idxs = scanl' (+) 1 $ snd <$> l
        iR = last idxs
    arr <- newArray (1, iR) Nothing
    forM_ (zip idxs l) $ \(i, v) -> writeArray arr i (Just v)

    runMaybeT $ go arr iR

    return arr
  where
    go :: MArr s -> Int -> MaybeT (ST s) ()
    go arr iR = do
        (i, sz) <- findVal arr iR

        (findGap arr sz 1 >>= move arr i) <|> return ()

        go arr $ pred i

type MArr s = STArray s Int (Maybe (Maybe Int, Int))

findGap :: MArr s -> Int -> Int -> MaybeT (ST s) Int
findGap arr n i = do
    mx <- lift $ snd <$> getBounds arr
    guard $ i <= mx
    ( do
            Just (Nothing, v) <- lift (readArray arr i)
            guard $ v >= n
            hoistMaybe $ Just i
        )
        <|> findGap arr n (succ i)

findVal :: MArr s -> Int -> MaybeT (ST s) (Int, Int)
findVal arr i = do
    guard $ i >= 1
    lift (readArray arr i) >>= \case
        Just (Just _, sz) -> hoistMaybe $ Just (i, sz)
        _ -> findVal arr $ pred i

move arr iVal iGap = do
    guard $ iGap < iVal

    Just (Nothing, gap) <- lift $ readArray arr iGap
    v@(Just (Just _, sz)) <- lift $ readArray arr iVal
    lift . writeArray arr iVal $ Just (Nothing, sz)
    lift $ writeArray arr iGap v

    when (gap > sz) . lift . writeArray arr (iGap + sz) $ Just (Nothing, gap - sz)

part1 = checksum . catMaybes . elems . process . expand
part2 = checksum . fmap (fromMaybe 0) . expand . catMaybes . elems . process2

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

I use neovim with haskell-tools.nvim plugin. For ghc, haskell-language-server and others I use nix which, among other benefits makes my development environment reproducible and all haskellPackages are built on the same version so there are no missmatches.

But, as much as I love nix, there are probably easier ways to setup your environment.

Haskell

import Control.Arrow
import Data.Array.Unboxed
import Data.List

type Pos = (Int, Int)
type Board = Array Pos Char
data Dir = N | NE | E | SE | S | SW | W | NW

target = "XMAS"

parse s = listArray ((1, 1), (n, m)) [l !! i !! j | i <- [0 .. n - 1], j <- [0 .. m - 1]]
  where
    l = lines s
    (n, m) = (length $ head l, length l)

move N = first pred
move S = first succ
move E = second pred
move W = second succ
move NW = move N . move W
move SW = move S . move W
move NE = move N . move E
move SE = move S . move E

check :: Board -> Pos -> Int -> Dir -> Bool
check b p i d =
    i >= length target
        || ( inRange (bounds b) p
                && (b ! p) == (target !! i)
                && check b (move d p) (succ i) d
           )

checkAllDirs :: Board -> Pos -> Int
checkAllDirs b p = length . filter (check b p 0) $ [N, NE, E, SE, S, SW, W, NW]

check2 :: Board -> Pos -> Bool
check2 b p =
    all (inRange (bounds b)) moves && ((b ! p) == 'A') && ("SSMM" `elem` rotations)
  where
    rotations = rots $ (b !) <$> moves
    moves = flip move p <$> [NE, SE, SW, NW]

    rots xs = init $ zipWith (++) (tails xs) (inits xs)

part1 b = sum $ checkAllDirs b <$> indices b
part2 b = length . filter (check2 b) $ indices b

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

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.

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

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

numP = read <$> munch1 isDigit
parse = endBy ((,) <$> (numP <* string ": ") <*> sepBy numP (char ' ')) (char '\n')

valid n [m] = m == n
valid n (x : xs) = n > 0 && valid (n - x) xs || (n `mod` x) == 0 && valid (n `div` x) xs

part1 = sum . fmap fst . filter (uncurry valid . second reverse)

concatNum r = (+r) . (* 10 ^ digits r)
    where
        digits = succ . floor . logBase 10 . fromIntegral

allPossible [n] = [n]
allPossible (x:xs) = ((x+) <$> rest) ++ ((x*) <$> rest) ++ (concatNum x <$> rest)
    where
        rest = allPossible xs

part2 = sum . fmap fst . filter (uncurry elem . second (allPossible . reverse))

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

Haskell

module Main where

import Control.Arrow hiding ((+++))
import Data.Char
import Data.Functor
import Data.Maybe
import Text.ParserCombinators.ReadP hiding (get)
import Text.ParserCombinators.ReadP qualified as P

data Op = Mul Int Int | Do | Dont deriving (Show)

parser1 :: ReadP [(Int, Int)]
parser1 = catMaybes <$> many ((Just <$> mul) <++ (P.get $> Nothing))

parser2 :: ReadP [Op]
parser2 = catMaybes <$> many ((Just <$> operation) <++ (P.get $> Nothing))

mul :: ReadP (Int, Int)
mul = (,) <$> (string "mul(" *> (read <$> munch1 isDigit <* char ',')) <*> (read <$> munch1 isDigit <* char ')')

operation :: ReadP Op
operation = (string "do()" $> Do) +++ (string "don't()" $> Dont) +++ (uncurry Mul <$> mul)

foldOp :: (Bool, Int) -> Op -> (Bool, Int)
foldOp (_, n) Do = (True, n)
foldOp (_, n) Dont = (False, n)
foldOp (True, n) (Mul a b) = (True, n + a * b)
foldOp (False, n) _ = (False, n)

part1 = sum . fmap (uncurry (*)) . fst . last . readP_to_S parser1
part2 = snd . foldl foldOp (True, 0) . fst . last . readP_to_S parser2

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