• 1 Post
  • 29 Comments
Joined 1 year ago
Cake day: June 12th, 2023
  • Leo Uino@lemmy.sdf.orgtoAdvent Of Code@programming.dev•P.D AoC Leaderboard Results
    9·
    10 months ago

    Maybe it was due to attempting the puzzles in real-time for the first time, but it felt like there was quite a spike in difficulty this year. Day 5 (If You Give A Seed A Fertilizer) in particular was pretty tough for an early puzzle.

    Day 8 (Haunted Wasteland), Day 20 (Pulse Propagation) and Day 21 (Step Counter) were (I felt) a bit mean due to hidden properties of the input data.

    I particularly liked Day 6 (Wait For It), Day 14 (Parabolic Reflector Dish) and Day 24 (Never Tell Me The Odds), although that one made my brain hurt.

    Day 25 (Snowverload) had me reading research papers, although in the end I stumbled across Karger’s algorithm. That’s the first time I’ve used a probabilistic approach. This solution in particular was very clever.

    I learned the Shoelace formula and Pick’s theorem this year, which will be very helpful to remember.

    Perhaps I’ll try using Prolog or J next year :)

  • Leo Uino@lemmy.sdf.orgtoAdvent Of Code@programming.dev•🛶 - 2023 DAY 18 SOLUTIONS -🛶
    1·
    11 months ago

    Haskell

    Wasn’t able to start on time today, but this was a fun one! Got to apply the two theorems I learned from somebody else’s solution to Day 10.

    Solution 
    import Data.Char
import Data.List

readInput :: String -> (Char, Int, String)
readInput s =
  let [d, n, c] = words s
   in (head d, read n, drop 2 $ init c)

boundary :: [(Char, Int)] -> [(Int, Int)]
boundary = scanl' step (0, 0)
  where
    step (x, y) (d, n) =
      let (dx, dy) = case d of
            'U' -> (0, 1)
            'D' -> (0, -1)
            'L' -> (-1, 0)
            'R' -> (1, 0)
       in (x + n * dx, y + n * dy)

area :: [(Char, Int)] -> Int
area steps =
  let a = -- shoelace formula
        (abs . (`quot` 2) . sum)
          . (zipWith (\(x, y) (x', y') -> x * y' - x' * y) <*> tail)
          $ boundary steps
   in a + 1 + sum (map snd steps) `quot` 2 -- Pick's theorem

part1, part2 :: [(Char, Int, String)] -> Int
part1 = area . map (\(d, n, _) -> (d, n))
part2 = area . map (\(_, _, c) -> decode c)
  where
    decode s = ("RDLU" !! digitToInt (last s), read $ "0x" ++ init s)

main = do
  input <- map readInput . lines <$> readFile "input18"
  print $ part1 input
  print $ part2 input
  • Leo Uino@lemmy.sdf.orgtoAdvent Of Code@programming.dev•[2023 Day 17] [Rust] Optimizing day 17 (spoilers)
    1·
    11 months ago

    Some (not very insightful or helpful) observations:

    • The shortest path is likely to be mostly monotonic (it’s quite hard for the “long way round” to be cost-effective), so the Manhattan distance is probably a good metric.
    • The center of the puzzle is expensive, so the straight-line distance is probably not a good metric
    • I’m pretty sure that the shortest route (for part one at least) can’t self-intersect. Implementing this constraint is probably not going to speed things up, and there might be some pathological case where it’s not true.

    Not an optimization, but I suspect that a heuristic-based “reasonably good” path such as a human would take will be fairly close to optimal.

  • Leo Uino@lemmy.sdf.orgtoAdvent Of Code@programming.dev•🍵 - 2023 DAY 17 SOLUTIONS -🍵
    2·
    11 months ago

    Haskell

    Wowee, I took some wrong turns solving today’s puzzle! After fixing some really inefficient pruning I ended up with a Dijkstra search that runs in 2.971s (for a less-than-impressive 124.782 l-s).

    Solution 
    import Control.Monad
