Skip to content

Commit a3b2b5b

Browse files
goblivendgoblivend
committed
opti(2024/Day18)
1 parent 80d03ac commit a3b2b5b

File tree

2 files changed

+175
-64
lines changed

2 files changed

+175
-64
lines changed

‎2024/Day18/Day18.hs

+32-64
Original file line numberDiff line numberDiff line change
@@ -1,21 +1,12 @@
11
module Main where
22

3-
import Data.Bits
4-
import Data.List
5-
import Data.List.Split
6-
import Data.List.Unique
73
import Data.Map (Map)
84
import Data.Map qualified as M
9-
import Data.Matrix (Matrix, (!))
10-
import Data.Matrix qualified as Mat
115
import Data.Set (Set)
126
import Data.Set qualified as S
137
import Data.Tuple.Extra
148
import Debug.Trace
159
import System.Environment
16-
import Text.Regex.TDFA ((=~))
17-
18-
-- TODO: Cleanup imports after day done
1910

2011
type Input = [(Int, Int)]
2112

@@ -35,62 +26,38 @@ move (y, x) RIGHT = (y, x + 1)
3526
isOut :: (Int, Int) -> (Int, Int) -> Bool
3627
isOut (width, height) (y, x) = x < 0 || y < 0 || x > width || y > height
3728

38-
smallestPathFind :: Set (Int, Int) -> Map (Int, Int) Int -> (Int, Int) -> (Int, Int) -> Int -> (Int, Set (Int, Int), Map (Int, Int) Int)
39-
smallestPathFind memory seen pos target nbMoves
40-
-- \| trace ("Pos: " ++ show pos) False = (-1, S.empty, seen)
41-
| isOut target pos = (-1, S.empty, seen)
42-
| pos `M.member` seen && seen M.! pos <= nbMoves = (-1, S.empty, seen) -- trace ("At " ++ show nbMoves ++ " but already seen at " ++ show (seen M.! pos))
43-
| pos `S.member` memory = (-1, S.empty, currSeen)
44-
| pos == target = (nbMoves, S.singleton target, currSeen)
45-
| length bestSol /= 0 = (bestMoves, S.insert pos bestPath, seenRight)
46-
| otherwise = (-1, S.empty, seenRight)
29+
bfs :: Set (Int, Int) -> (Int, Int) -> Set (Int, Int) -> Set (Int, Int) -> Map (Int, Int) (Set (Int, Int)) -> Set (Int, Int)
30+
bfs memory target seen curr paths
31+
| S.null curr = S.empty
32+
| target `S.member` curr = paths M.! target
33+
| otherwise = bfs memory target (S.union seen curr) newCurr newPaths
4734
where
48-
currSeen = M.insert pos nbMoves seen
49-
(movesUp, pathUp, seenUp) = smallestPathFind memory currSeen (move pos UP) target (nbMoves + 1)
50-
(movesLeft, pathLeft, seenLeft) = smallestPathFind memory seenUp (move pos LEFT) target (nbMoves + 1)
51-
(movesDown, pathDown, seenDown) = smallestPathFind memory seenLeft (move pos DOWN) target (nbMoves + 1)
52-
(movesRight, pathRight, seenRight) = smallestPathFind memory seenDown (move pos RIGHT) target (nbMoves + 1)
35+
notSeen = curr S.\\ seen
36+
notInWall = notSeen S.\\ memory
37+
notOut = S.filter (not . isOut target) notInWall
5338

54-
bestSol = sortOn fst . filter ((/= -1) . fst) $ [(movesUp, pathUp), (movesLeft, pathLeft), (movesDown, pathDown), (movesRight, pathRight)]
55-
(bestMoves, bestPath) = head bestSol
39+
f2 p (curr', paths') p' = (S.insert p' curr', M.insert p' (S.insert p' (paths M.! p)) paths')
40+
f1 cp p = foldl (f2 p) cp $ map (move p) [UP, LEFT, RIGHT, DOWN]
41+
(newCurr, newPaths) = S.foldl f1 (S.empty, M.empty) notOut
5642

