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)

Haskell

import Data.ByteString.Char8 (unpack)
import Data.Char (isDigit, isHexDigit)
import Relude
import qualified Relude.Unsafe as Unsafe
import Text.ParserCombinators.ReadP

data Dir = R | D | L | U deriving (Show, Eq)

type Pos = (Int, Int)

data Action = Action Dir Int deriving (Show, Eq)

parse :: ByteString -> Maybe [(Action, Action)]
parse = fmap fst . viaNonEmpty last . readP_to_S (sepBy1 parseAction (char '\n') <* char '\n' <* eof) . unpack
  where
    parseAction = do
      dir <- choice [U <$ char 'U', D <$ char 'D', L <$ char 'L', R <$ char 'R'] <* char ' '
      x <- Unsafe.read <$> munch1 isDigit <* char ' '
      y <- char '(' *> char '#' *> (Unsafe.read . ("0x" ++) <$> count 5 (satisfy isHexDigit))
      dir' <- choice [R <$ char '0', D <$ char '1', L <$ char '2', U <$ char '3'] <* char ')'
      return (Action dir x, Action dir' y)

vertices :: [Action] -> [Pos]
vertices = scanl' (flip step) origin
  where
    step (Action U n) = first $ subtract n
    step (Action D n) = first (+ n)
    step (Action L n) = second $ subtract n
    step (Action R n) = second (+ n)

origin :: Pos
origin = (0, 0)

area, perimeter, solve :: [Action] -> Int
area a = (`div` 2) . abs . sum $ zipWith (-) x y
  where
    (p, rp) = (origin :) &&& (++ [origin]) $ vertices a
    x = zipWith (*) (fst <$> p) (snd <$> rp)
    y = zipWith (*) (snd <$> p) (fst <$> rp)
perimeter = sum . fmap (\(Action _ n) -> n)
solve = area &&& (`div` 2) . perimeter >>> uncurry (+) >>> succ

part1, part2 :: [(Action, Action)] -> Int
part1 = solve . fmap fst
part2 = solve . fmap snd

Haskell

import Data.Array.Unboxed
import qualified Data.ByteString.Char8 as BS
import Data.Char (digitToInt)
import Data.Heap hiding (filter)
import qualified Data.Heap as H
import Relude

type Pos = (Int, Int)

type Grid = UArray Pos Int

data Dir = U | D | L | R deriving (Eq, Ord, Show, Enum, Bounded, Ix)

parse :: ByteString -> Maybe Grid
parse input = do
  let l = fmap (fmap digitToInt . BS.unpack) . BS.lines $ input
      h = length l
  w <- fmap length . viaNonEmpty head $ l
  pure . listArray ((0, 0), (w - 1, h - 1)) . concat $ l

move :: Dir -> Pos -> Pos
move U = first pred
move D = first succ
move L = second pred
move R = second succ

nextDir :: Dir -> [Dir]
nextDir U = [L, R]
nextDir D = [L, R]
nextDir L = [U, D]
nextDir R = [U, D]

-- position, previous direction, accumulated loss
type S = (Int, Pos, Dir)

doMove :: Grid -> Dir -> S -> Maybe S
doMove g d (c, p, _) = do
  let p' = move d p
  guard $ inRange (bounds g) p'
  pure (c + g ! p', p', d)

doMoveN :: Grid -> Dir -> Int -> S -> Maybe S
doMoveN g d n = foldl' (>=>) pure . replicate n $ doMove g d

doMoves :: Grid -> [Int] -> S -> Dir -> [S]
doMoves g r s d = mapMaybe (flip (doMoveN g d) s) r

allMoves :: Grid -> [Int] -> S -> [S]
allMoves g r s@(_, _, prev) = nextDir prev >>= doMoves g r s

solve' :: Grid -> [Int] -> UArray (Pos, Dir) Int -> Pos -> MinHeap S -> Maybe Int
solve' g r distances target h = do
  ((acc, pos, dir), h') <- H.view h

  if pos == target
    then pure acc
    else do
      let moves = allMoves g r (acc, pos, dir)
          moves' = filter (\(acc, p, d) -> acc < distances ! (p, d)) moves
          distances' = distances // fmap (\(acc, p, d) -> ((p, d), acc)) moves'
          h'' = foldl' (flip H.insert) h' moves'
      solve' g r distances' target h''

solve :: Grid -> [Int] -> Maybe Int
solve g r = solve' g r (emptyGrid ((lo, minBound), (hi, maxBound))) hi (H.singleton (0, (0, 0), U))
  where
    (lo, hi) = bounds g
    emptyGrid = flip listArray (repeat maxBound)

part1, part2 :: Grid -> Maybe Int
part1 = (`solve` [1 .. 3])
part2 = (`solve` [4 .. 10])

Haskell

A bit of a mess, I probably shouldn't have used RWS ...

import Control.Monad.RWS
import Control.Parallel.Strategies
import Data.Array
import qualified Data.ByteString.Char8 as BS
import Data.Foldable (Foldable (maximum))
import Data.Set
import Relude

data Cell = Empty | VertSplitter | HorizSplitter | Slash | Backslash deriving (Show, Eq)

type Pos = (Int, Int)

type Grid = Array Pos Cell

data Direction = N | S | E | W deriving (Show, Eq, Ord)

data BeamHead = BeamHead
  { pos :: Pos,
    dir :: Direction
  }
  deriving (Show, Eq, Ord)

type Simulation = RWS Grid (Set Pos) (Set BeamHead)

next :: BeamHead -> BeamHead
next (BeamHead p d) = BeamHead (next' d p) d
  where
    next' :: Direction -> Pos -> Pos
    next' direction = case direction of
      N -> first pred
      S -> first succ
      E -> second succ
      W -> second pred

advance :: BeamHead -> Simulation [BeamHead]
advance bh@(BeamHead position direction) = do
  grid <- ask
  seen <- get

  if inRange (bounds grid) position && bh `notMember` seen
    then do
      tell $ singleton position
      modify $ insert bh
      pure . fmap next $ case (grid ! position, direction) of
        (Empty, _) -> [bh]
        (VertSplitter, N) -> [bh]
        (VertSplitter, S) -> [bh]
        (HorizSplitter, E) -> [bh]
        (HorizSplitter, W) -> [bh]
        (VertSplitter, _) -> [bh {dir = N}, bh {dir = S}]
        (HorizSplitter, _) -> [bh {dir = E}, bh {dir = W}]
        (Slash, N) -> [bh {dir = E}]
        (Slash, S) -> [bh {dir = W}]
        (Slash, E) -> [bh {dir = N}]
        (Slash, W) -> [bh {dir = S}]
        (Backslash, N) -> [bh {dir = W}]
        (Backslash, S) -> [bh {dir = E}]
        (Backslash, E) -> [bh {dir = S}]
        (Backslash, W) -> [bh {dir = N}]
    else pure []

simulate :: [BeamHead] -> Simulation ()
simulate heads = do
  heads' <- foldMapM advance heads
  unless (Relude.null heads') $ simulate heads'

runSimulation :: BeamHead -> Grid -> Int
runSimulation origin g = size . snd . evalRWS (simulate [origin]) g $ mempty

part1, part2 :: Grid -> Int
part1 = runSimulation $ BeamHead (0, 0) E
part2 g = maximum $ parMap rpar (`runSimulation` g) possibleInitials
  where
    ((y0, x0), (y1, x1)) = bounds g
    possibleInitials =
      join
        [ [BeamHead (y0, x) S | x <- [x0 .. x1]],
          [BeamHead (y1, x) N | x <- [x0 .. x1]],
          [BeamHead (y, x0) E | y <- [y0 .. y1]],
          [BeamHead (y, x1) W | y <- [y0 .. y1]]
        ]

parse :: ByteString -> Maybe Grid
parse input = do
  let ls = BS.lines input
      h = length ls
  w <- BS.length <$> viaNonEmpty head ls
  mat <- traverse toCell . BS.unpack $ BS.concat ls
  pure $ listArray ((0, 0), (h - 1, w - 1)) mat
  where
    toCell '.' = Just Empty
    toCell '|' = Just VertSplitter
    toCell '-' = Just HorizSplitter
    toCell '/' = Just Slash
    toCell '\\' = Just Backslash
    toCell _ = Nothing

Haskell

import Data.Array
import qualified Data.ByteString.Char8 as BS
import Data.Char (isAlpha, isDigit)
import Relude
import qualified Relude.Unsafe as Unsafe
import Text.ParserCombinators.ReadP hiding (get)

hash :: String -> Int
hash = foldl' (\a x -> (a + x) * 17 `mod` 256) 0 . fmap ord

part1 :: ByteString -> Int
part1 = sum . fmap (hash . BS.unpack) . BS.split ',' . BS.dropEnd 1

-- Part 2

type Problem = [Operation]

type S = Array Int [(String, Int)]

data Operation = Set String Int | Remove String deriving (Show)

parse :: BS.ByteString -> Maybe Problem
parse = fmap fst . viaNonEmpty last . readP_to_S parse' . BS.unpack
  where
    parse' = sepBy parseOperation (char ',') <* char '\n' <* eof
    parseOperation =
      munch1 isAlpha
        >>= \label -> (Remove label <$ char '-') +++ (Set label . Unsafe.read <$> (char '=' *> munch1 isDigit))

liftOp :: Operation -> Endo S
liftOp (Set label v) = Endo $ \s ->
  let (b, a) = second (drop 1) $ span ((/= label) . fst) (s ! hash label)
   in s // [(hash label, b <> [(label, v)] <> a)]
liftOp (Remove l) = Endo $ \s -> s // [(hash l, filter ((/= l) . fst) (s ! hash l))]

score :: S -> Int
score m = sum $ join [(* (i + 1)) <$> zipWith (*) [1 ..] (snd <$> (m ! i)) | i <- [0 .. 255]]

part2 :: ByteString -> Maybe Int
part2 input = do
  ops <- appEndo . foldMap liftOp . reverse <$> parse input
  pure . score . ops . listArray (0, 255) $ repeat []