import Data.Array.Unboxed (UArray)
import qualified Data.Array.Unboxed as Array
import Data.Char
import qualified Data.HashSet as Set
import qualified Data.PQueue.Prio.Min as PQ

readInput :: String -> UArray (Int, Int) Int
readInput s =
  let rows = lines s
   in Array.amap digitToInt
        . Array.listArray ((1, 1), (length rows, length $ head rows))
        $ concat rows

walk :: (Int, Int) -> UArray (Int, Int) Int -> Int
walk (minStraight, maxStraight) grid = go Set.empty initPaths
  where
    initPaths = PQ.fromList [(0, ((1, 1), (d, 0))) | d <- [(0, 1), (1, 0)]]
    goal = snd $ Array.bounds grid
    go done paths =
      case PQ.minViewWithKey paths of
        Nothing -> error "no route"
        Just ((n, (p@(y, x), hist@((dy, dx), k))), rest)
          | p == goal && k >= minStraight -> n
          | (p, hist) `Set.member` done -> go done rest
          | otherwise ->
              let next = do
                    h'@((dy', dx'), _) <-
                      join
                        [ guard (k >= minStraight) >> [((dx, dy), 1), ((-dx, -dy), 1)],
                          guard (k < maxStraight) >> [((dy, dx), k + 1)]
                        ]
                    let p' = (y + dy', x + dx')
                    guard $ Array.inRange (Array.bounds grid) p'
                    return (n + grid Array.! p', (p', h'))
               in go (Set.insert (p, hist) done) $
                    (PQ.union rest . PQ.fromList) next

main = do
  input <- readInput <$> readFile "input17"
  print $ walk (0, 3) input
  print $ walk (4, 10) input

    (edited for readability)

  • Leo Uino@lemmy.sdf.orgtoAdvent Of Code@programming.dev•🦌 - 2023 DAY 16 SOLUTIONS -🦌
    2·
    11 months ago

    Haskell

    A pretty by-the-book “walk all paths” algorithm. This could be made a lot faster with some caching.

    Solution 
    import Control.Monad
import Data.Array.Unboxed (UArray)
import qualified Data.Array.Unboxed as A
import Data.Foldable
import Data.Set (Set)
import qualified Data.Set as Set

type Pos = (Int, Int)

readInput :: String -> UArray Pos Char
readInput s =
  let rows = lines s
   in A.listArray ((1, 1), (length rows, length $ head rows)) $ concat rows

energized :: (Pos, Pos) -> UArray Pos Char -> Set Pos
energized start grid = go Set.empty $ Set.singleton start
  where
    go seen beams
      | Set.null beams = Set.map fst seen
      | otherwise =
          let seen' = seen `Set.union` beams
              beams' = Set.fromList $ do
                ((y, x), (dy, dx)) <- toList beams
                d'@(dy', dx') <- case grid A.! (y, x) of
                  '/' -> [(-dx, -dy)]
                  '\\' -> [(dx, dy)]
                  '|' | dx /= 0 -> [(-1, 0), (1, 0)]
                  '-' | dy /= 0 -> [(0, -1), (0, 1)]
                  _ -> [(dy, dx)]
                let p' = (y + dy', x + dx')
                    beam' = (p', d')
                guard $ A.inRange (A.bounds grid) p'
                guard $ beam' `Set.notMember` seen'
                return beam'
           in go seen' beams'

part1 = Set.size . energized ((1, 1), (0, 1))

part2 input = maximum counts
  where
    (_, (h, w)) = A.bounds input
    starts =
      concat $
        [[((y, 1), (0, 1)), ((y, w), (0, -1))] | y <- [1 .. h]]
          ++ [[((1, x), (1, 0)), ((h, x), (-1, 0))] | x <- [1 .. w]]
    counts = map (\s -> Set.size $ energized s input) starts

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

    A whopping 130.050 line-seconds!

  • Leo Uino@lemmy.sdf.orgtoAdvent Of Code@programming.dev•🎄 - 2023 DAY 15 SOLUTIONS -🎄
    4·
    11 months ago

    Haskell

    Took a while to figure out what part 2 was all about. Didn’t have the energy to golf this one further today, so looking forward to seeing the other solutions!

    Solution

    0.3 line-seconds

    import Data.Char
import Data.List
import Data.List.Split
import qualified Data.Vector as V

hash :: String -> Int
hash = foldl' (\a c -> ((a + ord c) * 17) `rem` 256) 0

hashmap :: [String] -> Int
hashmap = focus . V.toList . foldl' step (V.replicate 256 [])
  where
    focus = sum . zipWith focusBox [1 ..]
    focusBox i = sum . zipWith (\j (_, z) -> i * j * z) [1 ..] . reverse
    step boxes s =
      let (label, op) = span isLetter s
          i = hash label
       in case op of
            ['-'] -> V.accum (flip filter) boxes [(i, (/= label) . fst)]
            ('=' : z) -> V.accum replace boxes [(i, (label, read z))]
    replace ls (n, z) =
      case findIndex ((== n) . fst) ls of
        Just j ->
          let (a, _ : b) = splitAt j ls
           in a ++ (n, z) : b
        Nothing -> (n, z) : ls

main = do
  input &lt;- splitOn "," . head . lines &lt;$> readFile "input15"
  print $ sum . map hash $ input
  print $ hashmap input
  • Leo Uino@lemmy.sdf.orgtoAdvent Of Code@programming.dev•🍪 - 2023 DAY 14 SOLUTIONS -🍪
    5·
    11 months ago

    Haskell

    A little slow (1.106s on my machine), but list operations made this really easy to write. I expect somebody more familiar with Haskell than me will be able to come up with a more elegant solution.

    Nevertheless, 59th on the global leaderboard today! Woo!

    Solution 
    import Data.List
import qualified Data.Map.Strict as Map
import Data.Semigroup

rotateL, rotateR, tiltW :: Endo [[Char]]
rotateL = Endo $ reverse . transpose
rotateR = Endo $ map reverse . transpose
tiltW = Endo $ map tiltRow
  where
    tiltRow xs =
      let (a, b) = break (== '#') xs
          (os, ds) = partition (== 'O') a
          rest = case b of
            ('#' : b') -> '#' : tiltRow b'
            [] -> []
       in os ++ ds ++ rest

load rows = sum $ map rowLoad rows
  where
    rowLoad = sum . map (length rows -) . elemIndices 'O'

lookupCycle xs i =
  let (o, p) = findCycle 0 Map.empty xs
   in xs !! if i &lt; o then i else (i - o) `rem` p + o
  where
    findCycle i seen (x : xs) =
      case seen Map.!? x of
        Just j -> (j, i - j)
        Nothing -> findCycle (i + 1) (Map.insert x i seen) xs

main = do
  input &lt;- lines &lt;$> readFile "input14"
  print . load . appEndo (tiltW &lt;> rotateL) $ input
  print $
    load $
      lookupCycle
        (iterate (appEndo $ stimes 4 (rotateR &lt;> tiltW)) $ appEndo rotateL input)
        1000000000

    42.028 line-seconds

  • Leo Uino@lemmy.sdf.orgtoAdvent Of Code@programming.dev•🌟 - 2023 DAY 13 SOLUTIONS -🌟
    6·
    11 months ago

    Haskell

    This was fun and (fairly) easy! Off-by-one errors are a likely source of bugs here.

    import Control.Monad
import Data.List
import Data.List.Split
import Data.Maybe

score d pat = ((100 *) &lt;$> search pat) `mplus` search (transpose pat)
  where
    search pat' = find ((d ==) . rdiff pat') [1 .. length pat' - 1]
    rdiff pat' i =
      let (a, b) = splitAt i pat'
       in length $ filter (uncurry (/=)) $ zip (concat $ reverse a) (concat b)

main = do
  input &lt;- splitOn [""] . lines &lt;$> readFile "input13"
  let go d = print . sum . map (fromJust . score d) $ input
  go 0
  go 1

    Line-seconds score: 0.102 😉

  • Leo Uino@lemmy.sdf.orgtoAdvent Of Code@programming.dev•🎁 - 2023 DAY 12 SOLUTIONS -🎁
    4·
    11 months ago

    Haskell

    Phew! I struggled with this one. A lot of the code here is from my original approach, which cuts down the search space to plausible positions for each group. Unfortunately, that was still way too slow…

    It took an embarrassingly long time to try memoizing the search (which made precomputing valid points far less important). Anyway, here it is!

    Solution 
    {-# LANGUAGE LambdaCase #-}

import Control.Monad
import Control.Monad.State
import Data.List
import Data.List.Split
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Maybe

readInput :: String -> ([Maybe Bool], [Int])
readInput s =
  let [a, b] = words s
   in ( map (\case '#' -> Just True; '.' -> Just False; '?' -> Nothing) a,
        map read $ splitOn "," b
      )

arrangements :: ([Maybe Bool], [Int]) -> Int
arrangements (pat, gs) = evalState (searchMemo 0 groups) Map.empty
  where
    len = length pat
    groups = zipWith startPoints gs $ zip minStarts maxStarts
      where
        minStarts = scanl (\a g -> a + g + 1) 0 $ init gs
        maxStarts = map (len -) $ scanr1 (\g a -> a + g + 1) gs
        startPoints g (a, b) =
          let ps = do
                (i, pat') &lt;- zip [a .. b] $ tails $ drop a pat
                guard $
                  all (\(p, x) -> maybe True (== x) p) $
                    zip pat' $
                      replicate g True ++ [False]
                return i
           in (g, ps)
    clearableFrom i =
      fmap snd $
        listToMaybe $
          takeWhile ((&lt;= i) . fst) $
            dropWhile ((&lt; i) . snd) clearableRegions
      where
        clearableRegions =
          let go i [] = []
              go i pat =
                let (a, a') = span (/= Just True) pat
                    (b, c) = span (== Just True) a'
                 in (i, i + length a - 1) : go (i + length a + length b) c
           in go 0 pat
    searchMemo :: Int -> [(Int, [Int])] -> State (Map (Int, Int) Int) Int
    searchMemo i gs = do
      let k = (i, length gs)
      cached &lt;- gets (Map.!? k)
      case cached of
        Just x -> return x
        Nothing -> do
          x &lt;- search i gs
          modify (Map.insert k x)
          return x
    search i gs | i >= len = return $ if null gs then 1 else 0
    search i [] = return $
      case clearableFrom i of
        Just b | b == len - 1 -> 1
        _ -> 0
    search i ((g, ps) : gs) = do
      let maxP = maybe i (1 +) $ clearableFrom i
          ps' = takeWhile (&lt;= maxP) $ dropWhile (&lt; i) ps
      sum &lt;$> mapM (\p -> let i' = p + g + 1 in searchMemo i' gs) ps'

expand (pat, gs) =
  (intercalate [Nothing] $ replicate 5 pat, concat $ replicate 5 gs)

main = do
  input &lt;- map readInput . lines &lt;$> readFile "input12"
  print $ sum $ map arrangements input
  print $ sum $ map (arrangements . expand) input
  • Leo Uino@lemmy.sdf.orgtoAdvent Of Code@programming.dev•🌟 - 2023 DAY 6 SOLUTIONS -🌟
    4·
    11 months ago

    Haskell

    This problem has a nice closed form solution, but brute force also works.

    (My keyboard broke during part two. Yet another day off the bottom of the leaderboard…)

    import Control.Monad
import Data.Bifunctor
import Data.List

readInput :: String -> [(Int, Int)]
readInput = map (\[t, d] -> (read t, read d)) . tail . transpose . map words . lines

-- Quadratic formula
wins :: (Int, Int) -> Int
wins (t, d) =
  let c = fromIntegral t / 2 :: Double
      h = sqrt (fromIntegral $ t * t - 4 * d) / 2
   in ceiling (c + h) - floor (c - h) - 1

main = do
  input &lt;- readInput &lt;$> readFile "input06"
  print $ product . map wins $ input
  print $ wins . join bimap (read . concatMap show) . unzip $ input