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

Haskell

import Control.Arrow
import Data.Array.Unboxed
import Data.Functor
import Data.List
import Data.Map qualified as M
import Data.Set qualified as S

type Pos = (Int, Int)
type Board = Array Pos Char
type Path = M.Map Pos Int

parse board = listArray ((1, 1), (length l, length $ head l)) (concat l)
  where
    l = lines board

moves :: Pos -> [Pos]
moves p = [first succ p, first pred p, second succ p, second pred p]

getOrigin :: Board -> Maybe Pos
getOrigin = fmap fst . find ((== 'S') . snd) . assocs

getPath :: Board -> Pos -> [Pos]
getPath board p
    | not $ inRange (bounds board) p = []
    | board ! p == 'E' = [p]
    | board ! p == '#' = []
    | otherwise = p : (moves p >>= getPath (board // [(p, '#')]))

taxiCab (xa, ya) (xb, yb) = abs (xa - xb) + abs (ya - yb)

solve dist board = do
    path <- M.fromList . flip zip [1 ..] <$> (getOrigin board <&> getPath board)
    let positions = M.keys path
        jumps = [ (path M.! a) - (path M.! b) - d | a <- positions, b <- positions, d <- [taxiCab a b], d <= dist]
    return $ length $ filter (>=100) jumps

main = getContents >>= print . (solve 2 &&& solve 20) . parse

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

Spent a lot of time trying to find symmetric quadrants. In the end made an interactive visualization and found that a weird pattern appeared on iterations (27 + 101k) and (75 + 103k’). Put those congruences in an online Chinese remainder theorem calculator and go to the answer: x ≡ 8006 (mod 101*103)

import Data.Bifunctor
import Data.Char
import qualified Data.Set as S
import Data.Functor
import Data.List
import Control.Monad
import Text.ParserCombinators.ReadP
import Data.IORef

bounds = (101, 103)

parseInt :: ReadP Int
parseInt = (*) <$> option 1 (char '-' $> (-1)) <*> (read <$> munch1 isDigit)
parseTuple = (,) <$> parseInt <*> (char ',' *> parseInt)
parseRow = (,) <$> (string "p=" *> parseTuple) <*> (string " v=" *> parseTuple)
parse = fst . last . readP_to_S (endBy parseRow (char '\n'))

move t (x, y) (vx, vy) = bimap (mod (x + vx * t)) (mod (y + vy * t)) bounds

getQuadrant :: (Int, Int) -> Int
getQuadrant (x, y)
    | x == mx || y == my = 0
    | otherwise = case (x > mx, y > my) of
        (True, True) -> 1
        (True, False) -> 2
        (False, True) -> 3
        (False, False) -> 4
  where
    (mx, my) = bimap (`div` 2) (`div` 2) bounds

step (x, y) (vx, vy) = (,(vx, vy)) $ bimap (mod (x + vx)) (mod (y + vy)) bounds

main = do
    p <- parse <$> readFile "input14"

    print . product . fmap length . group . sort . filter (/=0) . fmap (getQuadrant . uncurry (move 100)) $ p

    let l = iterate (fmap (uncurry step)) p

    current <- newIORef 0
    actions <- lines <$> getContents
    forM_ actions $ \a -> do
        case a of
            "" -> modifyIORef current (+1)
            "+" -> modifyIORef current (+1)
            "-" -> modifyIORef current (subtract 1)
            n -> writeIORef current (read n)
        pos <- readIORef current
        putStr "\ESC[2J" -- clear screen
        print pos
        visualize $ fst <$> l !! pos

visualize :: [(Int, Int)] -> IO ()
visualize pos = do
    let p = S.fromList pos
    forM_ [1..(snd bounds)] $ \y -> do
        forM_ [1..(fst bounds)] $ \x -> do
            putChar $ if S.member (x, y) p then '*' else '.'
        putChar '\n'

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

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

type Pos = (Int, Int)
type Board = UArray Pos Char
type Prob = Reader Board

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

origins :: Prob [Pos]
origins =
    ask >>= \board ->
        return $ fmap fst . filter ((== '0') . snd) $ assocs board

moves :: Pos -> Prob [Pos]
moves pos =
    ask >>= \board ->
        let curr = board ! pos
         in return . filter ((== succ curr) . (board !)) . filter (inRange (bounds board)) $ fmap (.+. pos) deltas
  where
    deltas = [(1, 0), (0, 1), (-1, 0), (0, -1)]
    (ax, ay) .+. (bx, by) = (ax + bx, ay + by)

solve :: [Pos] -> Prob [Pos]
solve p = do
    board <- ask
    nxt <- concat <$> mapM moves p

    let (nines, rest) = partition ((== '9') . (board !)) nxt

    fmap (++ nines) $ if null rest then return [] else solve rest

scoreTrail = fmap (length . nub) . solve . pure
scoreTrail' = fmap length . solve . pure

part1 = sum . runReader (origins >>= mapM scoreTrail)
part2 = sum . runReader (origins >>= mapM scoreTrail')

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

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

Haskell

import Control.Arrow
import Control.Monad
import Data.List
import Data.Map qualified as M

type Pos = [Int]

parse :: String -> (Pos, [(Char, Pos)])
parse s = ([n, m], [(c, [i, j]) | i <- [0 .. n], j <- [0 .. m], c <- [l !! i !! j], c /= '.'])
  where
    l = lines s
    n = pred $ length $ head l
    m = pred $ length l

buildMap :: [(Char, Pos)] -> M.Map Char [Pos]
buildMap = M.fromListWith (++) . fmap (second pure)

allPairs :: [Pos] -> [(Pos, Pos)]
allPairs l = [(x, y) | (x : xs) <- tails l, y <- xs]

add = zipWith (+)
sub = zipWith (-)

antinodes :: Pos -> Pos -> [Pos]
antinodes a b = [a `sub` ab, b `add` ab]
  where
    ab = b `sub` a

inBounds [x', y'] [x, y] = x >= 0 && y >= 0 && x <= x' && y <= y'

antinodes' :: Pos -> Pos -> Pos -> [Pos]
antinodes' l a b = al ++ bl
  where
    ab = b `sub` a
    al = takeWhile (inBounds l) $ iterate (`sub` ab) a
    bl = takeWhile (inBounds l) $ iterate (`add` ab) b

part1 l = length . nub . filter (inBounds l) . concat . M.elems . fmap (allPairs >=> uncurry antinodes)
part2 l = length . nub . concat . M.elems . fmap (allPairs >=> uncurry (antinodes' l))

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

Love the fold on the list monad to apply the operations.

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.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

I should probably have used sortBy instead of this ad-hoc selection sort.

import Control.Arrow
import Control.Monad
import Data.Char
import Data.List qualified as L
import Data.Map
import Data.Set
import Data.Set qualified as S
import Text.ParserCombinators.ReadP

parse = (,) <$> (fromListWith S.union <$> parseOrder) <*> (eol *> parseUpdate)
parseOrder = endBy (flip (,) <$> (S.singleton <$> parseInt <* char '|') <*> parseInt) eol
parseUpdate = endBy (sepBy parseInt (char ',')) eol
parseInt = read <$> munch1 isDigit
eol = char '\n'

verify :: Map Int (Set Int) -> [Int] -> Bool
verify m = and . (zipWith fn <*> scanl (flip S.insert) S.empty)
  where
    fn a = flip S.isSubsetOf (findWithDefault S.empty a m)

getMiddle = ap (!!) ((`div` 2) . length)

part1 m = sum . fmap getMiddle

getOrigin :: Map Int (Set Int) -> Set Int -> Int
getOrigin m l = head $ L.filter (S.disjoint l . preds) (S.toList l)
  where
    preds = flip (findWithDefault S.empty) m

order :: Map Int (Set Int) -> Set Int -> [Int]
order m s
  | S.null s = []
  | otherwise = h : order m (S.delete h s)
    where
      h = getOrigin m s

part2 m = sum . fmap (getMiddle . order m . S.fromList)

main = getContents >>= print . uncurry runParts . fst . last . readP_to_S parse
runParts m = L.partition (verify m) >>> (part1 m *** part2 m)

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

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)

Haskell

import Control.Arrow
import Control.Monad
import Data.List
import Data.Map

part1 [a, b] = sum $ abs <$> zipWith (-) (sort a) (sort b)
part2 [a, b] = sum $ ap (zipWith (*)) (fmap (flip (findWithDefault 0) (freq b))) a
  where
    freq = fromListWith (+) . fmap (,1)

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

Haskell

Had some fun with arrows.

import Control.Arrow
import Control.Monad

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

part1 = length . filter isSafe
part2 = length . filter (any isSafe . removeOne)

isSafe = ap (zipWith (-)) tail >>> (all (between 1 3) &&& all (between (-3) (-1))) >>> uncurry (||)
 where
  between a b = (a <=) &&& (<= b) >>> uncurry (&&)

removeOne [] = []
removeOne (x : xs) = xs : fmap (x :) (removeOne xs)