Advent of code 2024

This year will do it in Haskell, but might try few days in Rust as well

• Day 1
• Day 2
• Day 3
• Day 4
• Day 5
• Day 6
• Day 7
• Day 8
• Day 9
• Day 10
• Day 11
• Day 12
• Day 13
• Day 14
• Day 15
• Day 16
• [?] Day 17
• Day 18
• Day 19
• Day 20
• Day 21
• Day 22
• Day 23
• Day 24
• Day 25

---

Feedback

Day 1:

As every year, still a bit rusty but managed to do it anyways

Day 2:

Still rusty even found the part2 a bit difficult (might have been trying to do something opti since the beginning but that complexified a lot....)

Day 3:

Today seemed complicated at first with the parsing but actually instead of using Read instances as I planned at the beginning, using Regex was easier. The part 2 didn't suprise me too much, I just thought there would have been more operations instead of just do don't and mul...

Day 4:

Interesting puzzle, quite happy of my solution and the possible ways to debug it.

I cleaned it afterward since debugging is no more needed but was an interesting day

Day 5:

First part nice

Second part subject does not seem complete enough

1|2
5|4
2|3
3|4

2,3,5,4,1

With this example a correct order could be 1,2,3,5,4 or 1,2,5,3,4 or 1,5,2,3,4 or 5,1,2,3,4 there is no way to decide. If it's the same thing in the inputs -> some valid solutions won't work

and worse there even are some circular dependencies in my input :

16|11
11|19
19|16

Not nice at all, if it's a page ordering => impossible to print some of the updates

