Haskell

This was a fun one! I’m quite pleased with moveInto, which could be easily extended to support arbitrary box shapes.

import Control.Monad
import Data.Bifunctor
import Data.List
import Data.Map (Map)
import Data.Map qualified as Map
import Data.Set (Set)
import Data.Set qualified as Set

type C = (Int, Int)

readInput :: String -> (Map C Char, [C])
readInput s =
  let (room, _ : moves) = break null $ lines s
   in ( Map.fromList [((i, j), c) | (i, l) <- zip [0 ..] room, (j, c) <- zip [0 ..] l],
        map dir $ concat moves
      )
  where
    dir '^' = (-1, 0)
    dir 'v' = (1, 0)
    dir '<' = (0, -1)
    dir '>' = (0, 1)

moveInto :: Int -> Set C -> C -> C -> Set C -> Maybe (Set C)
moveInto boxWidth walls (di, dj) = go
  where
    go (i, j) boxes
      | (i, j) `Set.member` walls = Nothing
      | Just j' <- find (\j' -> (i, j') `Set.member` boxes) $ map (j -) [0 .. boxWidth - 1] =
          Set.insert (i + di, j' + dj)
            <$> foldM
              (flip go)
              (Set.delete (i, j') boxes)
              [(i + di, j' + z + dj) | z <- [0 .. boxWidth - 1]]
      | otherwise = Just boxes

runMoves :: (Map C Char, [C]) -> Int -> Int
runMoves (room, moves) scale = score $ snd $ foldl' move (start, boxes) moves
  where
    room' = Map.mapKeysMonotonic (second (* scale)) room
    Just start = fst <$> find ((== '@') . snd) (Map.assocs room')
    walls =
      let ps = Map.keysSet $ Map.filter (== '#') room'
       in Set.unions [Set.mapMonotonic (second (+ z)) ps | z <- [0 .. scale - 1]]
    boxes = Map.keysSet $ Map.filter (== 'O') room'
    move (pos@(i, j), boxes) dir@(di, dj) =
      let pos' = (i + di, j + dj)
       in maybe (pos, boxes) (pos',) $ moveInto scale walls dir pos' boxes
    score = sum . map (\(i, j) -> i * 100 + j) . Set.elems

main = do
  input <- readInput <$> readFile "input15"
  mapM_ (print . runMoves input) [1, 2]

Checking for no overlaps is an interesting one. Intuitively I’d expect that to happen more often due to the low density, but as you say perhaps it’s deliberate.

Haskell

Part 2 could be improved significantly now that I know what to look for, but this is the (very inefficient) heuristic I eventually found the answer with.

import Control.Arrow
import Data.Char
import Data.List
import Data.Map qualified as Map
import Data.Maybe
import Text.Parsec

(w, h) = (101, 103)

readInput :: String -> [((Int, Int), (Int, Int))]
readInput = either (error . show) id . parse (robot `endBy` newline) ""
  where
    robot = (,) <$> (string "p=" >> coords) <*> (string " v=" >> coords)
    coords = (,) <$> num <* char ',' <*> num
    num = read <$> ((++) <$> option "" (string "-") <*> many1 digit)

runBots :: [((Int, Int), (Int, Int))] -> [[(Int, Int)]]
runBots = transpose . map botPath
  where
    botPath (p, (vx, vy)) = iterate (incWrap w vx *** incWrap h vy) p
    incWrap s d = (`mod` s) . (+ d)

safetyFactor :: [(Int, Int)] -> Int
safetyFactor = product . Map.fromListWith (+) . map (,1) . mapMaybe quadrant
  where
    cx = w `div` 2
    cy = h `div` 2
    quadrant (x, y)
      | x == cx || y == cy = Nothing
      | otherwise = Just (x `div` (cx + 1), y `div` (cy + 1))

render :: [(Int, Int)] -> [String]
render bots =
  let counts = Map.fromListWith (+) $ map (,1) bots
   in flip map [0 .. h - 1] $ \y ->
        flip map [0 .. w - 1] $ \x ->
          maybe '.' intToDigit $ counts Map.!? (x, y)

isImage :: [String] -> Bool
isImage = (> 4) . length . filter hasRun
  where
    hasRun = any ((> 3) . length) . filter head . group . map (/= '.')

main = do
  positions <- runBots . readInput <$> readFile "input14"
  print . safetyFactor $ positions !! 100
  let (Just (t, image)) = find (isImage . snd) $ zip [0 ..] $ map render positions
  print t
  mapM_ putStrLn image

Oops! Took me a while to spot it from your comment, too, so don’t feel too bad :)

Line intersection is a nice way of looking at it. My immediate thought was “change of basis”.

Ooh, Cramer’s rule is new to me. That will come in handy if I can remember it next year!

Haskell

Whee, linear algebra! Converting between numeric types is a bit annoying in Haskell, but I’m reasonably happy with this solution.

import Control.Monad
import Data.Matrix qualified as M
import Data.Maybe
import Data.Ratio
import Data.Vector qualified as V
import Text.Parsec

type C = (Int, Int)

readInput :: String -> [(C, C, C)]
readInput = either (error . show) id . parse (machine `sepBy` newline) ""
  where
    machine = (,,) <$> coords <*> coords <*> coords
    coords =
      (,)
        <$> (manyTill anyChar (string ": X") >> anyChar >> num)
        <*> (string ", Y" >> anyChar >> num)
        <* newline
    num = read <$> many1 digit

presses :: (C, C, C) -> Maybe C
presses ((ax, ay), (bx, by), (px, py)) =
  do
    let m = fromIntegral <$> M.fromLists [[ax, bx], [ay, by]]
    m' <- either (const Nothing) Just $ M.inverse m
    let [a, b] = M.toList $ m' * M.colVector (fromIntegral <$> V.fromList [px, py])
    guard $ denominator a == 1
    guard $ denominator b == 1
    return (numerator a, numerator b)

main = do
  input <- readInput <$> readFile "input13"
  mapM_
    (print . sum . map (\(a, b) -> 3 * a + b) . mapMaybe presses)
    [ input,
      map (\(a, b, (px, py)) -> (a, b, (10000000000000 + px, 10000000000000 + py))) input
    ]

Woah! That solution is a work of art!

Haskell

This was a bit of a fiddly one. There’s probably scope for golfing it down some more, but I’ve had enough for today :3

import Control.Arrow
import Data.List
import Data.Map (Map)
import Data.Map qualified as Map
import Data.Set (Set)
import Data.Set qualified as Set

readInput :: String -> Map (Int, Int) Char
readInput s = Map.fromList [((i, j), c) | (i, l) <- zip [0 ..] (lines s), (j, c) <- zip [0 ..] l]

(i1, j1) .+. (i2, j2) = (i1 + i2, j1 + j2)

(i1, j1) .-. (i2, j2) = (i1 - i2, j1 - j2)

directions = [(0, 1), (1, 0), (0, -1), (-1, 0)] :: [(Int, Int)]

edges = zip ps (drop 1 ps) :: [((Int, Int), (Int, Int))]
  where
    ps = [(0, 1), (1, 1), (1, 0), (0, 0), (0, 1)]

regions :: Map (Int, Int) Char -> [Set (Int, Int)]
regions = unfoldr (fmap (uncurry removeRegion) . Map.minViewWithKey)
  where
    removeRegion (p, t) = go Set.empty (Set.singleton p)
      where
        go r ps plots
          | Set.null ps = (r, plots)
          | otherwise =
              let ps' =
                    Set.filter (\p -> plots Map.!? p == Just t) $
                      Set.fromList (concatMap adjacent ps) Set.\\ ps
               in go (Set.union r ps) ps' (Map.withoutKeys plots ps')
        adjacent = (`map` directions) . (.+.)

boundary :: Set (Int, Int) -> Set ((Int, Int), (Int, Int))
boundary region =
  Set.fromList $
    [ (p .+. e1, p .+. e2)
      | p <- Set.elems region,
        (d, (e1, e2)) <- zip directions edges,
        p .+. d `Set.notMember` region
    ]

perimeter :: Set (Int, Int) -> [[(Int, Int)]]
perimeter = unfoldr (fmap (uncurry removeChain) . Set.minView) . boundary
  where
    removeChain e@(e1, e2) es = first (e1 :) $ go [] e es
    go c e@(e1, e2) es =
      case find ((== e2) . fst) es of
        Nothing -> (e1 : c, es)
        Just e' -> go (e1 : c) e' (Set.delete e' es)

countSides :: [(Int, Int)] -> Int
countSides ps = length $ group $ zipWith (.-.) (drop 1 ps) ps

main = do
  input <- readInput <$> readFile "input12"
  let rs = map (Set.size &&& perimeter) $ regions input
  print . sum $ map (\(a, p) -> a * sum (map (subtract 1 . length) p)) rs
  print . sum $ map (\(a, p) -> a * sum (map countSides p)) rs

Your code as it stands is basically State BlinkCache written out explicitly, which is I think a natural way to structure the solution. That is, the cache is the state, and the stone count is the (monadic) return value. Good luck!

The IORef is like a mutable box you can stick things in, so readIORef returns whatever was last put in it (in this case using modifyIORef'). “last” makes sense here because operations are sequenced thanks to the IO monad, so yes: values get carried back up the tree to the caller. There’s also STRef for the ST monad, or I could have used the State monad which (kind of) encapsulates a single ref.

Some nice monadic code patterns going on there, passing the cache around! (You might want to look into the State monad if you haven’t come across it before)

Haskell

Yay, mutation! Went down the route of caching the expanded lists of stones at first. Oops.

import Data.IORef
import Data.Map.Strict (Map)
import Data.Map.Strict qualified as Map

blink :: Int -> [Int]
blink 0 = [1]
blink n
  | s <- show n,
    l <- length s,
    even l =
      let (a, b) = splitAt (l `div` 2) s in map read [a, b]
  | otherwise = [n * 2024]

countExpanded :: IORef (Map (Int, Int) Int) -> Int -> [Int] -> IO Int
countExpanded _ 0 = return . length
countExpanded cacheRef steps = fmap sum . mapM go
  where
    go n =
      let key = (n, steps)
          computed = do
            result <- countExpanded cacheRef (steps - 1) $ blink n
            modifyIORef' cacheRef (Map.insert key result)
            return result
       in readIORef cacheRef >>= maybe computed return . (Map.!? key)

main = do
  input <- map read . words <$> readFile "input11"
  cache <- newIORef Map.empty
  mapM_ (\steps -> countExpanded cache steps input >>= print) [25, 75]

Oooh! Pretty!

I bet that search would look cool visualized.

Haskell

A nice easy one today: didn’t even have to hit this with the optimization hammer.

import Data.Char
import Data.List
import Data.Map (Map)
import Data.Map qualified as Map

readInput :: String -> Map (Int, Int) Int
readInput s =
  Map.fromList
    [ ((i, j), digitToInt c)
      | (i, l) <- zip [0 ..] (lines s),
        (j, c) <- zip [0 ..] l
    ]

findTrails :: Map (Int, Int) Int -> [[[(Int, Int)]]]
findTrails input =
  Map.elems . Map.map (filter ((== 10) . length)) $
    Map.restrictKeys accessible starts
  where
    starts = Map.keysSet . Map.filter (== 0) $ input
    accessible = Map.mapWithKey getAccessible input
    getAccessible (i, j) h
      | h == 9 = [[(i, j)]]
      | otherwise =
          [ (i, j) : path
            | (di, dj) <- [(-1, 0), (0, 1), (1, 0), (0, -1)],
              let p = (i + di, j + dj),
              input Map.!? p == Just (succ h),
              path <- accessible Map.! p
          ]

main = do
  trails <- findTrails . readInput <$> readFile "input10"
  mapM_
    (print . sum . (`map` trails))
    [length . nub . map last, length]

Aww, thank you <3

It’s just practice, I guess? (The maths degree probably doesn’t hurt either)

Second attempt! I like this one much better.

Edit: down to 0.040 secs now!

import Control.Arrow
import Data.Either
import Data.List
import Data.Map (Map)
import Data.Map qualified as Map

type Layout = ([(Int, (Int, Int))], Map Int Int)

readInput :: String -> Layout
readInput =
  map (read . singleton) . head . lines
    >>> (scanl' (+) 0 >>= zip) -- list of (pos, len)
    >>> zipWith ($) (intersperse Right [Left . (id,) | id <- [0 ..]])
    >>> partitionEithers
    >>> filter ((> 0) . snd . snd) *** Map.filter (> 0) . Map.fromAscList

checksum :: Layout -> Int
checksum = sum . map (\(id, (pos, len)) -> id * len * (2 * pos + len - 1) `div` 2) . fst

compact :: (Int -> Int -> Bool) -> Layout -> Layout
compact select (files, spaces) = foldr moveFile ([], spaces) files
  where
    moveFile file@(fileId, (filePos, fileLen)) (files, spaces) =
      let candidates = Map.assocs $ fst . Map.split filePos $ spaces
       in case find (select fileLen . snd) candidates of
            Just (spacePos, spaceLen) ->
              let spaces' = Map.delete spacePos spaces
               in if spaceLen >= fileLen
                    then
                      ( (fileId, (spacePos, fileLen)) : files,
                        if spaceLen == fileLen
                          then spaces'
                          else Map.insert (spacePos + fileLen) (spaceLen - fileLen) spaces'
                      )
                    else
                      moveFile
                        (fileId, (filePos + spaceLen, fileLen - spaceLen))
                        ((fileId, (spacePos, spaceLen)) : files, spaces')
            Nothing -> (file : files, spaces)

main = do
  input <- readInput <$> readFile "input09"
  mapM_ (print . checksum . ($ input) . compact) [const $ const True, (<=)]

Haskell

Not a lot of time to come up with a pretty solution today; sorry.

import Data.List
import Data.Maybe
import Data.Sequence (Seq)
import Data.Sequence qualified as Seq

readInput :: String -> Seq (Maybe Int, Int)
readInput =
  Seq.fromList
    . zip (intersperse Nothing $ map Just [0 ..])
    . (map (read . singleton) . head . lines)

expand :: Seq (Maybe Int, Int) -> [Maybe Int]
expand = concatMap (uncurry $ flip replicate)

compact :: Seq (Maybe Int, Int) -> Seq (Maybe Int, Int)
compact chunks =
  case Seq.spanr (isNothing . fst) chunks of
    (suffix, Seq.Empty) -> suffix
    (suffix, chunks' Seq.:|> file@(_, fileSize)) ->
      case Seq.breakl (\(id, size) -> isNothing id && size >= fileSize) chunks' of
        (_, Seq.Empty) -> compact chunks' Seq.>< file Seq.<| suffix
        (prefix, (Nothing, gapSize) Seq.:<| chunks'') ->
          compact $ prefix Seq.>< file Seq.<| (Nothing, gapSize - fileSize) Seq.<| chunks'' Seq.>< (Nothing, fileSize) Seq.<| suffix

part1, part2 :: Seq (Maybe Int, Int) -> Int
part1 input =
  let blocks = dropWhileEnd isNothing $ expand input
      files = catMaybes blocks
      space = length blocks - length files
      compacted = take (length files) $ fill blocks (reverse files)
   in sum $ zipWith (*) [0 ..] compacted
  where
    fill (Nothing : xs) (y : ys) = y : fill xs ys
    fill (Just x : xs) ys = x : fill xs ys
part2 = sum . zipWith (\i id -> maybe 0 (* i) id) [0 ..] . expand . compact

main = do
  input <- readInput <$> readFile "input09"
  print $ part1 input
  print $ part2 input

I mean, sure you can combine rectangles to make any path, but since there is no upper limit I don’t think that will help much. You may be on to something and I just can’t see it, though! Good luck!