day 22 reflections and cleanup

mstksg · mstksg · commit 5a3439f3b273 · 2025-01-01T00:39:50.000-08:00
diff --git a/2024/AOC2024/Day22.hs b/2024/AOC2024/Day22.hs
@@ -1,6 +1,3 @@
-{-# OPTIONS_GHC -Wno-unused-imports #-}
-{-# OPTIONS_GHC -Wno-unused-top-binds #-}
-
 -- |
 -- Module      : AOC2024.Day22
 -- License     : BSD3
@@ -9,87 +6,53 @@
 -- Portability : non-portable
 --
 -- Day 22.  See "AOC.Solver" for the types used in this module!
---
--- After completing the challenge, it is recommended to:
---
--- *   Replace "AOC.Prelude" imports to specific modules (with explicit
---     imports) for readability.
--- *   Remove the @-Wno-unused-imports@ and @-Wno-unused-top-binds@
---     pragmas.
--- *   Replace the partial type signatures underscores in the solution
---     types @_ :~> _@ with the actual types of inputs and outputs of the
---     solution.  You can delete the type signatures completely and GHC
---     will recommend what should go in place of the underscores.
 module AOC2024.Day22 (
   day22a,
   day22b,
 )
 where
 
-import AOC.Prelude
-import Data.Bits
-import qualified Data.Graph.Inductive as G
+import AOC.Common (strictIterate, (!!!))
+import AOC.Common.Parser (pDecimal, parseMaybe', sepByLines)
+import AOC.Solver (noFail, type (:~>) (..))
+import Data.Bits (Bits (shift, xor, (.&.)))
+import Data.Foldable (Foldable (toList))
 import qualified Data.IntMap as IM
-import qualified Data.IntMap.NonEmpty as NEIM
-import qualified Data.IntSet as IS
-import qualified Data.IntSet.NonEmpty as NEIS
-import qualified Data.List.NonEmpty as NE
-import qualified Data.List.PointedList as PL
-import qualified Data.List.PointedList.Circular as PLC
-import qualified Data.Map as M
-import qualified Data.Map.NonEmpty as NEM
-import qualified Data.OrdPSQ as PSQ
-import qualified Data.Sequence as Seq
-import qualified Data.Sequence.NonEmpty as NESeq
-import qualified Data.Set as S
-import qualified Data.Set.NonEmpty as NES
-import qualified Data.Text as T
-import qualified Data.Vector as V
-import qualified Linear as L
-import qualified Text.Megaparsec as P
-import qualified Text.Megaparsec.Char as P
-import qualified Text.Megaparsec.Char.Lexer as PP
-
-day22a :: _ :~> _
-day22a =
-  MkSol
-    { sParse =
-        parseMaybe' $
-          sepByLines pDecimal
-    , -- noFail $
-      --   lines
-      sShow = show
-    , sSolve =
-        noFail $
-          sum . map ((!! 2000) . iterate step)
-    }
+import Safe.Foldable (maximumMay)
 
 step :: Int -> Int
-step n = n'''
+step = prune . phase3 . prune . phase2 . prune . phase1
   where
-    n' = prune $ (n `shift` 6) `xor` n
-    n'' = prune $ (n' `shift` (-5)) `xor` n'
-    n''' = prune $ (n'' `shift` 11) `xor` n''
+    phase1 n = (n `shift` 6) `xor` n
+    phase2 n = (n `shift` (-5)) `xor` n
+    phase3 n = (n `shift` 11) `xor` n
     prune = (.&. 16777215)
 
-day22b :: _ :~> _
+day22a :: [Int] :~> Int
+day22a =
+  MkSol
+    { sParse = parseMaybe' $ sepByLines pDecimal
+    , sShow = show
+    , sSolve = noFail $ sum . map ((!!! 2000) . strictIterate step)
+    }
+
+day22b :: [Int] :~> Int
 day22b =
   MkSol
     { sParse = sParse day22a
     , sShow = show
-    , sSolve =
-        noFail $ \xs ->
-          let serieses =
-                xs <&> \x ->
-                  let ps = take 2000 $ map (`mod` 10) $ iterate step x
-                      dPs = zipWith (\p0 p1 -> (p1, p1 - p0)) ps (drop 1 ps)
-                      windows = slidingWindows 4 dPs <&> \w -> (encodeSeq $ snd <$> w, fst $ last (toList w))
-                      seqMap = IM.fromListWith (const id) windows
-                   in seqMap
-              bests = toList $ IM.unionsWith (+) serieses
-           in maximum bests
-          -- bests = M.unionsWith (<>) $ map (fmap (:[])) serieses
-          -- in maximumBy (comparing (sum . snd)) (M.toList bests)
+    , sSolve = maximumMay . toList . IM.unionsWith (+) . map genSeries
     }
   where
-    encodeSeq = sum . zipWith (\i x -> x * 19^(i :: Int)) [0..] . map (+ 9) . toList
+    encodeSeq = sum . zipWith (\i x -> x * 19 ^ (i :: Int)) [0 ..] . map (+ 9)
+    genSeries = IM.fromListWith (const id) . chompChomp . take 2000 . map (`mod` 10) . strictIterate step
+      where
+        chompChomp :: [Int] -> [(Int, Int)]
+        chompChomp (a : b : c : d : e : fs) =
+          (encodeSeq [da, db, dc, dd], e) : chompChomp (b : c : d : e : fs)
+          where
+            da = b - a
+            db = c - b
+            dc = d - c
+            dd = e - d
+        chompChomp _ = []
diff --git a/bench-results/2024/day22.txt b/bench-results/2024/day22.txt
@@ -1,19 +1,20 @@
 >> Day 22a
 benchmarking...
-time                 84.47 ms   (82.54 ms .. 88.08 ms)
-                     0.998 R²   (0.993 R² .. 1.000 R²)
-mean                 83.30 ms   (82.68 ms .. 84.79 ms)
-std dev              1.625 ms   (543.2 μs .. 2.715 ms)
+time                 28.09 ms   (27.10 ms .. 28.65 ms)
+                     0.994 R²   (0.979 R² .. 1.000 R²)
+mean                 29.09 ms   (28.60 ms .. 30.31 ms)
+std dev              1.589 ms   (387.5 μs .. 2.463 ms)
+variance introduced by outliers: 21% (moderately inflated)
 
 * parsing and formatting times excluded
 
 >> Day 22b
 benchmarking...
-time                 5.653 s    (5.314 s .. 6.426 s)
-                     0.998 R²   (NaN R² .. 1.000 R²)
-mean                 6.488 s    (6.099 s .. 7.163 s)
-std dev              642.2 ms   (58.08 ms .. 808.9 ms)
-variance introduced by outliers: 23% (moderately inflated)
+time                 3.095 s    (3.060 s .. 3.129 s)
+                     1.000 R²   (1.000 R² .. 1.000 R²)
+mean                 3.086 s    (3.073 s .. 3.090 s)
+std dev              8.510 ms   (919.8 μs .. 10.82 ms)
+variance introduced by outliers: 19% (moderately inflated)
 
 * parsing and formatting times excluded
 
diff --git a/reflections/2024/day22.md b/reflections/2024/day22.md
@@ -0,0 +1,48 @@
+First let's set up the RNG step:
+
+```haskell
+step :: Int -> Int
+step = prune . phase3 . prune . phase2 . prune . phase1
+  where
+    phase1 n = (n `shift` 6) `xor` n
+    phase2 n = (n `shift` (-5)) `xor` n
+    phase3 n = (n `shift` 11) `xor` n
+    prune = (.&. 16777215)
+```
+
+Part 1 is just running and summing:
+
+
+```haskell
+part1 :: [Int] -> Int
+part1 = sum . map ((!! 2000) . iterate)
+```
+
+Part 2 is a little more interesting. We want to make a map of 4-sequences to
+the first price they would get. On a chain of iterations, we can iteratively
+chomp on runs of 4:
+
+```haskell
+chompChomp :: [Int] -> [([Int], Int)]
+chompChomp (a : b : c : d : e : fs) =
+    ([da, db, dc, dd], e) : chompChomp (b : c : d : e : fs)
+  where
+    da = b - a
+    db = c - b
+    dc = d - c
+    dd = e - d
+chompChomp _ = []
+
+priceForChain :: Int -> Map [Int] Int
+priceForChain = M.fromListWith (const id) . chompChomp . take 2000 . map (`mod` 10) . iterate step
+```
+
+Then we can sum all of the sequence prices and get the maximum:
+
+```haskell
+part2 :: [Int] -> Int
+part2 = maximum . M.elems . M.fromListWith (+) . map priceForChain
+```
+
+I'm not super happy with the fact that this takes 3 seconds (even after
+optimizing to using `IntMap` on a base-19 encoding of the sequence).
