Skip to content

Commit 8f11036

Browse files
goblivendgoblivend
committed
opti(2024/Day09)
1 parent 08a5d0e commit 8f11036

File tree

2 files changed

+88
-60
lines changed

2 files changed

+88
-60
lines changed

‎2024/Day09/Day09.hs

+79-57
Original file line numberDiff line numberDiff line change
@@ -1,93 +1,115 @@
11
module Main where
2+
3+
import Data.Set (Set)
4+
import Data.Set qualified as S
25
import Debug.Trace
36
import System.Environment
47

58
type Input = [Int]
9+
610
type Output = Int
711

812
parseInput :: String -> Input
913
parseInput = map (\c -> read [c]) . filter (/= '\n')
1014

1115
expand :: [Int] -> [Int]
12-
expand = concat . map (\(i, n) -> replicate n (if i `mod` 2 == 0 then (i `div` 2) else -1)) . zip [0..]
16+
expand = concat . map (\(i, n) -> replicate n (if i `mod` 2 == 0 then (i `div` 2) else -1)) . zip [0 ..]
1317

1418
exchangeAt :: [a] -> Int -> a -> [a]
1519
exchangeAt arr i e = elsBefore ++ [e] ++ elsAfter
1620
where
17-
(elsBefore, _:elsAfter) = splitAt i arr
21+
(elsBefore, _ : elsAfter) = splitAt i arr
1822

1923
retract :: [Int] -> [Int]
2024
retract arr = sub arr (reverse arr) 0 (length arr - 1)
21-
where
22-
sub arr rev i j
23-
| i == j = [head arr]
24-
| head arr /= -1 = head arr : sub (drop 1 arr) rev (i+1) j
25-
| head rev == -1 = sub arr (drop 1 rev) i (j-1)
26-
| otherwise = head rev: sub (drop 1 arr) (drop 1 rev) (i+1) (j-1)
27-
25+
where
26+
sub arr rev i j
27+
| i == j = [head arr]
28+
| head arr /= -1 = head arr : sub (drop 1 arr) rev (i + 1) j
29+
| head rev == -1 = sub arr (drop 1 rev) i (j - 1)
30+
| otherwise = head rev : sub (drop 1 arr) (drop 1 rev) (i + 1) (j - 1)
2831

2932
part1 :: Input -> Int
30-
part1 = sum . map (uncurry (*)) . zip [0..] . retract . expand
33+
part1 = sum . map (uncurry (*)) . filter ((/= -1) . snd) . zip [0 ..] . retract . expand
3134

35+
expand2 :: [Int] -> [(Int, Int)]
36+
expand2 = map (\(i, n) -> (if i `mod` 2 == 0 then (i `div` 2) else -1, n)) . zip [0 ..]
3237

33-
-- Artifact of previous version in which I segmented the drive as (id, size) (id -1 beeing free) but had the issue of [(-1, 2), (-1, 3)] which should be converted to [(-1, 5)]
34-
-- and meant to pass onee more time on the array => seemed either slow or more complicated even if doable
35-
-- expand2 :: [Int] -> [(Int, Int)]
36-
-- expand2 = map (\(i, n) -> (if i `mod` 2 == 0 then (i `div` 2) else -1, n)) . zip [0..]
38+
expandStr :: [(Int, Int)] -> String
39+
expandStr = concat . map (\d -> if d == (-1) then "." else show d) . concat . map (\(i, n) -> replicate n i)
3740