57-
part1 :: Int -> Input -> Output
58-
part1 range input = fst3 $ smallestPathFind memory M.empty (0, 0) (range, range) 0
59-
where
60-
memory = foldl (\r e -> S.insert e r) S.empty $ take 1024 input
61-
62-
anyPathFind :: Set (Int, Int) -> Map (Int, Int) Int -> (Int, Int) -> (Int, Int) -> Int -> (Int, Set (Int, Int), Map (Int, Int) Int)
63-
anyPathFind memory seen pos target nbMoves
64-
-- \| trace ("Pos: " ++ show pos) False = (-1, S.empty, seen)
65-
| isOut target pos = (-1, S.empty, seen)
66-
| pos `M.member` seen && seen M.! pos <= nbMoves = (-1, S.empty, seen) -- trace ("At " ++ show nbMoves ++ " but already seen at " ++ show (seen M.! pos))
67-
| pos `S.member` memory = (-1, S.empty, currSeen)
68-
| pos == target = (nbMoves, S.singleton target, currSeen)
69-
| movesUp /= -1 = (movesUp, S.insert pos pathUp, seenUp)
70-
| movesLeft /= -1 = (movesLeft, S.insert pos pathLeft, seenLeft)
71-
| movesDown /= -1 = (movesDown, S.insert pos pathDown, seenDown)
72-
| movesRight /= -1 = (movesRight, S.insert pos pathRight, seenRight)
73-
| otherwise = (-1, S.empty, seenRight)
43+
part1 :: Int -> Int -> Input -> Output
44+
part1 range firstBatch input = S.size $ bfs memory (range, range) S.empty (S.singleton (0, 0)) (M.singleton (0, 0) S.empty)
7445
where
75-
currSeen = M.insert pos nbMoves seen
76-
(movesUp, pathUp, seenUp) = anyPathFind memory currSeen (move pos UP) target (nbMoves + 1)
77-
(movesLeft, pathLeft, seenLeft) = anyPathFind memory seenUp (move pos LEFT) target (nbMoves + 1)
78-
(movesDown, pathDown, seenDown) = anyPathFind memory seenLeft (move pos DOWN) target (nbMoves + 1)
79-
(movesRight, pathRight, seenRight) = anyPathFind memory seenDown (move pos RIGHT) target (nbMoves + 1)
80-
81-
part2 :: Int -> Input -> (Int, Int)
82-
part2 range input = sub 1024 memory (drop 1024 input) (snd3 $ smallestPathFind memory M.empty (0, 0) (range, range) 0)
46+
memory = S.fromList $ take firstBatch input
47+
48+
part2 :: Int -> Int -> Input -> (Int, Int)
49+
part2 range firstBatch input = sub (firstBatch, length input + 1)
8350
where
84-
memory = foldl (\r e -> S.insert e r) S.empty $ take 1024 input
85-
sub n mem [] lastPath = (-1, -1)
86-
sub n mem (e : l) lastPath
87-
-- \| trace (show lastPath) False = (0, 0)
88-
| e `S.notMember` lastPath = sub (n + 1) newMem l lastPath
89-
| currRes == -1 = swap e
90-
| otherwise = sub (n + 1) newMem l currPath
51+
findPath m = bfs m (range, range) S.empty (S.singleton (0, 0)) (M.singleton (0, 0) S.empty)
52+
sub :: (Int, Int) -> (Int, Int)
53+
sub (imin, imax)
54+
| imin >= imax = swap $ input !! (imin - 1)
55+
| S.null currPath = sub (imin, midi)
56+
| otherwise = sub (midi + 1, imax)
9157
where
92-
newMem = S.insert e mem
93-
(currRes, currPath, _) = smallestPathFind newMem M.empty (0, 0) (range, range) 0
58+
midi = imin + (imax - imin) `div` 2
59+
mem = S.fromList $ take midi input
60+
currPath = findPath mem
9461

9562
showMemory :: Int -> Set (Int, Int) -> [String]
9663
showMemory range memory = [[if S.member (y, x) memory then '#' else '.' | x <- [0 .. range]] | y <- [0 .. range]]
@@ -101,12 +68,13 @@ main = do
10168
content <- readFile (last args)
10269
let input = parseInput content
10370
let range = 70
104-
71+
let firstStep = 1024
10572
-- print input
10673

107-
-- let memory = foldl (\r e -> S.insert e r) S.empty $ take 1024 input
74+
print $ part1 range firstStep input
75+
print $ part2 range firstStep input
10876

