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 []

Haskell

Managed to do part1 in one line using ByteString operations:

import Control.Monad
import qualified Data.ByteString.Char8 as BS

part1 :: IO Int
part1 =
  sum
    . ( BS.transpose . BS.split '\n'
          >=> fmap succ
          . BS.elemIndices 'O' . BS.reverse . BS.intercalate "#"
          . fmap (BS.reverse . BS.sort) . BS.split '#'
      )
    <$> BS.readFile "inp"

Part 2

{-# LANGUAGE NumericUnderscores #-}

import qualified Data.ByteString.Char8 as BS
import qualified Data.Map as M
import Relude

type Problem = [ByteString]

-- We apply rotation so that north is to the right, this makes
-- all computations easier since we can just sort the rows.
parse :: ByteString -> Problem
parse = rotate . BS.split '\n'

count :: Problem -> [[Int]]
count = fmap (fmap succ . BS.elemIndices 'O')

rotate, move, rotMov, doCycle :: Problem -> Problem
rotate = fmap BS.reverse . BS.transpose
move = fmap (BS.intercalate "#" . fmap BS.sort . BS.split '#')
rotMov = rotate . move
doCycle = rotMov . rotMov . rotMov . rotMov

doNcycles :: Int -> Problem -> Problem
doNcycles n = foldl' (.) id (replicate n doCycle)

findCycle :: Problem -> (Int, Int)
findCycle = go 0 M.empty
  where
    go :: Int -> M.Map Problem Int -> Problem -> (Int, Int)
    go n m p =
      let p' = doCycle p
       in case M.lookup p' m of
            Just n' -> (n', n + 1)
            Nothing -> go (n + 1) (M.insert p' n m) p'

part1, part2 :: ByteString -> Int
part1 = sum . join . count . move . parse
part2 input =
  let n = 1_000_000_000
      p = parse input
      (s, r) = findCycle p
      numRots = s + ((n - s) `mod` (r - s - 1))
   in sum . join . count $ doNcycles numRots p

Haskell

Abused ParserCombinators for the first part. For the second, I took quite a while to figure out dynamic programming in Haskell.

module Day12 where

import Data.Array
import Data.Char (isDigit)
import Data.List ((!!))
import Relude hiding (get, many)
import Relude.Unsafe (read)
import Text.ParserCombinators.ReadP

type Spring = (String, [Int])

type Problem = [Spring]

parseStatus :: ReadP Char
parseStatus = choice $ char <$> ".#?"

parseSpring :: ReadP Spring
parseSpring = do
  status <- many1 parseStatus <* char ' '
  listFailed <- (read <$> munch1 isDigit) `sepBy` char ','
  return (status, listFailed)

parseProblem :: ReadP Problem
parseProblem = parseSpring `sepBy` char '\n'

parse :: ByteString -> Maybe Problem
parse = fmap fst . viaNonEmpty last . readP_to_S parseProblem . decodeUtf8

good :: ReadP ()
good = choice [char '.', char '?'] $> ()

bad :: ReadP ()
bad = choice [char '#', char '?'] $> ()

buildParser :: [Int] -> ReadP ()
buildParser l = do
  _ <- many good
  sequenceA_ $ intersperse (many1 good) [count x bad | x <- l]
  _ <- many good <* eof

  return ()

combinations :: Spring -> Int
combinations (s, l) = length $ readP_to_S (buildParser l) s

part1, part2 :: Problem -> Int
part1 = sum . fmap combinations
part2 = sum . fmap (combinations' . toSpring' . bimap (join . intersperse "?" . replicate 5) (join . replicate 5))

run1, run2 :: FilePath -> IO Int
run1 f = readFileBS f >>= maybe (fail "parse error") (return . part1) . parse
run2 f = readFileBS f >>= maybe (fail "parse error") (return . part2) . parse

data Status = Good | Bad | Unknown deriving (Eq, Show)

type Spring' = ([Status], [Int])

type Problem' = [Spring']

toSpring' :: Spring -> Spring'
toSpring' (s, l) = (fmap toStatus s, l)
  where
    toStatus :: Char -> Status
    toStatus '.' = Good
    toStatus '#' = Bad
    toStatus '?' = Unknown
    toStatus _ = error "impossible"

isGood, isBad :: Status -> Bool
isGood Bad = False
isGood _ = True
isBad Good = False
isBad _ = True

combinations' :: Spring' -> Int
combinations' (s, l) = t ! (0, 0)
  where
    n = length s
    m = length l

    t = listArray ((0, 0), (n, m)) [f i j | i <- [0 .. n], j <- [0 .. m]]

    f :: Int -> Int -> Int
    f n' m'
      | n' >= n = if m' >= m then 1 else 0
      | v == Unknown = tGood + tBad
      | v == Good = tGood
      | v == Bad = tBad
      | otherwise = error "impossible"
      where
        v = s !! n'
        x = l !! m'

        ss = drop n' s

        (bads, rest) = splitAt x ss
        badsDelimited = maybe True isGood (viaNonEmpty head rest)
        off = if null rest then 0 else 1

        tGood = t ! (n' + 1, m')

        tBad =
          if m' + 1 <= m && length bads == x && all isBad bads && badsDelimited
            then t ! (n' + x + off, m' + 1)
            else 0