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 Control.Monad.Writer.Strict
import Data.Char
import Data.Functor
import Text.ParserCombinators.ReadP

n = 100
start = 50

parse = fst . last . readP_to_S (endBy rotation (char '\n'))
  where
    rotation = (*) <$> ((char 'L' $> (-1)) <++ (char 'R' $> 1)) <*> (read <$> munch isDigit)

part1 = length . filter (== 0) . fmap (`mod` n) . scanl (+) start

spins :: Int -> Int -> Writer [Int] Int
spins acc x = do
    when (abs x >= n) . tell . pure $ abs x `div` n -- full loops
    let res = acc + (x `rem` n)
        res' = res `mod` n

    when (res /= res') . tell . pure $ 1

    return res'

part2 = sum . execWriter . foldM spins start

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

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

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

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

import Data.Array qualified as A
import Data.Map.Strict qualified as M

parse = M.fromList . fst . last . readP_to_S (((,) <$> (munch1 isAlpha <* string ": ") <*> (munch1 isAlpha `sepBy` char ' ')) `endBy` char '\n')

out = 0 :: Int -- index of out node

buildAdjList m = (keys, adj)
  where
    keys = M.insert "out" out . snd . M.mapAccumWithKey (\a k _ -> (succ a, a)) (succ out) $ m
    adj = A.listArray (out, out + M.size m) $ [] : (fmap (keys M.!) <$> M.elems m)

findPaths adj src dest = go src
  where
    go i
      | i == dest = 1 :: Int
      | otherwise = sum $ (r A.!) <$> (adj A.! i)

    r = A.listArray bounds $ go <$> A.range bounds
    bounds = A.bounds adj

part1 (keys, adj) = findPaths adj (keys M.! "you") out

-- Since graph must be acyclic, one of fft_dac or dac_fft will be 0
part2 (keys, adj)
  | fft_dac /= 0 = svr_fft * fft_dac * dac_out
  | otherwise = svr_dac * dac_fft * fft_out
    where
      [svr, fft, dac] = (keys M.!) <$> ["svr", "fft", "dac"]
      svr_fft = findPaths adj svr fft
      fft_dac = findPaths adj fft dac
      dac_out = findPaths adj dac out

      svr_dac = findPaths adj svr dac
      dac_fft = findPaths adj dac fft
      fft_out = findPaths adj fft out

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

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

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

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

::: spoiler code

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

::: spoiler solution

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

::: spoiler solution

{-# 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

Merry Christmas!

{-# LANGUAGE OverloadedStrings #-}

module Main where

import Data.Either
import Data.Text hiding (all, head, zipWith)
import Data.Text qualified as T
import Data.Text.IO as TIO

type Pins = [Int]

toKeyLock :: [Text] -> Either Pins Pins
toKeyLock v = (if T.head (head v) == '#' then Left else Right) $ fmap (pred . count "#") v

solve keys locks = sum [1 | k <- keys, l <- locks, fit k l]
  where
    fit a b = all (<= 5) $ zipWith (+) a b

main = TIO.getContents >>= print . uncurry solve . partitionEithers . fmap (toKeyLock . transpose . T.lines) . splitOn "\n\n"

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.

::: spoiler code

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 Data.List
import Text.ParserCombinators.ReadP

op "*" = product
op "+" = sum

part1 s = sum $ zipWith ($) (op <$> a) (transpose $ fmap read <$> as)
  where
    (a : as) = reverse . fmap words . lines $ s

parseGroups = fst . last . readP_to_S (sepBy (endBy int eol) eol) . filter (/= ' ')
  where
    eol = char '\n'
    int = read <$> munch1 isDigit :: ReadP Int

part2 s = sum $ zipWith ($) (op <$> words a) (parseGroups . unlines $ reverse <$> transpose as)
  where
    (a : as) = reverse $ lines s

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

Haskell

import Control.Arrow
import Control.Monad
import Data.Char
import Data.List
import Data.Maybe
import Data.Ord
import Text.ParserCombinators.ReadP

import Data.Array.Unboxed qualified as A
import Data.Map.Strict qualified as M

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

sortedPairs l = sortOn dist [(x, y) | (x : ys) <- tails l, y <- ys]
  where
    dist = uncurry $ (sum .) . zipWith (\a b -> (b - a) ^ 2)

merge l = scanl' f (initialAssocs, initialSizes)
  where
    f s@(assocs, sizes) (a, b) = case compare ia ib of
        GT -> f s (b, a)
        LT ->
            ( M.map (\x -> if x == ib then ia else x) assocs
            , sizes A.// [(ib, 0), (ia, (sizes A.! ia) + (sizes A.! ib))]
            )
        EQ -> s
      where
        (ia, ib) = (assocs M.! a, assocs M.! b)

    initialAssocs = M.fromList $ zip l [1 ..]
    initialSizes = A.listArray (1, length l) $ repeat 1 :: A.UArray Int Int

main = do
    contents <- parse <$> getContents
    let pairs = sortedPairs contents
        merged = merge contents pairs
        n = findIndex ((== length contents) . (A.! 1) . snd) merged

    print $ product . take 3 . sortBy (comparing Down) . A.elems . snd <$> merged !? 1000
    print $ uncurry (*) . (head *** head) . (pairs !!) . pred <$> n

Haskell

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

::: spoiler Solution

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

:::

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

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