109-
-- putStrLn . unlines $ showMemory range memory
77+
-- print $ part2dicho range firstStep input
11078

111-
print $ part1 range input
112-
print $ part2 range input
79+
-- let memory = foldl (\r e -> S.insert e r) S.empty $ take 1024 input
80+
-- putStrLn . unlines $ showMemory range memory

‎2024/README.md

+143
Original file line numberDiff line numberDiff line change
@@ -265,3 +265,146 @@ Solution is a bit slow so will try to optimize it.
265265
Mainly the second part, I already only look for a path if the current position is in the previous path.
266266

267267
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)
268+
269+
#### First version :
270+
At first I used a DFS to find the smallest path for both part1 and part2.
271+
272+
```hs
273+
smallestPathFind :: Set (Int, Int) -> Map (Int, Int) Int -> (Int, Int) -> (Int, Int) -> Int -> (Int, Set (Int, Int), Map (Int, Int) Int)
274+
smallestPathFind memory seen pos target nbMoves
275+
| isOut target pos = (-1, S.empty, seen)
276+
| pos `M.member` seen && seen M.! pos <= nbMoves = (-1, S.empty, seen)
277+
| pos `S.member` memory = (-1, S.empty, currSeen)
278+
| pos == target = (nbMoves, S.singleton target, currSeen)
279+
| length bestSol /= 0 = (bestMoves, S.insert pos bestPath, seenRight)
280+
| otherwise = (-1, S.empty, seenRight)
281+
where
282+
currSeen = M.insert pos nbMoves seen
283+
(movesUp, pathUp, seenUp) = smallestPathFind memory currSeen (move pos UP) target (nbMoves + 1)
284+
(movesLeft, pathLeft, seenLeft) = smallestPathFind memory seenUp (move pos LEFT) target (nbMoves + 1)
285+
(movesDown, pathDown, seenDown) = smallestPathFind memory seenLeft (move pos DOWN) target (nbMoves + 1)
286+
(movesRight, pathRight, seenRight) = smallestPathFind memory seenDown (move pos RIGHT) target (nbMoves + 1)
287+
288+
bestSol = sortOn fst . filter ((/= -1) . fst) $ [(movesUp, pathUp), (movesLeft, pathLeft), (movesDown, pathDown), (movesRight, pathRight)]
289+
(bestMoves, bestPath) = head bestSol
290+
```
291+
292+
```hs
293+
{- Simple part2 version using previous found path as condition to find a new path -}
294+
sub n mem [] lastPath = (-1, -1)
295+
sub n mem (e : l) lastPath
296+
| e `S.notMember` lastPath = sub (n + 1) newMem l lastPath
297+
| currRes == -1 = swap e
298+
| otherwise = sub (n + 1) newMem l currPath
299+
where
300+
newMem = S.insert e mem
301+
(currRes, currPath, _) = smallestPathFind newMem M.empty (0, 0) (range, range) 0
302+
```
303+
304+
Time : ~25s
305+
306+
#### Second Version :
307+
308+
Then I thought that for the second part any path could do the trick
309+
So instead of the smallest path, I changed the algorithm to return the first path found.
310+
This method didn't work and was actually slower than the previous version.
311+
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.
312+
313+
```hs
314+
anyPathFind :: Set (Int, Int) -> Map (Int, Int) Int -> (Int, Int) -> (Int, Int) -> Int -> (Int, Set (Int, Int), Map (Int, Int) Int)
315+
anyPathFind memory seen pos target nbMoves
316+
| isOut target pos = (-1, S.empty, seen)
317+
| pos `M.member` seen && seen M.! pos <= nbMoves = (-1, S.empty, seen)
318+
| pos `S.member` memory = (-1, S.empty, currSeen)
319+
| pos == target = (nbMoves, S.singleton target, currSeen)
320+
| movesUp /= -1 = (movesUp, S.insert pos pathUp, seenUp)
321+
| movesLeft /= -1 = (movesLeft, S.insert pos pathLeft, seenLeft)
322+
| movesDown /= -1 = (movesDown, S.insert pos pathDown, seenDown)
323+
| movesRight /= -1 = (movesRight, S.insert pos pathRight, seenRight)
324+
| otherwise = (-1, S.empty, seenRight)
325+
where
326+
currSeen = M.insert pos nbMoves seen
327+
(movesUp, pathUp, seenUp) = anyPathFind memory currSeen (move pos UP) target (nbMoves + 1)
328+
(movesLeft, pathLeft, seenLeft) = anyPathFind memory seenUp (move pos LEFT) target (nbMoves + 1)
329+
(movesDown, pathDown, seenDown) = anyPathFind memory seenLeft (move pos DOWN) target (nbMoves + 1)
330+
(movesRight, pathRight, seenRight) = anyPathFind memory seenDown (move pos RIGHT) target (nbMoves + 1)
331+
```
332+
333+
Time : ~40s
334+
335+
#### Third Version :
336+
337+
Then Raphaël Montes (Sheinxy) made me think about BFS that are actually way faster in this case.
338+
So here is my implementation.
339+
340+
```hs
341+
bfs :: Set (Int, Int) -> (Int, Int) -> Set (Int, Int) -> Set (Int, Int) -> Int -> Int
342+
bfs memory target seen curr acc
343+
| S.null curr = -1
344+
| target `S.member` curr = acc
345+
| otherwise = bfs memory target (S.union seen curr) newCurr (acc + 1)
346+
where
347+
notSeen = curr S.\\ seen
348+
notInWall = notSeen S.\\ memory
349+
notOut = S.filter (not . isOut target) notInWall
350+
newCurr = S.fromList . concat . map (\p -> map (move p) [UP, LEFT, RIGHT, DOWN]) $ S.toList notOut
351+
```
352+
353+
```hs
354+
{- Another Simple sub using BFS but not keeping memory of previous paths-}
355+
sub n mem [] = (-1, -1)
356+
sub n mem (e : l)
357+
| currRes == -1 = swap e
358+
| otherwise = sub (n + 1) newMem l
359+
where
360+
newMem = S.insert e mem
361+
currRes = bfs newMem (range, range) S.empty (S.singleton (0, 0)) 0
362+
```
363+
364+
Time : ~13s
365+
366+
#### Fourth Version:
367+
368+
By using my two previous best versions I tried to do part2 using a bfs that returns the path.
369+
So instead of calculating the path each time, I only do it when the position would block the previous path found.
370+
371+
372+
```hs
373+
bfs :: Set (Int, Int) -> (Int, Int) -> Set (Int, Int) -> Set (Int, Int) -> Map (Int, Int) (Set (Int, Int)) -> Set (Int, Int)
374+
bfs memory target seen curr paths
375+
| S.null curr = S.empty
376+
| target `S.member` curr = paths M.! target
377+
| otherwise = bfs memory target (S.union seen curr) newCurr newPaths
378+
where
379+
notSeen = curr S.\\ seen
380+
notInWall = notSeen S.\\ memory
381+
notOut = S.filter (not . isOut target) notInWall
382+
383+
f2 p (curr', paths') p' = (S.insert p' curr', M.insert p' (S.insert p' (paths M.! p)) paths')
384+
f1 cp p = foldl (f2 p) cp $ map (move p) [UP, LEFT, RIGHT, DOWN]
385+
(newCurr, newPaths) = S.foldl f1 (S.empty, M.empty) notOut
386+
```
387+
388+
```hs
389+
part2 :: Int -> Int -> Input -> (Int, Int)
390+
part2 range firstBatch input = sub memory (drop firstBatch input) (findPath memory)
391+
where
392+
memory = S.fromList $ take firstBatch input
393+
findPath m = bfs2 m (range, range) S.empty (S.singleton (0, 0)) (M.singleton (0, 0) S.empty)
394+
sub mem [] lastPath = (-1, -1)
395+
sub mem (e : l) lastPath
396+
| e `S.notMember` lastPath = sub newMem l lastPath
397+
| S.null currPath = swap e
398+
| otherwise = sub newMem l currPath
399+
where
400+
newMem = S.insert e mem
401+
currPath = findPath newMem
402+
```
403+
404+
Time : 0.3s
405+
406+
#### Last Version:
407+
408+
After this interesting idea, Raphaël Montes had another one : `dichotomic search` which is my last version
409+
410+
Time : ~0.08s

0 commit comments

Comments
 (0)