feat(2024/Day11): part2 haskell + python

Author: goblivend

2024/Day11/Day11.hs

@@ -1,6 +1,8 @@
 module Main where
 
 import Control.Parallel.Strategies
+import Data.Map (Map)
+import Data.Map qualified as M
 import Debug.Trace
 import System.Environment
 
@@ -11,37 +13,52 @@ type Output = Int
 parseInput :: String -> Input
 parseInput = map read . words . head . lines
 
+-- Number of digits in a number : digitCount 128 = 3
 digitCount :: Int -> Int
 digitCount i
   | i < 10 = 1
   | otherwise = 1 + digitCount (div i 10)
 
-splitNumber :: Int -> Int -> [Int]
-splitNumber n lengthn = [firstHalf, secondHalf]
+-- Splits a number containing an even number of digits in 2 : splitNumber 2048 = [20, 48]
+splitNumber :: Int -> [Int]
+splitNumber n = [firstHalf, secondHalf]
   where
+    lengthn = {-# SCC stoneLength #-} digitCount n
     powered10 = {-# SCC powered10 #-} (10 ^ (div lengthn 2))
     firstHalf = {-# SCC firstHalf #-} div n powered10
     secondHalf = {-# SCC secondHalf #-} n - (firstHalf * powered10)
 
-iterateStones :: [Int] -> [Int]
-iterateStones stones = concat $ map iterateStone stones
+-- Main Algorithm of the day
+iterateStone :: Int -> [Int]
+iterateStone 0 = [1]
+iterateStone stone
+  | (== 0) . (`mod` 2) $ digitCount stone = splitNumber stone
+  | otherwise = [stone * 2024]
+
+solveFold :: Map (Int, Int) Int -> (Int, Int) -> Map (Int, Int) Int
+solveFold memRes (stone, n)
+  | (stone, n) `M.member` memRes = memRes
+  | n == 1 = M.insert (stone, n) (length newStones) memRes
+  | otherwise = M.insert (stone, n) total memResFold
   where
-    iterateStone 0 = [1]
-    iterateStone stone
-      | isSplitable = splitNumber stone stoneLength
-      | otherwise = [stone * 2024]
-      where
-        isSplitable = {-# SCC isSplitable #-} (== 0) $ (`mod` 2) stoneLength
-        stoneLength = {-# SCC stoneLength #-} digitCount stone
+    newStones = iterateStone stone
+    newQuerries = zip newStones $ repeat (n - 1)
+
+    memResFold = foldl solveFold memRes $ newQuerries
+
+    total = sum . map (memResFold M.!) $ newQuerries
 
 solve :: Int -> Input -> Output
-solve n arr = length . fst . head . drop n $ iterate (\(l, i) -> trace (show (i, length l)) (iterateStones l, i + 1)) (arr, 0)
+solve n arr = sum $ map (solutions M.!) . zip arr $ repeat n
+  where
+    solutions :: Map (Int, Int) Int
+    solutions = foldl solveFold M.empty . zip arr $ repeat n
 
 part1 :: Input -> Output
 part1 = solve 25
 
 part2 :: Input -> Output
-part2 = solve 40
+part2 = solve 75
 
 main :: IO ()
 main = do
@@ -51,5 +68,44 @@ main = do
 
   print input
 
-  print $ part1 input
-  print $ (== 11965325) $ part2 input
+  let res1 = part1 input
+  -- print res1
+  print $ any (== res1) [55312, 183484]
+  let res2 = part2 input
+  -- print res2
+  print $ any (== res2) [65601038650482, 218817038947400]
+
+
+
+
+-- Gets main algorithm using a memory map to avoid calculating the same result twice
+-- lookUpIterateStone :: Map Int [Int] -> Int -> (Map Int [Int], [Int])
+-- lookUpIterateStone mem n
+--   | n `M.member` mem = (mem, mem M.! n)
+--   | otherwise = (newMem, newArr)
+--   where
+--     newArr = iterateStone n
+--     newMem = M.insert n newArr mem
+
+-- solveFold :: (Map (Int, Int) Int, Map Int [Int]) -> (Int, Int) -> (Map (Int, Int) Int, Map Int [Int])
+-- solveFold (memRes, mem1) (stone, n)
+--   | (stone, n) `M.member` memRes = (memRes, mem1)
+--   | n == 1 = (M.insert (stone, n) (length resLookUp) memRes, mem1LookUp)
+--   | otherwise = (M.insert (stone, n) total memResFold, mem1Fold)
+--   where
+--     (mem1LookUp, resLookUp) = lookUpIterateStone mem1 stone
+--     (memResSub1, mem1Sub1) = solveFold (memRes, mem1) (stone, n - 1)
+
+--     newStones :: [Int]
+--     newStones = mem1Sub1 M.! stone
+
+--     newQuerries :: [(Int, Int)]
+--     newQuerries = zip newStones $ repeat (n - 1)
+--     (memResFold, mem1Fold) = foldl solveFold (memResSub1, mem1Sub1) $ newQuerries
+--     total = sum . map (memResFold M.!) $ newQuerries
+
+-- solve :: Int -> Input -> Output
+-- solve n arr = sum $ map (solutions M.!) . zip arr $ repeat n
+--   where
+--     solutions :: Map (Int, Int) Int
+--     solutions = fst . foldl solveFold (M.empty, M.empty) . zip arr $ repeat n

2024/Day11/Day11.py

@@ -0,0 +1,38 @@
+import sys
+
+def algo(stone) :
+    if stone == 0 :
+        return [1]
+    elif len(str(stone)) % 2 == 0 :
+        half_len = len(str(stone)) // 2
+        return [int(str(stone)[:half_len]), int(str(stone)[half_len:])]
+    else :
+        return [2024*stone]
+
+solvei_cache = {}
+def solvei(stone, n) :
+    if (stone, n) in solvei_cache :
+        return solvei_cache[(stone, n)]
+    res1 = algo(stone)
+    if n == 1 :
+        solvei_cache[(stone, n)] = len(res1)
+        return len(res1)
+
+    solvei_cache[(stone, n)] = sum(map (lambda x : solvei(x, n-1), res1))
+    return solvei_cache[(stone, n)]
+
+def solve(arr, n) :
+    return sum(map(lambda x : solvei(x, n), arr))
+
+def part1(arr) :
+    return solve(arr, 25)
+
+def part2(arr) :
+    return solve(arr, 75)
+
+if __name__ == "__main__" :
+    file = sys.argv[1]
+    with open(file) as f :
+        arr = list(map(int, f.read().split(' ')))
+    print(part1(arr))
+    print(part2(arr))

2024/README.md

@@ -147,3 +147,13 @@ Tried to multithread it (in the `iterateStones` change `map` to `parMap rseq`) b
 - 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