38-
-- retract2 :: [(Int, Int)] -> [(Int, Int)]
39-
-- retract2 arr = foldl (\res (j, (idi, size)) -> sub res 0 j (idi, size)) arr $ zip (reverse [0..length arr - 1]) arr
40-
-- where
41-
-- sub :: [(Int, Int)] -> Int -> Int -> (Int, Int) -> Bool -> [(Int, Int)]
42-
-- sub arr i j (idi, size) added
43-
-- | added && i == j = (-1, size) : (drop 1 arr)
44-
-- | i >= j = arr
45-
-- | idi == -1 = arr
46-
-- | (fst $ head arr) /= -1 = head arr : sub (drop 1 arr) (i+1) j (idi, size) added
47-
-- | (snd $ head arr) < size = head arr : sub (drop 1 arr) (i+1) j (idi, size) added
48-
-- | (snd $ head arr) == size = (idi, size) : sub (drop 1 arr) (i+1) j (idi, size) True
49-
-- | (snd $ head arr) > size = (idi, size) : (-1, (snd $ head arr) - size) : sub (drop 1 arr) (i+1) j (idi, size) True
50-
-- sub2 arr rev j
51-
-- | rev == [] = arr
52-
-- | (fst $ head rev) == -1 = sub2 arr (drop 1 rev) (j-1)
53-
-- | otherwise = sub arr 0 j head (rev)
41+
retract2 :: [(Int, Int)] -> [(Int, Int)]
42+
retract2 arr = {-# SCC sub2 #-} sub2 arr (reverse arr)
43+
where
44+
subAdded :: [(Int, Int)] -> (Int, Int) -> [(Int, Int)]
45+
subAdded arr (idi, size)
46+
| idi == currId = (-1, size) : (drop 1 arr)
47+
| otherwise = head arr : subAdded (drop 1 arr) (idi, size)
48+
where
49+
(currId, currSize) = head arr
50+
51+
sub :: [(Int, Int)] -> (Int, Int) -> [(Int, Int)]
52+
sub arr (idi, size)
53+
| idi == currId = arr
54+
| currId /= -1 = head arr : resSkip1
55+
| currId == -1 && nextId == -1 = {-# SCC subMergeMin1 #-} sub ((-1, currSize + nextSize) : arr) (idi, size)
56+
| currSize < size = head arr : resSkip1
57+
| currSize == size = (idi, size) : resExactMatch
58+
| currSize > size = (idi, size) : (-1, currSize - size) : resExactMatch
59+
where
60+
resSkip1 = {-# SCC nextEmptyFromSub #-} sub (drop 1 arr) (idi, size)
61+
(resExactMatch) = {-# SCC subAdded #-} subAdded (drop 1 arr) (idi, size)
62+
(currId, currSize) = head arr
63+
(nextId, nextSize) = head $ tail arr
64+
65+
sub2 :: [(Int, Int)] -> [(Int, Int)] -> [(Int, Int)]
66+
sub2 arr rev
67+
| rev == [] = arr
68+
| (fst $ head rev) == -1 = {-# SCC sub2OnMin1 #-} sub2 arr (drop 1 rev)
69+
| otherwise = {-# SCC sub2Next #-} sub2 (newArr) (drop 1 rev)
70+
where
71+
newArr = {-# SCC sub2CallsSub #-} sub (arr) (head rev)
72+
currId = fst $ head rev
5473

74+
part2 :: Input -> Output
75+
part2 = sum . map (uncurry (*)) . filter ((/= -1) . snd) . zip [0 ..] . concat . map (\(i, n) -> replicate n i) . retract2 . expand2
5576

5677
-- exchangeAt :: [a] -> Int -> a -> [a]
5778
-- exchangeAt arr i e = elsBefore ++ [e] ++ elsAfter
5879
-- where
59-
-- (elsBefore, _:elsAfter) = splitAt i arr
60-
61-
retract2 :: [Int] -> [Int]
62-
retract2 arr = {-# SCC sub2 #-} sub2 arr (reverse arr) (length arr -1)
63-
where
64-
sub arr jBlock i j
65-
| i >= j = arr
66-
| head arr /= -1 = iBlock ++ {-# SCC notFreeSubCall #-} sub (drop leni arr) jBlock (i+leni) j
67-
| leni < lenj = iBlock ++ {-# SCC tooSmallSubCall #-} sub (drop leni arr) jBlock (i+leni) j
68-
| otherwise = jBlock ++ {-# SCC removeElt #-} removeElt (head jBlock) (drop lenj arr)
69-
where
70-
iBlock = takeWhile (== (head arr)) arr
71-
leni = length iBlock
72-
lenj = length jBlock
73-
74-
removeElt elt arr = map (\e -> if e == elt then -1 else e) arr
75-
76-
sub2 arr rev j
77-
| j <= 0 = arr
78-
| head rev == -1 = sub2 arr (drop lenj rev) (j - lenj)
79-
| otherwise = sub2 ({-# SCC firstSubCall #-} sub arr jBlock 0 (j-lenj)) (drop lenj rev) (j - lenj)
80-
where
81-
jBlock = takeWhile (== (head rev)) rev
82-
lenj = length jBlock
80+
-- (elsBefore, _:elsAfter) = splitAt i arr
8381

82+
-- Former Version : Was faster to do but is way slower
83+
-- Quite similar to other version except that I run using [Int] hence time to look for the sizes and loop through all those numbers
84+
-- retract2 :: [Int] -> [Int]
85+
-- retract2 arr = {-# SCC sub2 #-} sub2 arr (reverse arr) (length arr -1)
86+
-- where
87+
-- sub arr jBlock i j
88+
-- | i >= j = arr
89+
-- | head arr /= -1 = iBlock ++ {-# SCC notFreeSubCall #-} sub (drop leni arr) jBlock (i+leni) j
90+
-- | leni < lenj = iBlock ++ {-# SCC tooSmallSubCall #-} sub (drop leni arr) jBlock (i+leni) j
91+
-- | otherwise = jBlock ++ {-# SCC removeElt #-} removeElt (head jBlock) (drop lenj arr)
92+
-- where
93+
-- iBlock = takeWhile (== (head arr)) arr
94+
-- leni = length iBlock
95+
-- lenj = length jBlock
8496

85-
part2 :: Input -> Output
86-
part2 = sum . map (uncurry (*)) . filter ((/= -1) . snd) . zip [0..] . retract2 . expand
97+
-- removeElt elt arr = map (\e -> if e == elt then -1 else e) arr
98+
99+
-- sub2 arr rev j
100+
-- | j <= 0 = arr
101+
-- | head rev == -1 = sub2 arr (drop lenj rev) (j - lenj)
102+
-- | otherwise = sub2 ({-# SCC firstSubCall #-} sub arr jBlock 0 (j-lenj)) (drop lenj rev) (j - lenj)
103+
-- where
104+
-- jBlock = takeWhile (== (head rev)) rev
105+
-- lenj = length jBlock
106+
107+
-- part2 :: Input -> Output
108+
-- part2 = sum . map (uncurry (*)) . filter ((/= -1) . snd) . zip [0..] . retract2 . expand
87109

88110
main :: IO ()
89111
main = do
90-
args <- getArgs
112+
args <- getArgs
91113
content <- readFile (last args)
92114
let input = parseInput content
93115

‎2024/README.md

+9-3
Original file line numberDiff line numberDiff line change
@@ -9,8 +9,8 @@ This year will do it in Haskell, but might try few days in Rust as well
99
- [x] Day 5
1010
- [x] Day 6
1111
- [x] Day 7
12-
- [ ] Day 8
13-
- [ ] Day 9
12+
- [x] Day 8
13+
- [x] Day 9
1414
- [ ] Day 10
1515
- [ ] Day 11
1616
- [ ] Day 12
@@ -115,7 +115,13 @@ Instead I had fun creating a function to preview the actual grid at each step, y
115115

116116
### Day 9:
117117

118-
Today was nice, was not as easy but was fun to think about and find optimised solutions
118+
Today was nice, was not as easy but was fun to think about and find optimized solutions
119119

120120
My solution is not that fast today ~1m30s might try to optimize it further but at the moment need to work on other things
121121
(ghc profiler decided not to profile my costs centers)
122+
123+
So I indeed took time to do some optimizations, now I run in 2s.
124+
125+
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
126+
127+
Tried more optimizations such as saving the first valid free spot but this was only slowing things down

0 commit comments

Comments
 (0)