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)