(I understand that might be the goal of the exercise but then this lore can't work....)

So instead of creating a perfect list and choosing the elements inside, I need to create a valid list each time => way higher time complexity

Day 6:

Quite happy about today managed to find a solution quite fast and minimize the amount of parsing

The only thing is that my code is quite ugly at the moment

For the part 2 I managed to speed up my solution :

• At first I tried adding a wall on every free spot using lists as memory => estimated 180mins
• Changing the memory list to a Set memory => 3mins
• Filtering the positions to only places where the guard passes in the their usual path => 30sec
• Adding -O2 => ~10sec
• Switching to Matrices instead of raw [String] => ~5.5s
• Multithreading => ~6s (runs slightly slower but at least I have a reference to use multithreading)

Day 7:

Today was really easy In order to optimize, I had to add profile costs centers check what operations took the most time

At first the bottle neck was the operation concatNb, I did it like read (show a) (show b) but I don't really need to read

So the solution was just to shift a to the left by multiplying it by ((^) 10) . length $ show b. This does for example with 42 and 24 : 42* 10^2 => 4200 and then only (+) => 4224

At the moment the bottle neck is the operation (*) so no really my fault.

Day 8:

Todays was also fun.

Since solution already is at 0.03s, there is no need to optimize.

Instead I had fun creating a function to preview the actual grid at each step, you just have to uncomment the lines in main to see it.

Day 9:

Today was nice, was not as easy but was fun to think about and find optimized solutions

My solution is not that fast today ~1m30s might try to optimize it further but at the moment need to work on other things (ghc profiler decided not to profile my costs centers)

So I indeed took time to do some optimizations, now I run in 2s.

The main reason for this time improvement is because I now play using a tuple (id, size) and not just the id, hence less items to loop through

Tried more optimizations such as saving the first valid free spot but this was only slowing things down

Day 10:

Today was so short that I didn't even take time to enjoy it...

It was like asking 2+2...

Day 11:

First part was interesting, managed to realize that ++ is the worst operator ever and that you should always use concat instead

For the second part, I managed to optimize and go up to 38 quite far from the required 75

Tried to multithread it (in the iterateStones change map to parMap rseq) but it only slowed things down... (for target 35 had 4s in normal map and 12 using rseq...)

• rseq : 12
• r0 : 11.7
• rdeepseq: 9.6
• rpar : 12.7

Might try looking for loops and similar things

I finally got it, the solution I found was to use memoization

At first I had 2 maps :

• First map for the result of the algorithm given an element (not much gain)
• Second one for the number of stones after n blinks with the stone

Since the first map didn't help, I tried to clean up and realized it was really useless so I removed it completely

Had fun doing it in python as well, strangely python is faster than haskell

Day 12:

That was a nice puzzle.

Might have been a bit easy but was interesting and difficult enough to have to think about it.

The only downside is what my solution looks like...

Cleaned that up a bit but still not great

Day 13:

Not a huge fan of today

At least not in haskell

First I tried the greedy method of finding the nb of button presses by simulating every combinations. Gave me answer for part1 but impossible for part2

Then I thought about solving Diophantine equations but seemed too much of a mess to find result, adjust them since I had to do them twice and find a potential balance

So the last solution was to use matrices, but then the Double precision was still not good. I thought that to determine if a number was an Int I could compare by 1e-10 seemed low and steady. But actually my solution works in haskell only for epsilon between [1e-2, 1e-3] so that does not leave much room for errors. The worst thing is that since it's so small it was a guessing game to have the same result as another solution found on reddit, since at first I thought I had a mistake in my calculations but found nothing of the sort.....

Day 14:

Today was quite simple.

I am not a huge fan of part2 today, telling us "Hey there will be a christmas tree" without telling us anything else ??? Like and example tree would have been nice or the size of the tree or anything about it...

Day 15:

Today was interesting, it was not either too easy nor coming from nowhere

Even though my solution is very ugly, today I don't think I will clean it up.

Day 16:

Nice and interesting puzzle today

Basically a simple path finding but with a few twists that make it fun

Will try to optimize solution

Edit: Haven't found any easy optimization

I know a way to optimize : Have another Map containing this time the set of valid spots => if already been on a position no need to do it again even from another good path.

For example

#######
#....E#
#.#.###
#S..###
#######

The first path explored will be this one

#######
#..OOE#
#.#O###
#SOO###
#######

But then at the moment when I reach the last intersection I need to go back up to the end

#######
#OOXXE#
#O#.###
#S..###
#######

The optimization would allow me to skip this last part represented with X

Day17

The first part was a simple computer simulation.

For the second one I didn't really succeed on my own...

Sadly in order to find the result I had to look at tips on how to solve it.

Basically each instruction corresponds to a byte in the register A

The register A is basically reduced like out A%8, A = A/8, so to build the register A you just have to go backward :

• For the last instruction, check all results for regA in [0..7]
• For the one before, check all the results for regA in [prev*8..prev*8+7]
• Continue recursively until you get all the numbers

Even though I didn't solve this one on my own I learnt how to analyze the output in order to find results

Day 18:

Nice and easy day today

Solution is a bit slow so will try to optimize it.

Mainly the second part, I already only look for a path if the current position is in the previous path.

To get the said path I tried with the smallest and the first, it works better with the smallest (less chance to fall on the path => less paths to find)

First version :

At first I used a DFS to find the smallest path for both part1 and part2.

smallestPathFind :: Set (Int, Int) -> Map (Int, Int) Int -> (Int, Int) -> (Int, Int) -> Int -> (Int, Set (Int, Int), Map (Int, Int) Int)
smallestPathFind memory seen pos target nbMoves
  | isOut target pos = (-1, S.empty, seen)
  | pos `M.member` seen && seen M.! pos <= nbMoves = (-1, S.empty, seen)
  | pos `S.member` memory = (-1, S.empty, currSeen)
  | pos == target = (nbMoves, S.singleton target, currSeen)
  | length bestSol /= 0 = (bestMoves, S.insert pos bestPath, seenRight)
  | otherwise = (-1, S.empty, seenRight)
  where
    currSeen = M.insert pos nbMoves seen
    (movesUp, pathUp, seenUp) = smallestPathFind memory currSeen (move pos UP) target (nbMoves + 1)
    (movesLeft, pathLeft, seenLeft) = smallestPathFind memory seenUp (move pos LEFT) target (nbMoves + 1)
    (movesDown, pathDown, seenDown) = smallestPathFind memory seenLeft (move pos DOWN) target (nbMoves + 1)
    (movesRight, pathRight, seenRight) = smallestPathFind memory seenDown (move pos RIGHT) target (nbMoves + 1)

    bestSol = sortOn fst . filter ((/= -1) . fst) $ [(movesUp, pathUp), (movesLeft, pathLeft), (movesDown, pathDown), (movesRight, pathRight)]
    (bestMoves, bestPath) = head bestSol

{- Simple part2 version using previous found path as condition to find a new path -}
sub n mem [] lastPath = (-1, -1)
sub n mem (e : l) lastPath
  | e `S.notMember` lastPath = sub (n + 1) newMem l lastPath
  | currRes == -1 = swap e
  | otherwise = sub (n + 1) newMem l currPath
  where
    newMem = S.insert e mem
    (currRes, currPath, _) = smallestPathFind newMem M.empty (0, 0) (range, range) 0

Time : ~25s

Second Version :

Then I thought that for the second part any path could do the trick So instead of the smallest path, I changed the algorithm to return the first path found. This method didn't work and was actually slower than the previous version. The time saved by taking the first solution isn't worth the additional number of path to find when a position is in this new bigger path.

anyPathFind :: Set (Int, Int) -> Map (Int, Int) Int -> (Int, Int) -> (Int, Int) -> Int -> (Int, Set (Int, Int), Map (Int, Int) Int)
anyPathFind memory seen pos target nbMoves
  | isOut target pos = (-1, S.empty, seen)
  | pos `M.member` seen && seen M.! pos <= nbMoves = (-1, S.empty, seen)
  | pos `S.member` memory = (-1, S.empty, currSeen)
  | pos == target = (nbMoves, S.singleton target, currSeen)
  | movesUp /= -1 = (movesUp, S.insert pos pathUp, seenUp)
  | movesLeft /= -1 = (movesLeft, S.insert pos pathLeft, seenLeft)
  | movesDown /= -1 = (movesDown, S.insert pos pathDown, seenDown)
  | movesRight /= -1 = (movesRight, S.insert pos pathRight, seenRight)
  | otherwise = (-1, S.empty, seenRight)
  where
    currSeen = M.insert pos nbMoves seen
    (movesUp, pathUp, seenUp) = anyPathFind memory currSeen (move pos UP) target (nbMoves + 1)
    (movesLeft, pathLeft, seenLeft) = anyPathFind memory seenUp (move pos LEFT) target (nbMoves + 1)
    (movesDown, pathDown, seenDown) = anyPathFind memory seenLeft (move pos DOWN) target (nbMoves + 1)
    (movesRight, pathRight, seenRight) = anyPathFind memory seenDown (move pos RIGHT) target (nbMoves + 1)

Time : ~40s

Third Version :

Then Raphaël Montes (Sheinxy) made me think about BFS that are actually way faster in this case. So here is my implementation.

bfs :: Set (Int, Int) -> (Int, Int) -> Set (Int, Int) -> Set (Int, Int) -> Int -> Int
bfs memory target seen curr acc
  | S.null curr = -1
  | target `S.member` curr = acc
  | otherwise = bfs memory target (S.union seen curr) newCurr (acc + 1)
  where
    notSeen = curr S.\\ seen
    notInWall = notSeen S.\\ memory
    notOut = S.filter (not . isOut target) notInWall
    newCurr = S.fromList . concat . map (\p -> map (move p) [UP, LEFT, RIGHT, DOWN]) $ S.toList notOut

{- Another Simple sub using BFS but not keeping memory of previous paths-}
sub n mem [] = (-1, -1)
sub n mem (e : l)
  | currRes == -1 = swap e
  | otherwise = sub (n + 1) newMem l
  where
    newMem = S.insert e mem
    currRes = bfs newMem (range, range) S.empty (S.singleton (0, 0)) 0

Time : ~13s

Fourth Version:

By using my two previous best versions I tried to do part2 using a bfs that returns the path. So instead of calculating the path each time, I only do it when the position would block the previous path found.

bfs :: Set (Int, Int) -> (Int, Int) -> Set (Int, Int) -> Set (Int, Int) -> Map (Int, Int) (Set (Int, Int)) -> Set (Int, Int)
bfs memory target seen curr paths
  | S.null curr = S.empty
  | target `S.member` curr = paths M.! target
  | otherwise = bfs memory target (S.union seen curr) newCurr newPaths
  where
    notSeen = curr S.\\ seen
    notInWall = notSeen S.\\ memory
    notOut = S.filter (not . isOut target) notInWall

    f2 p (curr', paths') p' = (S.insert p' curr', M.insert p' (S.insert p' (paths M.! p)) paths')
    f1 cp p = foldl (f2 p) cp $ map (move p) [UP, LEFT, RIGHT, DOWN]
    (newCurr, newPaths) = S.foldl f1 (S.empty, M.empty) notOut

part2 :: Int -> Int -> Input -> (Int, Int)
part2 range firstBatch input = sub memory (drop firstBatch input) (findPath memory)
  where
    memory = S.fromList $ take firstBatch input
    findPath m = bfs2 m (range, range) S.empty (S.singleton (0, 0)) (M.singleton (0, 0) S.empty)
    sub mem [] lastPath = (-1, -1)
    sub mem (e : l) lastPath
      | e `S.notMember` lastPath = sub newMem l lastPath
      | S.null currPath = swap e
      | otherwise = sub newMem l currPath
      where
        newMem = S.insert e mem
        currPath = findPath newMem

Time : 0.3s

Last Version:

After this interesting idea, Raphaël Montes had another one : dichotomic search which is my last version

Time : ~0.08s

Day19:

Today was nice and easy.

First I tried the brute force DFS approach then when I realized it was way too long, I decided to switch to a BFS approach using sets.

This solution worked for part1 but then with Sets, part2 was not possible so I thought of another way using a lookup table for already found solutions.

Day20:

Day was interesting, solution is quite slow

part1: 30mins part2: 10mins

Day21:

This day was hard.

Like really hard.

Took me all day to do it (part2 finished at 7:20pm).

I didn't really like the lore, like if the robots are not made for pushing buttons, how can they even know to crash when they're not in front of one...

Even more, at what speed is the main character pushing the buttons to be able to push ~3e14 of them...

Day22:

This one was simpler.

I had to wake early so I was on my computer at the start.

Got stuck on stupid things for a bit of part1 and around ~30mins in part2

Optimizations:

Without the optimizations my solution ran in about 4mins

The main bottle neck is at the moment where I get the previous differences and match the price with its prefix.

withDiffPrefix = map (\n -> map (\i -> (fst (n !! (i + 4)), map snd $ take 4 $ drop i n)) [0 .. 1996]) $ pricesDiff

Here it is easy to understand that each time, getting a random element, dropping X elements and taking the four next ones is quite long.

So an optimization that seemed ok was to cycle through the list without having to cycle through every elements all the time.

withDiffPrefix = map (\n -> reverse . fst3 $ foldr (\_ r -> third3 (drop 1) . second3 (drop 1) $ first3 ((fst $ head $ thd3 r, map snd $ take 4 $ snd3 r) :) r) ([], n, drop 4 n) $ [0 .. 1996]) $ pricesDiff

Another version taking the same time using this time tails instead

withDiffPrefix = map (\n -> take 1997 $ map (\l -> (fst (l !! (4)), map snd $ take 4 $ l)) $ tails n) $ pricesDiff

Now the time is taken in the sort algorithm

sortedByDiffPref = sortOn snd . concat $ map (uniqBy snd) $ withDiffPrefix

I thought that it could be possible to optimize by sorting each list and then merging them together but this try was not successful

mergeSortOn :: (Eq a, Ord b) => (a -> b) -> [[a]] -> [a]
mergeSortOn f m = merge f . filter (/= []) $ map (sortOn f) m
  where
    merge f [] = []
    merge f l
      | mid /= [] = merge f newL
      | otherwise = merge f $ concat [first, after]
      where
        mini = fst . minimumBy (compare `on` (f . head . snd)) $ zip [0 ..] l
        (first, (e : mid) : after) = splitAt mini l
        newL = concat [first, [mid], after]

On the other hand it was possible to optimize the uniqBy function I created :

uniqBy :: (Ord b) => (a -> b) -> [a] -> [a]
uniqBy f l = sub f l S.empty
  where
    sub :: (Ord b) => (a -> b) -> [a] -> Set b -> [a]
    sub f [] _ = []
    sub f (e : l) seen
      | (f e) `S.member` seen = sub f l seen
      | otherwise = e : sub f l (S.insert (f e) seen)

This version kept me at 36s

Using a Set meant that the input didn't have to be sorted but that actually backfired and is was not useful

The other way, to first sort then discard any duplicate was more successful

uniqBy :: (Ord b) => (a -> b) -> [a] -> [a]
uniqBy f [] = []
uniqBy f (e : l) = e : sub f (f e) l
  where
    sub :: (Ord b) => (a -> b) -> b -> [a] -> [a]
    sub f _ [] = []
    sub f lastE (e : l)
      | currVal == lastE = sub f lastE l
      | otherwise = e : sub f currVal l
      where
        currVal = f e

Getting now down to 13s

The main bottlenecks are now:

• sortedByDiffPref with 65% of the total time
• withDiffPrefix with 23% of the total time

I might try to optimize this day further later on

Day23:

Today was interesting.

Didn't have much time and was not super difficult nor completely given.

I was afraid using graph visualizers could solve instantly but I don't think it can. I might try that later just to see for part2 though.

Optimizations:

Base version

part2 :: Input -> String
part2 input = join "," . sort $ S.toList biggest
  where
    isLan s = all (\e -> S.isSubsetOf s $ (S.insert e) $ input M.! e) s
    lansOf k = S.filter isLan . S.powerSet . S.insert k $ (input M.! k)
    lans = S.unions . map lansOf $ M.keys input
    biggest = maximumBy (compare `on` S.size) lans

Time: 18s

To try I tried to change the S.insert to the opposite S.delete

part2 :: Input -> String
part2 input = join "," . sort $ S.toList biggest
  where
    isLan s = all (\e -> S.isSubsetOf (S.delete e s) $ input M.! e) s
    lansOf k = S.filter isLan . S.powerSet . S.insert k $ (input M.! k)
    lans = S.unions . map lansOf $ M.keys input
    biggest = maximumBy (compare `on` S.size) lans

Time: 16s

Then I tried to remove the number of calls to isLan

part2 :: Input -> String
part2 input = join "," . sort $ S.toList biggest
  where
    isLan s = all (\e -> S.isSubsetOf (S.delete e s) $ input M.! e) s
    lansOf k = S.powerSet . S.insert k $ (input M.! k)
    lans = S.filter isLan . S.unions . map lansOf $ M.keys input
    biggest = maximumBy (compare `on` S.size) lans

Time: 12.6s

Another idea to decrease the number of calls to isLan was to first sort by S.size then take the first valid lan.

part2 :: Input -> String
part2 input = join "," . sort $ S.toList biggest
  where
    isLan s = all (\e -> S.isSubsetOf (S.delete e s) $ input M.! e) s
    lansOf k = S.powerSet . S.insert k $ (input M.! k)
    lans = S.unions . map lansOf $ M.keys input
    biggest = head . filter isLan . reverse . sortBy (compare `on` S.size) $ S.toList lans

The issue with this one is that the sorting takes more time than the calls to isLan so instead of 12s it actually takes longer.

Time: 19s

Anyway the time is not as much in isLan anymore:

• isLan: 37%
• lans: 54%

Could try and look further but I don't really have time now.

Day24:

This day was... hmmm interesting...

Didn't manage to automatize the second part, only did it by hand.

Day25:

This day was really easy.

Will try later to wrap up this year (few optimizations and Day24 part2)