From 841a067c280a6880159e4a2228b808ac8e7df066 Mon Sep 17 00:00:00 2001
From: justin <justin@jle.im>
Date: Fri, 27 Dec 2024 15:37:14 -0800
Subject: [PATCH 01/43] start cleaning up day 21

---
 2024/AOC2024/Day21.hs  | 589 +++++------------------------------------
 test-data/2024/21b.txt |   6 -
 2 files changed, 68 insertions(+), 527 deletions(-)

diff --git a/2024/AOC2024/Day21.hs b/2024/AOC2024/Day21.hs
index ad33371..cbc7a6a 100644
--- a/2024/AOC2024/Day21.hs
+++ b/2024/AOC2024/Day21.hs
@@ -1,6 +1,3 @@
-{-# OPTIONS_GHC -Wno-unused-imports #-}
-{-# OPTIONS_GHC -Wno-unused-top-binds #-}
-
 -- |
 -- Module      : AOC2024.Day21
 -- License     : BSD3
@@ -9,317 +6,78 @@
 -- Portability : non-portable
 --
 -- Day 21.  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.Day21
+module AOC2024.Day21 (
+  day21a,
+  day21b,
+)
 where
 
--- (
--- day21a,
--- day21b,
--- dirPath,
--- composeDirPath,
--- composeDirPathLengths,
--- dirPathCosts,
--- runPath,
--- altP1,
--- )
-
 import AOC.Prelude
-import qualified Data.Graph.Inductive as G
-import qualified Data.IntMap as IM
-import qualified Data.IntMap.NonEmpty as IM
-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 Data.Vector.Sized as SV
-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
-
--- okay i guess if we have a long series of bots, every time the top level
--- pushes A, an unbroken chain from the top also pushes A
---
--- Therefore any A cannot be pushed without the cascade of all the others
--- above it being pushed
---
--- This also means we have a "starting point" from which all memory is fresh.
---
--- The annoying thing is if there is more than one path, how can we really
--- know what is the best path to take?
---
--- Consider: moving from 0 to 6 to 9, vs 0 to 6 to 5. 06 could be ^^> or >^^,
--- but >^^ is better for moving to 9 later.
---
--- maybe is there a better A* heuristic for top-down? Instead of moving
--- randomly, move to a destination and then back. but then that's random.
---
--- Hm, okay maybe we can still go bottom-up: do things in triples instead of
--- pairs. Consider "0-6-9" to get to 6, then once you're at 6, consider
--- "6-9-A".
---
--- But now i wonder if the arrow keys need the same consideration? maybe
--- not...
---
--- Hmm yeah there is. Consider: A -> v -> <.
---
--- But actually wait would that ever matter? for the D pads you are always
--- going A to arrow to back, right? Could you optimize those? Yeah the D-pads
--- could be cached maybe: A-to-arrow-to-back?
---
--- Yeah in that case you always need to optimize only those 4: A^A, A>A, A<A,
--- AvA...
---
--- Okay here's the new goal: optimize all of the A-Dir-A marches at one level.
--- then two levels. then three levels. -> yeah this is already what we have
--- with the composeDirPath
---
--- For the final level we can then A-star again? or do something fundamentally
--- different.
---
--- We can at least compare with a ground truth A-star
---
--- 363987226123908 is too high
--- 360179530912464 is also too high
--- 352119886237752 is incorrect
--- 344484288881564 is incorrect
--- 411895844528756
---
 
 type NumPad = Maybe (Finite 10)
 type DirPad = Maybe Dir
 
--- 540A
--- 582A
--- 169A
--- 593A
--- 579A
-
-pc :: Char -> Maybe (Finite 10)
-pc = fmap fromIntegral . digitToIntSafe <=< mfilter isDigit . Just
-
-applyPushDir :: Maybe Dir -> DirPad -> Maybe (DirPad, Maybe DirPad)
-applyPushDir = \case
-  Nothing -> \dp -> Just (dp, Just dp)
-  Just North ->
-    fmap (,Nothing) . \case
-      Just South -> Just (Just North)
-      Just East -> Just Nothing
-      _ -> Nothing
-  Just South ->
-    fmap (,Nothing) . \case
-      Just North -> Just (Just South)
-      Nothing -> Just (Just East)
-      _ -> Nothing
-  Just East ->
-    fmap (,Nothing) . \case
-      Just North -> Just Nothing
-      Just West -> Just (Just South)
-      Just South -> Just (Just East)
-      _ -> Nothing
-  Just West ->
-    fmap (,Nothing) . \case
-      Nothing -> Just (Just North)
-      Just South -> Just (Just West)
-      Just East -> Just (Just South)
-      _ -> Nothing
-
-applyPushNum :: DirPad -> NumPad -> Maybe (NumPad, Maybe NumPad)
-applyPushNum = \case
-  Nothing -> \np -> Just (np, Just np)
-  Just North ->
-    fmap (,Nothing) . \case
-      Just i
-        | i /= 0 -> Just <$> packFinite (fromIntegral i + 3)
-        | i == 0 -> Just (Just 2)
-      Nothing -> Just (Just 3)
-  Just South ->
-    fmap (,Nothing) . \case
-      Just i
-        | i > 3 -> Just <$> packFinite (fromIntegral i - 3)
-        | i == 3 -> Just Nothing
-        | i == 2 -> Just (Just 0)
-        | i == 1 -> Nothing
-        | i == 0 -> Nothing
-      _ -> Nothing
-  Just East ->
-    fmap (,Nothing) . \case
-      Just i
-        | i `elem` [3, 6, 9] -> Nothing
-        | i == 0 -> Just Nothing
-        | i /= 0 -> Just (Just (succ i))
-      _ -> Nothing
-  Just West ->
-    fmap (,Nothing) . \case
-      Just i
-        | i `elem` [0, 1, 4, 7] -> Nothing
-        | otherwise -> Just (Just (pred i))
-      Nothing -> Just (Just 0)
-
-data SearchState = SS
-  { ssNumBot :: !NumPad
-  , ssDirBot1 :: !DirPad
-  , ssDirBot2 :: !DirPad
-  , ssOutput :: !(Seq NumPad)
-  }
-  deriving stock (Eq, Show, Ord, Generic)
-  deriving anyclass (NFData)
-
-findSol :: [NumPad] -> Maybe _
-findSol goal = score . fst <$> aStar heur step s0 ((== goalseq) . ssOutput)
-  where
-    goalseq = Seq.fromList goal
-    ngoal = length goal
-    score p = p * read @Int (map intToDigit (mapMaybe (fmap fromIntegral) goal :: [Int]))
-    heur SS{..} = ngoal - Seq.length ssOutput
-    s0 =
-      SS
-        { ssNumBot = Nothing
-        , ssDirBot1 = Nothing
-        , ssDirBot2 = Nothing
-        , ssOutput = mempty
-        }
-    step ss@SS{..} =
-      M.fromSet (const 1) . S.fromList $
-        [ SS{ssNumBot = numBot', ssDirBot1 = dirBot1', ssDirBot2 = dirBot2', ssOutput = output'}
-        | push <- Nothing : (Just <$> [North ..])
-        , (dirBot1', dbo1) <- maybeToList $ applyPushDir push ssDirBot1
-        , (dirBot2', dbo2) <- case dbo1 of
-            Nothing -> pure (ssDirBot2, Nothing)
-            Just push' -> maybeToList $ applyPushDir push' ssDirBot2
-        , (numBot', nbo) <- case dbo2 of
-            Nothing -> pure (ssNumBot, Nothing)
-            Just push' -> maybeToList $ applyPushNum push' ssNumBot
-        , output' <- case nbo of
-            Nothing -> pure ssOutput
-            Just o -> do
-              guard $ o == (goalseq `Seq.index` Seq.length ssOutput)
-              pure (ssOutput Seq.:|> o)
-        ]
-
-day21a :: _ :~> _
-day21a =
-  MkSol
-    { sParse = Just . map (map pc) . lines
-    , -- noFail $
-      --   lines
-      -- , sShow = ('\n':) . unlines . map show . head
-      sShow = show
-    , -- , sSolve = fmap sum . traverse findSol
-      sSolve =
-        noFail $
-          sum
-            . map
-              ( \p ->
-                  let num :: Int
-                      num = read (map intToDigit (mapMaybe (fmap fromIntegral) p :: [Int]))
-                   in num * altP1' 2 p
-              )
-              -- , sSolve = fmap (fmap length) . traverse findSolBasic
-              -- noFail $
-              --   id
-    }
-
-data SearchStateN n = SSN
-  { ssnNumBot :: !NumPad
-  , ssnDirBots :: !(SV.Vector n DirPad)
-  , ssnOutput :: !(Seq NumPad)
-  }
-  deriving stock (Eq, Show, Ord, Generic)
-  deriving anyclass (NFData)
-
-findSolN :: [NumPad] -> Maybe _
-findSolN goal = score . fst <$> aStar heur step s0 ((== goalseq) . ssnOutput)
-  where
-    goalseq = Seq.fromList goal
-    ngoal = length goal
-    score p = p * read @Integer (map intToDigit (mapMaybe (fmap fromIntegral) goal :: [Int]))
-    heur SSN{..} = fromIntegral $ ngoal - Seq.length ssnOutput
-    s0 :: SearchStateN 25
-    s0 =
-      SSN
-        { ssnNumBot = Nothing
-        , ssnDirBots = SV.replicate Nothing
-        , ssnOutput = mempty
-        }
-    step ssn@SSN{..} =
-      M.fromSet (const 1) . S.fromList $
-        [ SSN{ssnNumBot = numBot', ssnDirBots = dirBots', ssnOutput = output'}
-        | push <- Nothing : (Just <$> [North ..])
-        , (dirBots', dbo) <- maybeToList $ flip runStateT (Just push) $ traverse pushDir1 ssnDirBots
-        , -- scanlM pushDir1 _ ssnDirBots
-        -- applyPushDirs push ssnDirBots
-        (numBot', nbo) <- case dbo of
-          Nothing -> pure (ssnNumBot, Nothing)
-          Just push' -> maybeToList $ applyPushNum push' ssnNumBot
-        , output' <- case nbo of
-            Nothing -> pure ssnOutput
-            Just o -> do
-              guard $ o == (goalseq `Seq.index` Seq.length ssnOutput)
-              pure (ssnOutput Seq.:|> o)
-        ]
-
-pushDir1 :: DirPad -> StateT (Maybe (Maybe Dir)) Maybe DirPad
-pushDir1 bot = do
-  currPush <- get
-  case currPush of
-    Nothing -> pure bot
-    Just push -> do
-      (bot', out) <- lift $ applyPushDir push bot
-      put out
-      pure bot'
-
-allDirPad :: [DirPad]
-allDirPad = [Nothing, Just East, Just North, Just South, Just West]
+numPad :: Map Point NumPad
+numPad =
+  M.fromList
+    [ (V2 1 0, Just 0)
+    , (V2 2 0, Nothing)
+    , (V2 0 1, Just 1)
+    , (V2 1 1, Just 2)
+    , (V2 2 1, Just 3)
+    , (V2 0 2, Just 4)
+    , (V2 1 2, Just 5)
+    , (V2 2 2, Just 6)
+    , (V2 0 3, Just 7)
+    , (V2 1 3, Just 8)
+    , (V2 2 3, Just 9)
+    ]
+
+dirPad :: Map Point DirPad
+dirPad =
+  M.fromList
+    [ (V2 0 0, Just West)
+    , (V2 1 0, Just South)
+    , (V2 2 0, Just East)
+    , (V2 1 1, Just North)
+    , (V2 2 1, Nothing)
+    ]
 
 class Ord a => Pushable a where
   allPushable :: [a]
-  applyPush :: DirPad -> Maybe a -> Maybe (Maybe a, Maybe (Maybe a))
+  pushLayout :: Map Point (Maybe a)
 
 allPushable' :: Pushable a => [Maybe a]
 allPushable' = Nothing : fmap Just allPushable
 
+applyPush :: forall a. Pushable a => Maybe Dir -> Maybe a -> Maybe (Maybe a, Maybe (Maybe a))
+applyPush = \case
+  Nothing -> \x -> Just (x, Just x)
+  Just d -> \x -> do
+    y <- M.lookup d =<< M.lookup x pushMap
+    pure (y, Nothing)
+  where
+    pushMap :: Map (Maybe a) (Map Dir (Maybe a))
+    pushMap =
+      M.fromList
+        [ (x, M.fromList [(d, y) | d <- [North ..], y <- maybeToList $ M.lookup (p + dirPoint d) pushLayout])
+        | (p, x) <- M.toList pushLayout
+        ]
+
 instance Pushable Dir where
-  allPushable = [West, North, South, East]
-  applyPush = applyPushDir
+  allPushable = [East, South, North, West]
+  pushLayout = dirPad
 
 instance Pushable (Finite 10) where
   allPushable = finites
-  applyPush = applyPushNum
+  pushLayout = numPad
 
 -- | Best way to get from button to button. penalize motion
 dirPath :: forall a. Pushable a => Map (Maybe a) (Map (Maybe a) [DirPad])
 dirPath = M.fromSet ((`M.fromSet` S.fromList allPushable') . go) (S.fromList allPushable')
   where
-    -- go :: Maybe a -> Maybe a -> [DirPad]
-    -- go x y = (++ [Nothing]) . fromJust $ bfsActions step x (== y)
-    --   where
-    --     step p =
-    --       [ (d, p')
-    --       | d <- [Just West, Just North, Just South, Just East]
-    --       , (p', Nothing) <- maybeToList $ applyPush d p
-    --       ]
     go :: Maybe a -> Maybe a -> [DirPad]
     go x y = runPath Nothing . fromJust $ bfsActions step (Left (x, Nothing)) (== Right y)
       where
@@ -330,7 +88,7 @@ dirPath = M.fromSet ((`M.fromSet` S.fromList allPushable') . go) (S.fromList all
                   Nothing -> Left (b', d')
                   Just o -> Right o
               )
-            | push <- toList allDirPad
+            | push <- allPushable'
             , (d', dout) <- maybeToList $ applyPush push d
             , (b', bout) <- case dout of
                 Nothing -> pure (b, Nothing)
@@ -338,60 +96,9 @@ dirPath = M.fromSet ((`M.fromSet` S.fromList allPushable') . go) (S.fromList all
             ]
         step (Right _) = []
 
--- -- | Best way to get from button to button
--- dirPath :: forall a. Pushable a => Map (Maybe a) (Map (Maybe a) [DirPad])
--- dirPath = M.fromSet ((`M.fromSet` allPushable') . go) allPushable'
---   where
---     go :: Maybe a -> Maybe a -> [DirPad]
---     go x y = fromJust $ bfsActions step (Left x) (== Right y)
---       where
---         step (Left d) =
---           M.fromList
---             [ case dout of
---                 Nothing -> (push, Left d')
---                 Just o -> (push, Right o)
---             | push <- toList allDirPad
---             , (d', dout) <- maybeToList $ applyPush push d
---             ]
---         step (Right _) = M.empty
-
--- yeah I guess at each up/down step is independent of each other
 dirPathCosts :: Pushable a => Map (Maybe a) (Map (Maybe a) Int)
 dirPathCosts = (fmap . fmap) length dirPath
 
--- | missing the first element
-spellDirPath ::
-  Ord a =>
-  Map (Maybe a) (Map (Maybe a) [Maybe b]) ->
-  [Maybe a] ->
-  [Maybe b]
-spellDirPath mp xs = concat $ zipWith (\x y -> (mp M.! x) M.! y) xs (drop 1 xs)
-
--- composeDirPath ::
---   (Ord a, Pushable b) =>
---   Map (Maybe b) (Map (Maybe b) [Maybe c]) ->
---   Map (Maybe a) (Map (Maybe a) [Maybe b]) ->
---   Map (Maybe a, Maybe b) (Map (Maybe a) [Maybe c])
--- composeDirPath mpBC mpAB = M.fromListWith M.union
---   [ ((a0, b0), M.singleton a1 $ (spellDirPath mpBC $ b0 : pathA))
---     | (a0, as) <- M.toList mpAB
---     , (a1, pathA) <- M.toList as
---     ,  b0 <- toList allPushable'
---     -- , (b0, bs) <- M.toList mpBC
---     -- , (b1, pathB) <- M.toList bs
---   ]
---   -- (fmap . fmap) (spellDirPath mp undefined)
-
--- | this seems to work but at n=18 we get to 200,000,000 ... this grows too
--- big to keep them all in memory i think. maybe just keep the lengths?
-composeDirPath ::
-  Ord b =>
-  Map (Maybe b) (Map (Maybe b) [Maybe c]) ->
-  Map (Maybe a) (Map (Maybe a) [Maybe b]) ->
-  Map (Maybe a) (Map (Maybe a) [Maybe c])
-composeDirPath mp = (fmap . fmap) (spellDirPath mp . (Nothing :))
-
--- | missing the first element
 spellDirPathLengths ::
   Ord a =>
   Map (Maybe a) (Map (Maybe a) Int) ->
@@ -399,8 +106,6 @@ spellDirPathLengths ::
   Int
 spellDirPathLengths mp xs = sum $ zipWith (\x y -> (mp M.! x) M.! y) xs (drop 1 xs)
 
--- | this seems to work but at n=18 we get to 200,000,000 ... this grows too
--- big to keep them all in memory i think. maybe just keep the lengths?
 composeDirPathLengths ::
   Ord b =>
   Map (Maybe b) (Map (Maybe b) Int) ->
@@ -408,20 +113,6 @@ composeDirPathLengths ::
   Map (Maybe a) (Map (Maybe a) Int)
 composeDirPathLengths mp = (fmap . fmap) (spellDirPathLengths mp . (Nothing :))
 
--- [Just South,Just West,Nothing,Just West,Nothing,Nothing,Just East,Just
--- North,Just East,Nothing,Just South,Nothing,Just North,Just
--- West,Nothing,Just East,Just South,Nothing,Just North,Nothing]
--- v<A<AA>^>AvA^<A>vA^A
--- [Just South,Just West,Just West,Nothing,Just East,Just North,Just East,Nothing]
--- v<<A>^>A
--- ah hah, that's the key! >^> is more costly than >>^
--- we must penalize changes
-
--- <vA<AA>>^AvAA<^A>A
---   v <<   A >>  ^ A
---    <   A
--- 029A
-
 runPath :: Pushable a => Maybe a -> [DirPad] -> [Maybe a]
 runPath x = \case
   [] -> []
@@ -429,11 +120,6 @@ runPath x = \case
     Nothing -> error $ "hm..." ++ show d
     Just (y, out) -> maybe id (:) out $ runPath y ds
 
--- altP1 :: [NumPad] -> Int
--- altP1 = length . spellDirPath mp
---   where
---     mp = dirPath @Dir `composeDirPath` dirPath @Dir `composeDirPath` dirPath @(Finite 10)
-
 altP1 :: Int -> [NumPad] -> Int
 altP1 n = spellDirPathLengths mp . (Nothing :)
   where
@@ -444,125 +130,12 @@ altP1 n = spellDirPathLengths mp . (Nothing :)
 altP1' :: Int -> [NumPad] -> Int
 altP1' n ps = minimum do
   npp <- toList $ fullPadPaths (Nothing : ps)
-  -- dpp <- toList $ fullPadPaths (Nothing : npp)
-  -- dpp' <- toList $ fullPadPaths (Nothing : dpp)
   pure $ spellDirPathLengths mp (Nothing : npp)
   where
     mpChain :: [Map DirPad (Map DirPad Int)]
     mpChain = iterate (`composeDirPathLengths` dirPath @Dir) (dirPathCosts @Dir)
     mp = mpChain !! (n - 1)
 
-altP1'' :: Int -> [NumPad] -> Int
-altP1'' n ps = minimum do
-  npp <- traceLength . toList $ fullPadPaths (Nothing : ps)
-  traceM $ "npp " <> show npp
-  dpp <- traceLength . toList $ fullPadPaths (Nothing : npp)
-  traceM $ "dpp " <> show dpp
-  dpp' <- traceLength . toList $ fullPadPaths (Nothing : dpp)
-  traceM $ "dpp' " <> show dpp'
-  pure $ length dpp'
-  where
-    traceLength xs = traceShow (length xs) xs
-
-findFixed :: Pushable a => Maybe a -> Maybe a -> _
-findFixed a b = fst $ minimumBy (comparing length) do
-  npp <- toList $ padPaths a b
-  dpp <- toList $ fullPadPaths (Nothing : npp)
-  dpp' <- toList $ fullPadPaths (Nothing : dpp)
-  dpp'' <- toList $ fullPadPaths (Nothing : dpp')
-  -- dpp''' <- toList $ fullPadPaths (Nothing : dpp'')
-  pure (npp, length dpp'')
-  where
-    -- npp <- traceLength . toList $ fullPadPaths (Nothing : ps)
-    -- traceM $ "npp " <> show npp
-    -- dpp <- traceLength . toList $ fullPadPaths (Nothing : npp)
-    -- traceM $ "dpp " <> show dpp
-    -- dpp' <- traceLength . toList $ fullPadPaths (Nothing : dpp)
-    -- traceM $ "dpp' " <> show dpp'
-    -- pure $ length dpp'
-
-    traceLength xs = traceShow (length xs) xs
-
--- pure $ spellDirPathLengths mp (Nothing:npp)
--- where
--- mpChain :: [Map DirPad (Map DirPad Int)]
--- mpChain = iterate (`composeDirPathLengths` dirPath @Dir) (dirPathCosts @Dir)
--- mp = mpChain !! (n - 1)
-
--- applyPush :: DirPad -> Maybe a -> Maybe (Maybe a, Maybe (Maybe a))
-
----- | Best way to get from button to button
-----
----- Assume that same-to-same means same-to-A
--- dirPath :: forall a. Pushable a => Map (Maybe a) (Map (Maybe a) [_])
--- dirPath = M.fromSet ((`M.fromSet` allPushable') . go) allPushable'
---  where
---    go :: Maybe a -> Maybe a -> [DirPad]
---    go x y = mapMaybe (preview (_Left . _1)) . fromJust $ bfs step (Left (Nothing, x)) (== Right y)
---      where
---        step (Left (d, b)) = S.fromList
---          [ case bout of
---              Nothing -> Left (d', b')
---              Just o -> Right o
---            | push <- toList allDirPad
---          , (d', dout) <- maybeToList $ applyPushDir push d
---          , (b', bout) <- case dout of
---                          Nothing -> pure (b, Nothing)
---                          Just push' -> maybeToList $ applyPush push' b
---          ]
---        step (Right _) = S.empty
-
--- applyPushNum :: DirPad -> NumPad -> Maybe (NumPad, Maybe NumPad)
--- applyPushDir :: Maybe Dir -> DirPad -> Maybe (DirPad, Maybe DirPad)
--- step (Left (d, b)) = S.fromList
---   [ case bout of
---       Nothing -> Left (d', b')
---       Just o -> Right o
---     | push <- toList allDirPad
---   , (d', dout) <- maybeToList $ applyPushDir push d
---   , (b', bout) <- case dout of
---                   Nothing -> pure (b, Nothing)
---                   Just push' -> maybeToList $ applyPushDir push' b
-
---   ]
--- step (Right _) = S.empty
---
--- new realization, only the "top"
-
-day21b :: _ :~> _
-day21b =
-  MkSol
-    { sParse = sParse day21a
-    , sShow = show
-    , sSolve =
-        noFail $
-          sum
-            . map
-              ( \p ->
-                  let num :: Int
-                      num = read (map intToDigit (mapMaybe (fmap fromIntegral) p :: [Int]))
-                   in num * altP1 25 p
-              )
-    }
-
-numPadPaths :: NumPad -> NumPad -> Set [DirPad]
-numPadPaths start goal = fromMaybe S.empty do
-  minLen <- minimumMay $ length <$> options
-  pure $ S.fromList $ filter ((== minLen) . length) options
-  where
-    options = go S.empty start
-    go seen p = do
-      guard $ p `S.notMember` seen
-      d <- allDirPad
-      -- Nothing : (Just <$> [North ..])
-      (p', o) <- maybeToList $ applyPushNum d p
-      (d :) <$> case o of
-        Nothing -> go (S.insert p seen) p'
-        Just o' -> if o' == goal then pure [] else empty
-
-fullNumPadPaths :: [NumPad] -> Set [DirPad]
-fullNumPadPaths xs = S.fromList $ concat <$> zipWithM (\a b -> toList $ numPadPaths a b) xs (drop 1 xs)
-
 -- | a lot of these can be pruned waay by getting rid of NEN/ENE etc.
 padPaths :: Pushable a => Maybe a -> Maybe a -> Set [DirPad]
 padPaths start goal = fromMaybe S.empty do
@@ -572,9 +145,7 @@ padPaths start goal = fromMaybe S.empty do
     options = go S.empty start
     go seen p = do
       guard $ p `S.notMember` seen
-      d <- allDirPad
-      -- Nothing :
-      -- (Just <$> [North ..])
+      d <- allPushable'
       (p', o) <- maybeToList $ applyPush d p
       (d :) <$> case o of
         Nothing -> go (S.insert p seen) p'
@@ -583,49 +154,25 @@ padPaths start goal = fromMaybe S.empty do
 fullPadPaths :: Pushable a => [Maybe a] -> Set [DirPad]
 fullPadPaths xs = S.fromList $ concat <$> zipWithM (\a b -> toList $ padPaths a b) xs (drop 1 xs)
 
--- | Best way to get from button to button.  Ignore third path.
---
--- Hmm yeah we need to somehow involve the triple here otherwise no changes
--- propagate
---
--- We probably have to generate this as we go
-dirPathTriples :: forall a. Pushable a => Map (Maybe a) (Map (Maybe a) (Map (Maybe a) [DirPad]))
-dirPathTriples = fmap (\xs -> M.fromSet (const xs) $ S.fromList allPushable') <$> dirPath @a
-
--- | Only from X to Y, does not include from Y to Z
-composeTriples ::
-  Ord b =>
-  Map (Maybe b) (Map (Maybe b) (Map (Maybe b) [Maybe c])) ->
-  Map (Maybe a) (Map (Maybe a) (Map (Maybe a) [Maybe b])) ->
-  Map (Maybe a) (Map (Maybe a) (Map (Maybe a) [Maybe c]))
-composeTriples mp = (fmap . fmap . fmap) (spellTriples mp . (Nothing :))
-
--- | missing the first element
-spellTriples ::
-  Ord a =>
-  Map (Maybe a) (Map (Maybe a) (Map (Maybe a) [Maybe b])) ->
-  [Maybe a] ->
-  [Maybe b]
-spellTriples mp xs = concat $ zipWith3 (\x y z -> ((mp M.! x) M.! y) M.! z) xs (drop 1 xs) (drop 2 xs)
-
--- Map (Maybe b) (Map (Maybe b) [Maybe c]) ->
--- Map (Maybe a) (Map (Maybe a) [Maybe b]) ->
--- Map (Maybe a) (Map (Maybe a) [Maybe c])
-
--- score p = p * read @Int (map intToDigit (mapMaybe (fmap fromIntegral) goal :: [Int]))
-
-data BotState a = BS
-  { bsCache :: Map (V3 (Maybe a)) Int
-  , bsCurr :: Maybe a
-  , bsHistory :: Maybe (Maybe a, Maybe (Maybe a))
-  }
+pc :: Char -> Maybe (Finite 10)
+pc = fmap fromIntegral . digitToIntSafe <=< mfilter isDigit . Just
 
--- | How do we even step once? I guess we can search, 2^25 is the maximum
--- bound pretty much
-stepBotState :: BotState Dir -> BotState Dir
-stepBotState = undefined
+day21 :: Int -> [[NumPad]] :~> Int
+day21 n =
+  MkSol
+    { sParse = Just . map (map pc) . lines
+    , sShow = show
+    , sSolve =
+        noFail $
+          sum . map solve
+    }
+  where
+    solve p = num * altP1' n p
+      where
+        num = read (map intToDigit (mapMaybe (fmap fromIntegral) p :: [Int]))
 
--- data BotChain = BCNil NumPad
+day21a :: [[NumPad]] :~> Int
+day21a = day21 2
 
--- requestMotion :: NumPad -> State (NumPad, [DirPad]) Int
--- requestMotion = undefined
+day21b :: [[NumPad]] :~> Int
+day21b = day21 25
diff --git a/test-data/2024/21b.txt b/test-data/2024/21b.txt
index db7b2e9..e69de29 100644
--- a/test-data/2024/21b.txt
+++ b/test-data/2024/21b.txt
@@ -1,6 +0,0 @@
-029A
-980A
-179A
-456A
-379A
->>> 126384

From fa5ef5aa371401e7e5a79339c7558bc7fe19da18 Mon Sep 17 00:00:00 2001
From: justin <justin@jle.im>
Date: Fri, 27 Dec 2024 15:41:26 -0800
Subject: [PATCH 02/43] clean up day 21 for now

---
 2024/AOC2024/Day21.hs | 25 +++++++++++++++++++------
 1 file changed, 19 insertions(+), 6 deletions(-)

diff --git a/2024/AOC2024/Day21.hs b/2024/AOC2024/Day21.hs
index cbc7a6a..57ef931 100644
--- a/2024/AOC2024/Day21.hs
+++ b/2024/AOC2024/Day21.hs
@@ -12,9 +12,21 @@ module AOC2024.Day21 (
 )
 where
 
-import AOC.Prelude
+import AOC.Common (digitToIntSafe)
+import AOC.Common.Point (Dir (..), Point, V2 (V2), dirPoint)
+import AOC.Common.Search (bfsActions)
+import AOC.Solver (noFail, type (:~>) (..))
+import Control.Applicative (Alternative (empty))
+import Control.Monad (guard, mfilter, zipWithM, (<=<))
+import Data.Char (intToDigit, isDigit)
+import Data.Finite (Finite, finites)
+import Data.Foldable (Foldable (toList))
+import Data.Map (Map)
 import qualified Data.Map as M
+import Data.Maybe (fromJust, fromMaybe, mapMaybe, maybeToList)
+import Data.Set (Set)
 import qualified Data.Set as S
+import Safe.Foldable (minimumMay)
 
 type NumPad = Maybe (Finite 10)
 type DirPad = Maybe Dir
@@ -120,15 +132,16 @@ runPath x = \case
     Nothing -> error $ "hm..." ++ show d
     Just (y, out) -> maybe id (:) out $ runPath y ds
 
-altP1 :: Int -> [NumPad] -> Int
-altP1 n = spellDirPathLengths mp . (Nothing :)
+-- | this seems to work for the answers but not for the sample data
+_solveCodeNoSearch :: Int -> [NumPad] -> Int
+_solveCodeNoSearch n = spellDirPathLengths mp . (Nothing :)
   where
     mpChain :: [Map DirPad (Map DirPad Int)]
     mpChain = iterate (`composeDirPathLengths` dirPath @Dir) (dirPathCosts @Dir)
     mp = (mpChain !! (n - 1)) `composeDirPathLengths` dirPath @(Finite 10)
 
-altP1' :: Int -> [NumPad] -> Int
-altP1' n ps = minimum do
+solveCodeWithSearch :: Int -> [NumPad] -> Int
+solveCodeWithSearch n ps = minimum do
   npp <- toList $ fullPadPaths (Nothing : ps)
   pure $ spellDirPathLengths mp (Nothing : npp)
   where
@@ -167,7 +180,7 @@ day21 n =
           sum . map solve
     }
   where
-    solve p = num * altP1' n p
+    solve p = num * solveCodeWithSearch n p
       where
         num = read (map intToDigit (mapMaybe (fmap fromIntegral) p :: [Int]))
 

From dd89345e4d43d724e0c122a312fa760fede51311 Mon Sep 17 00:00:00 2001
From: justin <justin@jle.im>
Date: Fri, 27 Dec 2024 15:48:34 -0800
Subject: [PATCH 03/43] add benchs, fix standlone link

---
 bench-results/2024/day21.txt | 18 ++++++++++++++++++
 bench-results/2024/day24.txt | 20 ++++++++++++++++++++
 bench-results/2024/day25.txt | 10 ++++++++++
 site/default.nix             | 17 +++++++++++------
 4 files changed, 59 insertions(+), 6 deletions(-)
 create mode 100644 bench-results/2024/day21.txt
 create mode 100644 bench-results/2024/day24.txt
 create mode 100644 bench-results/2024/day25.txt

diff --git a/bench-results/2024/day21.txt b/bench-results/2024/day21.txt
new file mode 100644
index 0000000..e2d3531
--- /dev/null
+++ b/bench-results/2024/day21.txt
@@ -0,0 +1,18 @@
+>> Day 21a
+benchmarking...
+time                 836.4 μs   (835.0 μs .. 837.6 μs)
+                     1.000 R²   (1.000 R² .. 1.000 R²)
+mean                 838.9 μs   (837.6 μs .. 840.4 μs)
+std dev              5.489 μs   (4.298 μs .. 7.066 μs)
+
+* parsing and formatting times excluded
+
+>> Day 21b
+benchmarking...
+time                 836.6 μs   (834.9 μs .. 838.8 μs)
+                     1.000 R²   (1.000 R² .. 1.000 R²)
+mean                 837.2 μs   (836.0 μs .. 840.9 μs)
+std dev              5.832 μs   (2.314 μs .. 11.46 μs)
+
+* parsing and formatting times excluded
+
diff --git a/bench-results/2024/day24.txt b/bench-results/2024/day24.txt
new file mode 100644
index 0000000..9acdc7c
--- /dev/null
+++ b/bench-results/2024/day24.txt
@@ -0,0 +1,20 @@
+>> Day 24a
+benchmarking...
+time                 97.06 μs   (95.96 μs .. 97.88 μs)
+                     0.999 R²   (0.999 R² .. 1.000 R²)
+mean                 94.19 μs   (93.47 μs .. 94.95 μs)
+std dev              2.477 μs   (2.155 μs .. 2.931 μs)
+variance introduced by outliers: 23% (moderately inflated)
+
+* parsing and formatting times excluded
+
+>> Day 24b
+benchmarking...
+time                 1.696 s    (1.664 s .. 1.734 s)
+                     1.000 R²   (1.000 R² .. 1.000 R²)
+mean                 1.699 s    (1.690 s .. 1.712 s)
+std dev              12.02 ms   (88.75 μs .. 14.67 ms)
+variance introduced by outliers: 19% (moderately inflated)
+
+* parsing and formatting times excluded
+
diff --git a/bench-results/2024/day25.txt b/bench-results/2024/day25.txt
new file mode 100644
index 0000000..7ad450e
--- /dev/null
+++ b/bench-results/2024/day25.txt
@@ -0,0 +1,10 @@
+>> Day 25a
+benchmarking...
+time                 6.789 ms   (6.668 ms .. 6.890 ms)
+                     0.990 R²   (0.973 R² .. 1.000 R²)
+mean                 6.953 ms   (6.849 ms .. 7.262 ms)
+std dev              552.1 μs   (61.43 μs .. 1.049 ms)
+variance introduced by outliers: 46% (moderately inflated)
+
+* parsing and formatting times excluded
+
diff --git a/site/default.nix b/site/default.nix
index 0093ccb..f3183aa 100644
--- a/site/default.nix
+++ b/site/default.nix
@@ -25,6 +25,9 @@ let
                     ${lib.removeSuffix "\n\n" (builtins.readFile daymap.benchmark)}
                     ```
                   '';
+                standaloneLink = lib.optionalString
+                  (builtins.hasAttr "reflection" daymap)
+                  " / *[Standalone][d${daylong}s]*";
                 body =
                   ''
                     Day ${dayshort}
@@ -35,7 +38,7 @@ let
                     `./reflections/${year}/day${daylong}.md`.  If you want to edit this, edit that file instead!
                     -->
 
-                    *[Top](#)* / *[Prompt][d${daylong}p]* / *[Code][d${daylong}g]* / *[Standalone][d${daylong}s]*
+                    *[Top](#)* / *[Prompt][d${daylong}p]* / *[Code][d${daylong}g]*${standaloneLink}
 
                     [d${daylong}p]: https://adventofcode.com/${year}/day/${dayshort}
                     [d${daylong}g]: https://github.com/${github}/advent-of-code/blob/master/${year}/AOC${year}/Day${daylong}.hs
@@ -58,10 +61,12 @@ let
             let y2 = lib.removePrefix "aoc" n2;
             in "[${y2}](https://github.com/${github}/advent-of-code/wiki/Reflections-${y2})";
             tocLink = d: dm:
-              let dshort = lib.removePrefix "0" (lib.removePrefix "day" d);
-                  caveat = if builtins.hasAttr "reflection" dm
-                    then ""
-                    else " (benchmark only)";
+              let
+                dshort = lib.removePrefix "0" (lib.removePrefix "day" d);
+                caveat =
+                  if builtins.hasAttr "reflection" dm
+                  then ""
+                  else " (benchmark only)";
               in
               ''
                 * [Day ${dshort}](https://github.com/${github}/advent-of-code/wiki/Reflections-${year}#day-${dshort})${caveat}
@@ -97,7 +102,7 @@ let
     writeTextDir "Home.md"
       ''
         Check out the reflections page for each year!
-      
+
         ${lib.concatStrings (lib.mapAttrsToList mkLink renderedMap)}
       ''
 

From 26ab1e111497f3fbf47b97f0d0f8184efe259165 Mon Sep 17 00:00:00 2001
From: justin <justin@jle.im>
Date: Fri, 27 Dec 2024 15:56:10 -0800
Subject: [PATCH 04/43] clena up day 21

---
 2024/AOC2024/Day21.hs | 55 +++++++++++--------------------------------
 1 file changed, 14 insertions(+), 41 deletions(-)

diff --git a/2024/AOC2024/Day21.hs b/2024/AOC2024/Day21.hs
index 57ef931..b69d7da 100644
--- a/2024/AOC2024/Day21.hs
+++ b/2024/AOC2024/Day21.hs
@@ -16,17 +16,13 @@ import AOC.Common (digitToIntSafe)
 import AOC.Common.Point (Dir (..), Point, V2 (V2), dirPoint)
 import AOC.Common.Search (bfsActions)
 import AOC.Solver (noFail, type (:~>) (..))
-import Control.Applicative (Alternative (empty))
-import Control.Monad (guard, mfilter, zipWithM, (<=<))
+import Control.Monad (mfilter, (<=<))
 import Data.Char (intToDigit, isDigit)
 import Data.Finite (Finite, finites)
-import Data.Foldable (Foldable (toList))
 import Data.Map (Map)
 import qualified Data.Map as M
-import Data.Maybe (fromJust, fromMaybe, mapMaybe, maybeToList)
-import Data.Set (Set)
+import Data.Maybe (fromJust, mapMaybe, maybeToList)
 import qualified Data.Set as S
-import Safe.Foldable (minimumMay)
 
 type NumPad = Maybe (Finite 10)
 type DirPad = Maybe Dir
@@ -91,17 +87,22 @@ dirPath :: forall a. Pushable a => Map (Maybe a) (Map (Maybe a) [DirPad])
 dirPath = M.fromSet ((`M.fromSet` S.fromList allPushable') . go) (S.fromList allPushable')
   where
     go :: Maybe a -> Maybe a -> [DirPad]
-    go x y = runPath Nothing . fromJust $ bfsActions step (Left (x, Nothing)) (== Right y)
+    go x y =
+      runPath Nothing . runPath Nothing . fromJust $
+        bfsActions step (Left (x, Nothing, Nothing)) (== Right y)
       where
-        step (Left (b, d)) =
+        step (Left (b, d, e)) =
           reverse
             [ ( push
               , case bout of
-                  Nothing -> Left (b', d')
+                  Nothing -> Left (b', d', e')
                   Just o -> Right o
               )
             | push <- allPushable'
-            , (d', dout) <- maybeToList $ applyPush push d
+            , (e', eout) <- maybeToList $ applyPush push e
+            , (d', dout) <- case eout of
+                Nothing -> pure (d, Nothing)
+                Just push' -> maybeToList $ applyPush push' d
             , (b', bout) <- case dout of
                 Nothing -> pure (b, Nothing)
                 Just push' -> maybeToList $ applyPush push' b
@@ -132,41 +133,13 @@ runPath x = \case
     Nothing -> error $ "hm..." ++ show d
     Just (y, out) -> maybe id (:) out $ runPath y ds
 
--- | this seems to work for the answers but not for the sample data
-_solveCodeNoSearch :: Int -> [NumPad] -> Int
-_solveCodeNoSearch n = spellDirPathLengths mp . (Nothing :)
+solveCodeNoSearch :: Int -> [NumPad] -> Int
+solveCodeNoSearch n = spellDirPathLengths mp . (Nothing :)
   where
     mpChain :: [Map DirPad (Map DirPad Int)]
     mpChain = iterate (`composeDirPathLengths` dirPath @Dir) (dirPathCosts @Dir)
     mp = (mpChain !! (n - 1)) `composeDirPathLengths` dirPath @(Finite 10)
 
-solveCodeWithSearch :: Int -> [NumPad] -> Int
-solveCodeWithSearch n ps = minimum do
-  npp <- toList $ fullPadPaths (Nothing : ps)
-  pure $ spellDirPathLengths mp (Nothing : npp)
-  where
-    mpChain :: [Map DirPad (Map DirPad Int)]
-    mpChain = iterate (`composeDirPathLengths` dirPath @Dir) (dirPathCosts @Dir)
-    mp = mpChain !! (n - 1)
-
--- | a lot of these can be pruned waay by getting rid of NEN/ENE etc.
-padPaths :: Pushable a => Maybe a -> Maybe a -> Set [DirPad]
-padPaths start goal = fromMaybe S.empty do
-  minLen <- minimumMay $ length <$> options
-  pure $ S.fromList $ filter ((== minLen) . length) options
-  where
-    options = go S.empty start
-    go seen p = do
-      guard $ p `S.notMember` seen
-      d <- allPushable'
-      (p', o) <- maybeToList $ applyPush d p
-      (d :) <$> case o of
-        Nothing -> go (S.insert p seen) p'
-        Just o' -> if o' == goal then pure [] else empty
-
-fullPadPaths :: Pushable a => [Maybe a] -> Set [DirPad]
-fullPadPaths xs = S.fromList $ concat <$> zipWithM (\a b -> toList $ padPaths a b) xs (drop 1 xs)
-
 pc :: Char -> Maybe (Finite 10)
 pc = fmap fromIntegral . digitToIntSafe <=< mfilter isDigit . Just
 
@@ -180,7 +153,7 @@ day21 n =
           sum . map solve
     }
   where
-    solve p = num * solveCodeWithSearch n p
+    solve p = num * solveCodeNoSearch n p
       where
         num = read (map intToDigit (mapMaybe (fmap fromIntegral) p :: [Int]))
 

From c7cf6e772448153ef18c5f360032c0194f4e1029 Mon Sep 17 00:00:00 2001
From: justin <justin@jle.im>
Date: Fri, 27 Dec 2024 15:59:32 -0800
Subject: [PATCH 05/43] seems to be less dependent on prios

---
 2024/AOC2024/Day21.hs | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/2024/AOC2024/Day21.hs b/2024/AOC2024/Day21.hs
index b69d7da..91c5b7b 100644
--- a/2024/AOC2024/Day21.hs
+++ b/2024/AOC2024/Day21.hs
@@ -75,14 +75,14 @@ applyPush = \case
         ]
 
 instance Pushable Dir where
-  allPushable = [East, South, North, West]
+  allPushable = [North ..]
   pushLayout = dirPad
 
 instance Pushable (Finite 10) where
   allPushable = finites
   pushLayout = numPad
 
--- | Best way to get from button to button. penalize motion
+-- | Best way to get from button to button. penalize motion two bots down
 dirPath :: forall a. Pushable a => Map (Maybe a) (Map (Maybe a) [DirPad])
 dirPath = M.fromSet ((`M.fromSet` S.fromList allPushable') . go) (S.fromList allPushable')
   where

From d66abb3d9efec2f609ed69c8e4ccb56d6a24a874 Mon Sep 17 00:00:00 2001
From: justin <justin@jle.im>
Date: Fri, 27 Dec 2024 16:15:49 -0800
Subject: [PATCH 06/43] day 21 optimization, down to 4us

---
 2024/AOC2024/Day21.hs        | 22 +++++++++++-----------
 bench-results/2024/day21.txt | 15 ++++++++-------
 2 files changed, 19 insertions(+), 18 deletions(-)

diff --git a/2024/AOC2024/Day21.hs b/2024/AOC2024/Day21.hs
index 91c5b7b..3a521b2 100644
--- a/2024/AOC2024/Day21.hs
+++ b/2024/AOC2024/Day21.hs
@@ -53,34 +53,34 @@ dirPad =
     , (V2 2 1, Nothing)
     ]
 
-class Ord a => Pushable a where
+class (Ord a, Show a) => Pushable a where
   allPushable :: [a]
-  pushLayout :: Map Point (Maybe a)
+  pushMap :: Map (Maybe a) (Map Dir (Maybe a))
 
 allPushable' :: Pushable a => [Maybe a]
 allPushable' = Nothing : fmap Just allPushable
 
+pushMapFromLayout :: Pushable a => Map Point (Maybe a) -> Map (Maybe a) (Map Dir (Maybe a))
+pushMapFromLayout pushLayout =
+  M.fromList
+    [ (x, M.fromList [(d, y) | d <- [North ..], y <- maybeToList $ M.lookup (p + dirPoint d) pushLayout])
+    | (p, x) <- M.toList pushLayout
+    ]
+
 applyPush :: forall a. Pushable a => Maybe Dir -> Maybe a -> Maybe (Maybe a, Maybe (Maybe a))
 applyPush = \case
   Nothing -> \x -> Just (x, Just x)
   Just d -> \x -> do
     y <- M.lookup d =<< M.lookup x pushMap
     pure (y, Nothing)
-  where
-    pushMap :: Map (Maybe a) (Map Dir (Maybe a))
-    pushMap =
-      M.fromList
-        [ (x, M.fromList [(d, y) | d <- [North ..], y <- maybeToList $ M.lookup (p + dirPoint d) pushLayout])
-        | (p, x) <- M.toList pushLayout
-        ]
 
 instance Pushable Dir where
   allPushable = [North ..]
-  pushLayout = dirPad
+  pushMap = pushMapFromLayout dirPad
 
 instance Pushable (Finite 10) where
   allPushable = finites
-  pushLayout = numPad
+  pushMap = pushMapFromLayout numPad
 
 -- | Best way to get from button to button. penalize motion two bots down
 dirPath :: forall a. Pushable a => Map (Maybe a) (Map (Maybe a) [DirPad])
diff --git a/bench-results/2024/day21.txt b/bench-results/2024/day21.txt
index e2d3531..4e1fdcc 100644
--- a/bench-results/2024/day21.txt
+++ b/bench-results/2024/day21.txt
@@ -1,18 +1,19 @@
 >> Day 21a
 benchmarking...
-time                 836.4 μs   (835.0 μs .. 837.6 μs)
+time                 3.965 μs   (3.959 μs .. 3.970 μs)
                      1.000 R²   (1.000 R² .. 1.000 R²)
-mean                 838.9 μs   (837.6 μs .. 840.4 μs)
-std dev              5.489 μs   (4.298 μs .. 7.066 μs)
+mean                 3.967 μs   (3.961 μs .. 3.973 μs)
+std dev              17.27 ns   (14.75 ns .. 20.43 ns)
 
 * parsing and formatting times excluded
 
 >> Day 21b
 benchmarking...
-time                 836.6 μs   (834.9 μs .. 838.8 μs)
-                     1.000 R²   (1.000 R² .. 1.000 R²)
-mean                 837.2 μs   (836.0 μs .. 840.9 μs)
-std dev              5.832 μs   (2.314 μs .. 11.46 μs)
+time                 3.971 μs   (3.958 μs .. 3.988 μs)
+                     0.999 R²   (0.996 R² .. 1.000 R²)
+mean                 4.020 μs   (3.971 μs .. 4.206 μs)
+std dev              304.7 ns   (22.58 ns .. 645.9 ns)
+variance introduced by outliers: 80% (severely inflated)
 
 * parsing and formatting times excluded
 

From 7b10a3603b3baa64b748291075c3adc1c639798c Mon Sep 17 00:00:00 2001
From: justin <justin@jle.im>
Date: Fri, 27 Dec 2024 16:33:42 -0800
Subject: [PATCH 07/43] day 25 reflection

---
 2024/AOC2024/Day21.hs     |  9 +++++----
 reflections/2024/day25.md | 33 +++++++++++++++++++++++++++++++++
 2 files changed, 38 insertions(+), 4 deletions(-)
 create mode 100644 reflections/2024/day25.md

diff --git a/2024/AOC2024/Day21.hs b/2024/AOC2024/Day21.hs
index 3a521b2..855937c 100644
--- a/2024/AOC2024/Day21.hs
+++ b/2024/AOC2024/Day21.hs
@@ -12,7 +12,7 @@ module AOC2024.Day21 (
 )
 where
 
-import AOC.Common (digitToIntSafe)
+import AOC.Common (digitToIntSafe, (!!!))
 import AOC.Common.Point (Dir (..), Point, V2 (V2), dirPoint)
 import AOC.Common.Search (bfsActions)
 import AOC.Solver (noFail, type (:~>) (..))
@@ -133,12 +133,13 @@ runPath x = \case
     Nothing -> error $ "hm..." ++ show d
     Just (y, out) -> maybe id (:) out $ runPath y ds
 
+dirPathChain :: Int -> Map DirPad (Map DirPad Int)
+dirPathChain n = iterate (`composeDirPathLengths` dirPath @Dir) (dirPathCosts @Dir) !!! n
+
 solveCodeNoSearch :: Int -> [NumPad] -> Int
 solveCodeNoSearch n = spellDirPathLengths mp . (Nothing :)
   where
-    mpChain :: [Map DirPad (Map DirPad Int)]
-    mpChain = iterate (`composeDirPathLengths` dirPath @Dir) (dirPathCosts @Dir)
-    mp = (mpChain !! (n - 1)) `composeDirPathLengths` dirPath @(Finite 10)
+    mp = dirPathChain (n - 1) `composeDirPathLengths` dirPath @(Finite 10)
 
 pc :: Char -> Maybe (Finite 10)
 pc = fmap fromIntegral . digitToIntSafe <=< mfilter isDigit . Just
diff --git a/reflections/2024/day25.md b/reflections/2024/day25.md
new file mode 100644
index 0000000..9827fda
--- /dev/null
+++ b/reflections/2024/day25.md
@@ -0,0 +1,33 @@
+As usual, a nice relaxing day to celebrate Christmas :)
+
+Assuming we have a list of keys and locks interspersed, as `[Set (Int, Int)]`, we
+can marginalize to get the x-wise histograms and y-wise histograms:
+
+```haskell
+marginX :: Set (Int, Int) -> Map Int Int
+marginX = M.fromListWith (+) . toList
+
+marginY :: Set (Int, Int) -> Map Int Int
+marginY = M.fromListWith (+) . map swap . toList
+```
+
+We can distinguish keys from locks by checking if y=0 has all 5 points filled:
+
+```haskell
+isLock :: Set (Int, Int) -> Bool
+isLock = (== 5) . M.findWithDefault 0 0 . marginY
+```
+
+We can check if a pair is valid by checking that none of their x margins add up
+to greater than 7.  Wrapping it all in the list monad's cartesian product and
+we get:
+
+```haskell
+day25 :: [Set (Int, Int)] -> Int
+day25 = uncurry countCombos . partition isLock
+  where
+    countCombos locks keys = length do
+      lock <- marginX <$> locks
+      key <- marginX <$> keys
+      guard $ all (< 8) (M.unionWith (+) lock key)
+```

From 589a02521cce0c5a7cecde507b05d3beb1c56f09 Mon Sep 17 00:00:00 2001
From: justin <justin@jle.im>
Date: Fri, 27 Dec 2024 16:34:36 -0800
Subject: [PATCH 08/43] fix day 25 refl

---
 reflections/2024/day25.md | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/reflections/2024/day25.md b/reflections/2024/day25.md
index 9827fda..34bcca1 100644
--- a/reflections/2024/day25.md
+++ b/reflections/2024/day25.md
@@ -5,10 +5,10 @@ can marginalize to get the x-wise histograms and y-wise histograms:
 
 ```haskell
 marginX :: Set (Int, Int) -> Map Int Int
-marginX = M.fromListWith (+) . toList
+marginX = M.fromListWith (+) . map (\(x, y) -> (x, 1)) . toList
 
 marginY :: Set (Int, Int) -> Map Int Int
-marginY = M.fromListWith (+) . map swap . toList
+marginY = M.fromListWith (+) . map (\(x, y) -> (y, 1)) . toList
 ```
 
 We can distinguish keys from locks by checking if y=0 has all 5 points filled:

From 5daddee984dcff3a3fa13f6a9f4610b236318ae4 Mon Sep 17 00:00:00 2001
From: justin <justin@jle.im>
Date: Fri, 27 Dec 2024 16:53:13 -0800
Subject: [PATCH 09/43] day 14 reflections

---
 2024/AOC2024/Day14.hs     | 11 ++-------
 reflections/2024/day14.md | 50 +++++++++++++++++++++++++++++++++++++++
 2 files changed, 52 insertions(+), 9 deletions(-)
 create mode 100644 reflections/2024/day14.md

diff --git a/2024/AOC2024/Day14.hs b/2024/AOC2024/Day14.hs
index 64b5fed..9a81156 100644
--- a/2024/AOC2024/Day14.hs
+++ b/2024/AOC2024/Day14.hs
@@ -17,7 +17,7 @@ import AOC.Common.Parser (pDecimal, parseMaybe', sepByLines, sequenceSepBy)
 import AOC.Common.Point (Point)
 import AOC.Solver (noFail, type (:~>) (..))
 import Control.Lens (view)
-import Control.Monad (join)
+import Control.Monad (join, mfilter)
 import Data.Bifunctor (Bifunctor (second))
 import Data.Foldable1 (foldMap1)
 import qualified Data.List.NonEmpty as NE
@@ -45,14 +45,7 @@ day14a =
   where
     score = product . freqs . mapMaybe quadrant . VS.toList
       where
-        quadrant (V2 x y) = do
-          qx <- classify $ compare x 50
-          qy <- classify $ compare y 51
-          pure (qx, qy)
-        classify = \case
-          LT -> Just False
-          EQ -> Nothing
-          GT -> Just True
+        quadrant p = mfilter (notElem EQ) $ Just (compare <$> p <*> V2 50 51)
 
 day14b :: [V2 Point] :~> Int
 day14b =
diff --git a/reflections/2024/day14.md b/reflections/2024/day14.md
new file mode 100644
index 0000000..aad9c2d
--- /dev/null
+++ b/reflections/2024/day14.md
@@ -0,0 +1,50 @@
+Problems like this showcase the utility of using `V2` from *linear* for keeping
+track of points. The "step" function ends up pretty clean:
+
+```haskell
+type Point = V2 Int
+
+step :: Point -> Point -> Point
+step v x = mod <$> (x + v) <*> V2 101 103
+```
+
+Also, if we parse into `[V2 Point]` (a position and velocity paired up in a
+`V2`) we can use `sequence` to unzip our list into a `V2 [Point] [Point]`, a
+list of positions and velocities. We can then use `iterate` and `zipWith` to
+step them:
+
+```haskell
+part1 :: [V2 Point] -> Int
+part2 pvs = score $ iterate (zipWith step vs) ps !! 100
+  where
+    V2 ps vs = sequence pvs
+    score = product . M.fromListWith (+) . mapMaybe (\p -> (classify p, 1))
+    quadrant p = mfilter (notElem EQ) $ Just (compare <$> p <*> V2 50 51)
+```
+
+`quadrant` here uses the `Applicative` instance and also the `Foldable`
+instance with `notElem`.
+
+For my original solve of part 2, i stopped when I detected any large clusters.
+But, once we see that the actual input consists of vertical and horizontal
+lines, we can do a bit of optimizations. We know that the x positions have a
+period of 101, and so frames with vertical lines appear with period 101.  We
+know that y positions have a period of 103 and so frames with horizontal lines
+appear with period 103. So, we can look at the first 101 frames and find any
+vertical lines, and then the first 103 frames and find any horizontal lines,
+and then do some math to figure out when the periodic appearances will line up.
+
+```haskell
+maxMargin :: [[Int]] -> Int
+maxMargin = fst . maximumBy (comparing (concentration . snd)) . zip [0..]
+  where
+    concentration = product . M.fromListWith (+) . map (,1)
+
+part1 :: [V2 Point] -> Int
+part2 pvs = (xi + ((yi - xi) * 5151)) `mod` 10403
+  where
+    V2 ps vs = sequence pvs
+    steps = iterate (zipWith step vs) ps
+    xi = maxMargin (view _x <$> take 101 steps)
+    yi = maxMargin (view _y <$> take 103 steps)
+```

From f217b3cfce4602c30509d7557f7047ae8e3b363c Mon Sep 17 00:00:00 2001
From: justin <justin@jle.im>
Date: Fri, 27 Dec 2024 20:56:37 -0800
Subject: [PATCH 10/43] day 15 reflection

---
 2024/AOC2024/Day15.hs     | 11 +++--
 reflections/2024/day15.md | 96 +++++++++++++++++++++++++++++++++++++++
 2 files changed, 103 insertions(+), 4 deletions(-)
 create mode 100644 reflections/2024/day15.md

diff --git a/2024/AOC2024/Day15.hs b/2024/AOC2024/Day15.hs
index 8a91276..425c8d4 100644
--- a/2024/AOC2024/Day15.hs
+++ b/2024/AOC2024/Day15.hs
@@ -75,8 +75,8 @@ day15b =
           . M.keys
           . M.filter not
           . snd
-          . foldl' (stepper glue walls') (person', crates') $
-          path
+          . foldl' (stepper glue walls') (person', crates')
+          $ path
     }
   where
     doublePoint (V2 x y) = ($ y) <$> [V2 (2 * x), V2 (2 * x + 1)]
@@ -86,11 +86,12 @@ day15b =
       True -> subtract (V2 1 0)
 
 stepper ::
+  forall a.
   (Point -> Dir -> a -> [(Point, a)]) ->
   Set Point ->
-  (V2 Int, Map (V2 Int) a) ->
+  (Point, Map Point a) ->
   Dir ->
-  (V2 Int, Map (V2 Int) a)
+  (Point, Map Point a)
 stepper glue walls (person, crates) d
   | person' `S.member` walls = (person, crates)
   | otherwise = case M.lookup person' crates of
@@ -98,8 +99,10 @@ stepper glue walls (person, crates) d
       Nothing -> (person', crates)
   where
     person' = person + dirPoint d
+    tryMove :: Point -> Map Point a -> a -> Maybe (Map Point a)
     tryMove p crates' moved = do
       foldlM (\cs (p', moved') -> tryMoveSingle p' cs moved') crates' ((p, moved) : glue p d moved)
+    tryMoveSingle :: Point -> Map Point a -> a -> Maybe (Map Point a)
     tryMoveSingle p crates' moved =
       commit
         <$> if p' `S.member` walls
diff --git a/reflections/2024/day15.md b/reflections/2024/day15.md
new file mode 100644
index 0000000..dfcfbeb
--- /dev/null
+++ b/reflections/2024/day15.md
@@ -0,0 +1,96 @@
+This is puzzle involves iteratively following "steps" and seeing how things
+change.  If we store the world state polymorphically as a `Map Point a`, then
+we can write something generic to unite both parts.
+
+Our polymorphic stepper will take a:
+
+1.  `Set Point` of immovable walls
+2.  A "glue" function `Point -> Dir -> a -> [(Point, a)]` which takes an `a`
+    world entity and return any other entity it will be glued to.
+2.  A starting state `(Point, Map Point a)`, the player position and the
+    position of the crates
+3.  A `Dir` motion
+
+and return the new updated `(Point, Map Point a)` state.
+
+It will work by first trying to update the person state: if it moves into a
+crate, try to move the crate in the same direction, `Point -> Map Point a -> a
+-> Maybe (Map Point a)`. This will then recursively try to move any crates
+along the way and any crates glued to it. The whole thing is wrapped up in a
+big `Maybe` monad, sequenced together with `foldlM`, so if anything fails, the
+whole thing fails.
+
+```haskell
+type Point = V2 Int
+data Dir = North | East | South | West
+
+moveByDir :: Point -> Dir -> Point
+moveByDir p d = p + case d of
+  North -> V2 0 1
+  East -> V2 1 0
+  South -> V2 0 (-1)
+  West -> V2 (-1) 1
+
+stepper ::
+  forall a.
+  (Point -> Dir -> a -> [(Point, a)]) ->
+  Set Point ->
+  (Point, Map Point a) ->
+  Dir ->
+  (Point, Map Point a)
+stepper glue walls (person, crates) d
+  | person' `S.member` walls = (person, crates)
+  | otherwise = case M.lookup person' crates of
+      Just lr -> maybe (person, crates) (person',) $ tryMove person' crates lr
+      Nothing -> (person', crates)
+  where
+    person' = person `moveByDir` d
+    tryMove :: Point -> Map Point a -> a -> Maybe (Map Point a)
+    tryMove p crates' moved = do
+      foldlM (\cs (p', moved') -> tryMoveSingle p' cs moved') crates' ((p, moved) : glue p d moved)
+    tryMoveSingle :: Point -> Map Point a -> a -> Maybe (Map Point a)
+    tryMoveSingle p crates' moved =
+      commit
+        <$> if p' `S.member` walls
+          then Nothing
+          else case M.lookup p' crates' of
+            Just lr -> tryMove p' crates' lr
+            Nothing -> Just crates'
+      where
+        p' = p `moveByDir` d
+        commit = M.delete p . M.insert p' moved
+```
+
+Now to pick the glue and the `a`: for part 1, each crate contains no extra
+information, so `a` will be `()` and `glue _ _ _ = []`, no glue.
+
+```haskell
+part1 :: Set Point -> Set Point -> Point -> [Dir] -> Set Point
+part1 crates walls person =
+    M.keys . snd . foldl' (stepper glue crates) (person, M.fromSet (const ()) walls)
+  where
+    glue _ _ _ = []
+```
+
+For part 2, each crate is either a `[` or a `]`, left or right. So we can have
+the `a` be `Bool`, and the glue being the corresponding pair, but only if the
+motion direction is vertical.
+
+```haskell
+part2 :: Set Point -> Map Point Bool -> Point -> [Dir] -> Set Point
+part2 crates walls person =
+    M.keys . snd . foldl' (stepper glue crates) (person, walls)
+  where
+    glue p d lr = [(bump lr p, not lr) | d `elem` [North, South]]
+    bump = \case
+      False -> (+ V2 1 0)
+      True -> subtract (V2 1 0)
+```
+
+We can score our set of points:
+
+```haskell
+score :: Set Point -> Int
+score = sum . map (\(V2 x y) -> 100 * y + x) . toList 
+```
+

From 5f1b9324515e6a6bf18263496584c6049b8254a9 Mon Sep 17 00:00:00 2001
From: justin <justin@jle.im>
Date: Sat, 28 Dec 2024 14:50:05 -0800
Subject: [PATCH 11/43] day 18 reflections

---
 common/AOC/Common/Search.hs |   1 -
 reflections/2024/day15.md   |   2 +-
 reflections/2024/day18.md   | 100 ++++++++++++++++++++++++++++++++++++
 3 files changed, 101 insertions(+), 2 deletions(-)
 create mode 100644 reflections/2024/day18.md

diff --git a/common/AOC/Common/Search.hs b/common/AOC/Common/Search.hs
index 735dcf2..25a9220 100644
--- a/common/AOC/Common/Search.hs
+++ b/common/AOC/Common/Search.hs
@@ -122,7 +122,6 @@ data BFSActionState a n = BAS
   -- ^ queue
   }
 
-
 -- | Breadth-first search, with loop detection, that outputs actions
 bfsActions ::
   forall a n.
diff --git a/reflections/2024/day15.md b/reflections/2024/day15.md
index dfcfbeb..ea71c76 100644
--- a/reflections/2024/day15.md
+++ b/reflections/2024/day15.md
@@ -18,7 +18,7 @@ crate, try to move the crate in the same direction, `Point -> Map Point a -> a
 -> Maybe (Map Point a)`. This will then recursively try to move any crates
 along the way and any crates glued to it. The whole thing is wrapped up in a
 big `Maybe` monad, sequenced together with `foldlM`, so if anything fails, the
-whole thing fails.
+whole thing fails. This is essentially a recursion-based DFS.
 
 ```haskell
 type Point = V2 Int
diff --git a/reflections/2024/day18.md b/reflections/2024/day18.md
new file mode 100644
index 0000000..5c7b494
--- /dev/null
+++ b/reflections/2024/day18.md
@@ -0,0 +1,100 @@
+Honestly there really isn't much to this puzzle other than applying a basic BFS
+to solve the maze. It isn't really even big enough that a-star would help.
+
+If you parse the maze into an *fgl* graph, you can use something like `sp ::
+Node -> Node -> gr a b -> Maybe Path` to get the shortest path. However,
+because we're here anyway, I'm going to paste in my personal BFS code that I
+use for these challenges that I wrote a while ago, where neighborhoods are
+given by an `n -> Set n` function. It uses a `Seq` as its internal queue, which
+is my favorite queue type in Haskell.
+
+```haskell
+data BFSState n = BS
+  { _bsClosed :: !(Map n (Maybe n))
+  -- ^ map of item to "parent"
+  , _bsOpen :: !(Seq n)
+  -- ^ queue
+  }
+
+bfs ::
+  forall n.
+  Ord n =>
+  -- | neighborhood
+  (n -> Set n) ->
+  -- | start
+  n ->
+  -- | target
+  (n -> Bool) ->
+  -- | the shortest path, if it exists
+  Maybe [n]
+bfs ex x0 dest = reconstruct <$> go (addBack x0 Nothing (BS M.empty Seq.empty))
+  where
+    reconstruct :: (n, Map n (Maybe n)) -> [n]
+    reconstruct (goal, mp) = drop 1 . reverse $ goreco goal
+      where
+        goreco n = n : maybe [] goreco (mp M.! n)
+    go :: BFSState n -> Maybe (n, Map n (Maybe n))
+    go BS{..} = case _bsOpen of
+      Empty -> Nothing
+      n :<| ns
+        | dest n -> Just (n, _bsClosed)
+        | otherwise -> go . S.foldl' (processNeighbor n) (BS _bsClosed ns) $ ex n
+    addBack :: n -> Maybe n -> BFSState n -> BFSState n
+    addBack x up BS{..} =
+      BS
+        { _bsClosed = M.insert x up _bsClosed
+        , _bsOpen = _bsOpen :|> x
+        }
+    processNeighbor :: n -> BFSState n -> n -> BFSState n
+    processNeighbor curr bs0@BS{..} neighb
+      | neighb `M.member` _bsClosed = bs0
+      | otherwise = addBack neighb (Just curr) bs0
+
+type Point = V2 Int
+
+cardinalNeighbsSet :: Point -> Set Point
+cardinalNeighbsSet p = S.fromDistinctAscList . map (p +) $
+    [ V2 (-1) 0 , V2 0 (-1) , V2 0 1 , V2 1 0 ]
+
+solveMaze :: Set Point -> Maybe Int
+solveMaze walls = length <$> bfs step 0 (== 70)
+  where
+    step p = S.filter (all (inRange (0, 70))) $ cardinalNeighbsSet p `S.difference` walls
+```
+
+Now if you have a list of points `[Point]`, for part 1 you just solve the maze
+after taking the first 1024 of them:
+
+```haskell
+part1 :: [Point] -> Maybe Int
+part1 = solveMaze . S.fromList . take 1024
+```
+
+For part 2, you can search for the first success, or you can do a binary
+search.
+
+```haskell
+-- | Find the lowest value where the predicate is satisfied within the
+-- given bounds.
+binaryMinSearch :: (Int -> Bool) -> Int -> Int -> Maybe Int
+binaryMinSearch p = go
+  where
+    go !x !y
+      | x == mid || y == mid = Just (x + 1)
+      | p mid = go x mid
+      | otherwise = go mid y
+      where
+        mid = ((y - x) `div` 2) + x
+```
+
+```haskell
+part2 :: [Point] -> Maybe Int
+part2 pts = do
+    j <- binaryMinSearch (isNothing . solveMaze . (!! wallList)) 0 (length pts)
+    pure $ pts !! (j - 1)
+  where
+    wallList = scanl (flip S.insert) S.empty pts
+```
+
+You should probably use a container type with better indexing than a list,
+though.

From 6a6730046932e397feaf366d497b1c44dd4ce204 Mon Sep 17 00:00:00 2001
From: justin <justin@jle.im>
Date: Sun, 29 Dec 2024 15:10:44 -0800
Subject: [PATCH 12/43] write as a hylo but it's slower

---
 2024/AOC2024/Day19.hs     | 108 +++++++++++++++++++++++++++++++++-----
 reflections/2024/day19.md |   1 +
 2 files changed, 95 insertions(+), 14 deletions(-)
 create mode 100644 reflections/2024/day19.md

diff --git a/2024/AOC2024/Day19.hs b/2024/AOC2024/Day19.hs
index 95eadd3..30091ac 100644
--- a/2024/AOC2024/Day19.hs
+++ b/2024/AOC2024/Day19.hs
@@ -6,23 +6,35 @@
 -- Portability : non-portable
 --
 -- Day 19.  See "AOC.Solver" for the types used in this module!
-module AOC2024.Day19 (
-  day19a,
-  day19b,
-)
+module AOC2024.Day19
 where
 
+-- (
+-- day19a,
+-- day19b,
+-- )
+
 import AOC.Common.Parser (pAlphaNumWord, parseMaybe')
 import AOC.Solver (type (:~>) (..))
 import Control.DeepSeq (NFData)
+import Control.Monad
 import Control.Monad (guard)
+import Control.Monad.Free
+import Data.Bifunctor
 import Data.Finite (Finite)
+import Data.Foldable
 import Data.Foldable (fold)
-import Data.Functor.Foldable (Corecursive (ana), Recursive (cata))
+import Data.Functor.Foldable hiding (fold)
 import Data.Functor.Foldable.TH (MakeBaseFunctor (makeBaseFunctor))
+import Data.List.NonEmpty (NonEmpty (..))
+import qualified Data.List.NonEmpty as NE
+import Data.Map (Map)
 import qualified Data.Map as M
+import Data.Map.NonEmpty (NEMap)
+import qualified Data.Map.NonEmpty as NEM
 import Data.Maybe (mapMaybe)
-import Data.Semigroup (Sum (getSum))
+import Data.Semigroup
+import Data.These
 import qualified Data.Vector.Sized as SV
 import GHC.Generics (Generic)
 import GHC.TypeNats (KnownNat)
@@ -49,24 +61,92 @@ bindTrie t f = flip cata t \case
     Just x -> case f x of
       CT here' there' -> CT here' (SV.zipWith (<>) ctThereF there')
 
+fromMap :: KnownNat n => Map [Finite n] a -> NTrie n a
+fromMap = ana \mp ->
+  let (here, there) = flip M.foldMapWithKey mp \case
+        [] -> \x -> (Just (First x), mempty)
+        k : ks -> \x -> (mempty, SV.generate \i -> [(ks, x)] <$ guard (i == k))
+   in CTF (getFirst <$> here) (fmap M.fromList <$> there)
+
+fromMapForever ::
+  forall n a. (KnownNat n, Semigroup a) => NEMap (NonEmpty (Finite n)) a -> NTrie n a
+fromMapForever mp0 = ana (fromMapCoalg mp0) (That mp0)
+
+fromMapCoalg ::
+  forall n a.
+  (KnownNat n, Semigroup a) =>
+  NEMap (NonEmpty (Finite n)) a ->
+  These a (NEMap (NonEmpty (Finite n)) a) ->
+  NTrieF n a (These a (NEMap (NonEmpty (Finite n)) a))
+fromMapCoalg mp0 = \case
+  This x -> CTF (Just x) $ fmap separateMap <$> initialSplit x
+  That ks -> CTF Nothing $ fmap separateMap <$> splitTrie ks
+  These x ks ->
+    CTF (Just x) $
+      fmap separateMap <$> SV.zipWith combineMaybe (initialSplit x) (splitTrie ks)
+  where
+    initialSplit :: a -> SV.Vector n (Maybe (NEMap [Finite n] a))
+    initialSplit x = fmap (x <$) <$> splitTrie mp0
+    splitTrie :: NEMap (NonEmpty (Finite n)) a -> SV.Vector n (Maybe (NEMap [Finite n] a))
+    splitTrie mp = SV.generate \i ->
+      NEM.nonEmptyMap $
+        M.fromListWith
+          (<>)
+          [ (ks, x)
+          | (k :| ks, x) <- toList $ NEM.toList mp
+          , k == i
+          ]
+    combineMaybe Nothing Nothing = Nothing
+    combineMaybe (Just x) Nothing = Just x
+    combineMaybe Nothing (Just y) = Just y
+    combineMaybe (Just x) (Just y) = Just $ NEM.unionWith (<>) x y
+
+separateMap :: NEMap [Finite n] a -> These a (NEMap (NonEmpty (Finite n)) a)
+separateMap = first getFirst . NEM.foldMapWithKey go
+  where
+    go = \case
+      [] -> This . First
+      k : ks -> That . NEM.singleton (k :| ks)
+
+trieFromList :: KnownNat n => [([Finite n], a)] -> NTrie n a
+trieFromList = ana \mp ->
+  let (here, there) = flip foldMap mp \case
+        ([], x) -> (Just (First x), mempty)
+        (k : ks, x) -> (mempty, SV.generate \i -> [(ks, x)] <$ guard (i == k))
+   in CTF (getFirst <$> here) there
+
+-- trieFromListForever :: KnownNat n => [([Finite n], a)] -> NTrie n a
+-- trieFromListForever mp0 = flip ana mp0 \mp ->
+--   let (here, there) = flip foldMap mp \case
+--         ([], x) -> (Just (First x), SV.replicate (Just (first _ <$> mp0)))
+--         (k : ks, x) -> (mempty, SV.generate \i -> [(ks, x)] <$ guard (i == k))
+--    in CTF (getFirst <$> here) there
+
 singletonTrie :: KnownNat n => [Finite n] -> a -> NTrie n a
 singletonTrie str x = flip ana str \case
   [] -> CTF (Just x) (SV.replicate Nothing)
   c : cs -> CTF Nothing (SV.generate \i -> cs <$ guard (i == c))
 
 lookupTrie :: [Finite n] -> NTrie n a -> Maybe a
-lookupTrie str t = cata go t str
-  where
-    go CTF{..} = \case
-      [] -> ctHereF
-      c : cs -> ($ cs) =<< ctThereF `SV.index` c
+lookupTrie str t = cata lookupAlg t str
+
+lookupAlg :: NTrieF n a ([Finite n] -> Maybe a) -> [Finite n] -> Maybe a
+lookupAlg CTF{..} = \case
+  [] -> ctHereF
+  c : cs -> ($ cs) =<< ctThereF `SV.index` c
+
+foreverTrie' :: (KnownNat n, Semigroup w) => NonEmpty (NonEmpty (Finite n)) -> w -> NTrie n w
+foreverTrie' strs x = fromMapForever $ NEM.fromList ((,x) <$> strs)
 
 foreverTrie :: (KnownNat n, Semigroup w) => [[Finite n]] -> w -> NTrie n w
 foreverTrie strs x = infiniTrie
   where
-    tr = foldMap (`singletonTrie` x) strs
+    tr = trieFromList $ (,x) <$> strs
     infiniTrie = singletonTrie [] x <> (tr `bindTrie` const infiniTrie)
 
+buildable :: (KnownNat n, Semigroup a) => NEMap (NonEmpty (Finite n)) a -> [Finite n] -> Maybe a
+buildable mp0 = hylo lookupAlg (fromMapCoalg mp0) (That mp0)
+
 day19 :: Semigroup w => w -> ([w] -> Int) -> ([String], [String]) :~> Int
 day19 x agg =
   MkSol
@@ -79,9 +159,9 @@ day19 x agg =
           pure (ws, ls)
     , sShow = show
     , sSolve = \(ws, ls) -> do
-        ws' <- traverse toFinites ws
+        ws' <- NE.nonEmpty =<< traverse (NE.nonEmpty <=< toFinites) ws
         ls' <- traverse toFinites ls
-        pure $ agg $ mapMaybe (`lookupTrie` (foreverTrie @5) ws' x) ls'
+        pure $ agg $ mapMaybe (`lookupTrie` (foreverTrie' @5) ws' x) ls'
     }
   where
     toFinites = traverse $ flip M.lookup (M.fromList $ zip "wubrg" [0 ..])
diff --git a/reflections/2024/day19.md b/reflections/2024/day19.md
new file mode 100644
index 0000000..5e94ca3
--- /dev/null
+++ b/reflections/2024/day19.md
@@ -0,0 +1 @@
+This one can be solved in a fun way using an infinite n-trie.

From 09445ba8d51a12b10876b215ebb3b572e3205191 Mon Sep 17 00:00:00 2001
From: justin <justin@jle.im>
Date: Sun, 29 Dec 2024 15:26:50 -0800
Subject: [PATCH 13/43] get rid of maybe

---
 2024/AOC2024/Day19.hs | 106 +++++++++++++++++++++---------------------
 1 file changed, 52 insertions(+), 54 deletions(-)

diff --git a/2024/AOC2024/Day19.hs b/2024/AOC2024/Day19.hs
index 30091ac..f5ad32f 100644
--- a/2024/AOC2024/Day19.hs
+++ b/2024/AOC2024/Day19.hs
@@ -41,7 +41,7 @@ import GHC.TypeNats (KnownNat)
 import qualified Text.Megaparsec as P
 import qualified Text.Megaparsec.Char as P
 
-data NTrie n a = CT {ctHere :: Maybe a, ctThere :: SV.Vector n (Maybe (NTrie n a))}
+data NTrie n a = CT {ctHere :: Maybe a, ctThere :: SV.Vector n (NTrie n a)}
   deriving stock (Show, Functor, Traversable, Foldable, Generic)
 
 deriving anyclass instance NFData a => NFData (NTrie n a)
@@ -52,7 +52,7 @@ instance Semigroup a => Semigroup (NTrie n a) where
   CT h1 t1 <> CT h2 t2 = CT (h1 <> h2) (SV.zipWith (<>) t1 t2)
 
 instance (KnownNat n, Semigroup a) => Monoid (NTrie n a) where
-  mempty = CT Nothing (SV.replicate Nothing)
+  mempty = CT Nothing (SV.replicate mempty)
 
 bindTrie :: Semigroup b => NTrie n a -> (a -> NTrie n b) -> NTrie n b
 bindTrie t f = flip cata t \case
@@ -61,58 +61,55 @@ bindTrie t f = flip cata t \case
     Just x -> case f x of
       CT here' there' -> CT here' (SV.zipWith (<>) ctThereF there')
 
-fromMap :: KnownNat n => Map [Finite n] a -> NTrie n a
-fromMap = ana \mp ->
-  let (here, there) = flip M.foldMapWithKey mp \case
-        [] -> \x -> (Just (First x), mempty)
-        k : ks -> \x -> (mempty, SV.generate \i -> [(ks, x)] <$ guard (i == k))
-   in CTF (getFirst <$> here) (fmap M.fromList <$> there)
+-- fromMap :: KnownNat n => Map [Finite n] a -> NTrie n a
+-- fromMap = ana \mp ->
+--   let (here, there) = flip M.foldMapWithKey mp \case
+--         [] -> \x -> (Just (First x), mempty)
+--         k : ks -> \x -> (mempty, SV.generate \i -> [(ks, x)] <$ guard (i == k))
+--    in CTF (getFirst <$> here) (fmap M.fromList <$> there)
 
 fromMapForever ::
-  forall n a. (KnownNat n, Semigroup a) => NEMap (NonEmpty (Finite n)) a -> NTrie n a
-fromMapForever mp0 = ana (fromMapCoalg mp0) (That mp0)
+  forall n a. (KnownNat n, Semigroup a) => Map (NonEmpty (Finite n)) a -> NTrie n a
+fromMapForever mp0 = ana (fromMapCoalg mp0) (Nothing, mp0)
 
 fromMapCoalg ::
   forall n a.
   (KnownNat n, Semigroup a) =>
-  NEMap (NonEmpty (Finite n)) a ->
-  These a (NEMap (NonEmpty (Finite n)) a) ->
-  NTrieF n a (These a (NEMap (NonEmpty (Finite n)) a))
-fromMapCoalg mp0 = \case
-  This x -> CTF (Just x) $ fmap separateMap <$> initialSplit x
-  That ks -> CTF Nothing $ fmap separateMap <$> splitTrie ks
-  These x ks ->
-    CTF (Just x) $
-      fmap separateMap <$> SV.zipWith combineMaybe (initialSplit x) (splitTrie ks)
+  Map (NonEmpty (Finite n)) a ->
+  (Maybe a, Map (NonEmpty (Finite n)) a) ->
+  NTrieF n a (Maybe a, Map (NonEmpty (Finite n)) a)
+fromMapCoalg mp0 = \(x, ks) ->
+  -- This x -> CTF (Just x) $ separateMap <$> initialSplit x
+  -- That ks -> CTF Nothing $ separateMap <$> splitTrie ks
+  -- These x ks ->
+  CTF x $
+    separateMap <$> case x of
+      Just y -> SV.zipWith (M.unionWith (<>)) (initialSplit y) (splitTrie ks)
+      Nothing -> splitTrie ks
   where
-    initialSplit :: a -> SV.Vector n (Maybe (NEMap [Finite n] a))
-    initialSplit x = fmap (x <$) <$> splitTrie mp0
-    splitTrie :: NEMap (NonEmpty (Finite n)) a -> SV.Vector n (Maybe (NEMap [Finite n] a))
+    initialSplit :: a -> SV.Vector n (Map [Finite n] a)
+    initialSplit x = (x <$) <$> splitTrie mp0
+    splitTrie :: Map (NonEmpty (Finite n)) a -> SV.Vector n (Map [Finite n] a)
     splitTrie mp = SV.generate \i ->
-      NEM.nonEmptyMap $
-        M.fromListWith
-          (<>)
-          [ (ks, x)
-          | (k :| ks, x) <- toList $ NEM.toList mp
-          , k == i
-          ]
-    combineMaybe Nothing Nothing = Nothing
-    combineMaybe (Just x) Nothing = Just x
-    combineMaybe Nothing (Just y) = Just y
-    combineMaybe (Just x) (Just y) = Just $ NEM.unionWith (<>) x y
-
-separateMap :: NEMap [Finite n] a -> These a (NEMap (NonEmpty (Finite n)) a)
-separateMap = first getFirst . NEM.foldMapWithKey go
+      M.fromListWith
+        (<>)
+        [ (ks, x)
+        | (k :| ks, x) <- toList $ M.toList mp
+        , k == i
+        ]
+
+separateMap :: Map [Finite n] a -> (Maybe a, Map (NonEmpty (Finite n)) a)
+separateMap = first (fmap getFirst) . M.foldMapWithKey go
   where
     go = \case
-      [] -> This . First
-      k : ks -> That . NEM.singleton (k :| ks)
+      [] -> \x -> (Just (First x), mempty)
+      k : ks -> \x -> (mempty, M.singleton (k :| ks) x)
 
 trieFromList :: KnownNat n => [([Finite n], a)] -> NTrie n a
 trieFromList = ana \mp ->
   let (here, there) = flip foldMap mp \case
         ([], x) -> (Just (First x), mempty)
-        (k : ks, x) -> (mempty, SV.generate \i -> [(ks, x)] <$ guard (i == k))
+        (k : ks, x) -> (mempty, SV.generate \i -> [(ks, x) | i == k])
    in CTF (getFirst <$> here) there
 
 -- trieFromListForever :: KnownNat n => [([Finite n], a)] -> NTrie n a
@@ -122,10 +119,11 @@ trieFromList = ana \mp ->
 --         (k : ks, x) -> (mempty, SV.generate \i -> [(ks, x)] <$ guard (i == k))
 --    in CTF (getFirst <$> here) there
 
-singletonTrie :: KnownNat n => [Finite n] -> a -> NTrie n a
-singletonTrie str x = flip ana str \case
-  [] -> CTF (Just x) (SV.replicate Nothing)
-  c : cs -> CTF Nothing (SV.generate \i -> cs <$ guard (i == c))
+-- singletonTrie :: KnownNat n => [Finite n] -> a -> NTrie n a
+-- singletonTrie str x = flip ana str \case
+--   [] -> CTF (Just x) (SV.replicate undefined)
+--   c : cs -> CTF Nothing (SV.generate \i -> _)
+--   -- c : cs -> CTF Nothing (SV.generate \i -> [ cs | i == c])
 
 lookupTrie :: [Finite n] -> NTrie n a -> Maybe a
 lookupTrie str t = cata lookupAlg t str
@@ -133,19 +131,19 @@ lookupTrie str t = cata lookupAlg t str
 lookupAlg :: NTrieF n a ([Finite n] -> Maybe a) -> [Finite n] -> Maybe a
 lookupAlg CTF{..} = \case
   [] -> ctHereF
-  c : cs -> ($ cs) =<< ctThereF `SV.index` c
+  c : cs -> (ctThereF `SV.index` c) cs
 
-foreverTrie' :: (KnownNat n, Semigroup w) => NonEmpty (NonEmpty (Finite n)) -> w -> NTrie n w
-foreverTrie' strs x = fromMapForever $ NEM.fromList ((,x) <$> strs)
+foreverTrie' :: (KnownNat n, Semigroup w) => [NonEmpty (Finite n)] -> w -> NTrie n w
+foreverTrie' strs x = fromMapForever $ M.fromList ((,x) <$> strs)
 
-foreverTrie :: (KnownNat n, Semigroup w) => [[Finite n]] -> w -> NTrie n w
-foreverTrie strs x = infiniTrie
-  where
-    tr = trieFromList $ (,x) <$> strs
-    infiniTrie = singletonTrie [] x <> (tr `bindTrie` const infiniTrie)
+-- foreverTrie :: (KnownNat n, Semigroup w) => [[Finite n]] -> w -> NTrie n w
+-- foreverTrie strs x = infiniTrie
+--   where
+--     tr = trieFromList $ (,x) <$> strs
+--     infiniTrie = singletonTrie [] x <> (tr `bindTrie` const infiniTrie)
 
-buildable :: (KnownNat n, Semigroup a) => NEMap (NonEmpty (Finite n)) a -> [Finite n] -> Maybe a
-buildable mp0 = hylo lookupAlg (fromMapCoalg mp0) (That mp0)
+buildable :: (KnownNat n, Semigroup a) => Map (NonEmpty (Finite n)) a -> [Finite n] -> Maybe a
+buildable mp0 = hylo lookupAlg (fromMapCoalg mp0) (Nothing, mp0)
 
 day19 :: Semigroup w => w -> ([w] -> Int) -> ([String], [String]) :~> Int
 day19 x agg =
@@ -159,7 +157,7 @@ day19 x agg =
           pure (ws, ls)
     , sShow = show
     , sSolve = \(ws, ls) -> do
-        ws' <- NE.nonEmpty =<< traverse (NE.nonEmpty <=< toFinites) ws
+        ws' <- traverse (NE.nonEmpty <=< toFinites) ws
         ls' <- traverse toFinites ls
         pure $ agg $ mapMaybe (`lookupTrie` (foreverTrie' @5) ws' x) ls'
     }

From 7b3b8023f3b8273aa4bef4a482560fd429f49ba2 Mon Sep 17 00:00:00 2001
From: justin <justin@jle.im>
Date: Sun, 29 Dec 2024 16:34:08 -0800
Subject: [PATCH 14/43] doing things directly instead of joining and it still
 isn't too great

---
 2024/AOC2024/Day19.hs | 34 ++++++++++++++++++++--------------
 1 file changed, 20 insertions(+), 14 deletions(-)

diff --git a/2024/AOC2024/Day19.hs b/2024/AOC2024/Day19.hs
index f5ad32f..fe3b471 100644
--- a/2024/AOC2024/Day19.hs
+++ b/2024/AOC2024/Day19.hs
@@ -31,6 +31,8 @@ import qualified Data.List.NonEmpty as NE
 import Data.Map (Map)
 import qualified Data.Map as M
 import Data.Map.NonEmpty (NEMap)
+import qualified Data.Set as S
+import Data.Set (Set)
 import qualified Data.Map.NonEmpty as NEM
 import Data.Maybe (mapMaybe)
 import Data.Semigroup
@@ -69,13 +71,13 @@ bindTrie t f = flip cata t \case
 --    in CTF (getFirst <$> here) (fmap M.fromList <$> there)
 
 fromMapForever ::
-  forall n a. (KnownNat n, Semigroup a) => Map (NonEmpty (Finite n)) a -> NTrie n a
-fromMapForever mp0 = ana (fromMapCoalg mp0) (Nothing, mp0)
+  forall n a. (KnownNat n, Semigroup a) => a -> Set (NonEmpty (Finite n)) -> NTrie n a
+fromMapForever x0 mp0 = ana (fromMapCoalg mp0) (Nothing, M.fromSet (const x0) mp0)
 
 fromMapCoalg ::
   forall n a.
   (KnownNat n, Semigroup a) =>
-  Map (NonEmpty (Finite n)) a ->
+  Set (NonEmpty (Finite n)) ->
   (Maybe a, Map (NonEmpty (Finite n)) a) ->
   NTrieF n a (Maybe a, Map (NonEmpty (Finite n)) a)
 fromMapCoalg mp0 = \(x, ks) ->
@@ -84,26 +86,30 @@ fromMapCoalg mp0 = \(x, ks) ->
   -- These x ks ->
   CTF x $
     separateMap <$> case x of
-      Just y -> SV.zipWith (M.unionWith (<>)) (initialSplit y) (splitTrie ks)
+      Just y -> SV.zipWith (M.unionWith (<>)) (M.fromSet (const y) <$> initialSplit) (splitTrie ks)
       Nothing -> splitTrie ks
   where
-    initialSplit :: a -> SV.Vector n (Map [Finite n] a)
-    initialSplit x = (x <$) <$> splitTrie mp0
+    initialSplit :: SV.Vector n (Set [Finite n])
+    initialSplit = SV.generate \i ->
+      S.fromDistinctAscList
+        [ ks
+        | k :| ks <- toList mp0
+        , k == i
+        ]
     splitTrie :: Map (NonEmpty (Finite n)) a -> SV.Vector n (Map [Finite n] a)
     splitTrie mp = SV.generate \i ->
-      M.fromListWith
-        (<>)
+      M.fromDistinctAscList
         [ (ks, x)
-        | (k :| ks, x) <- toList $ M.toList mp
+        | (k :| ks, x) <- M.toList mp
         , k == i
         ]
 
 separateMap :: Map [Finite n] a -> (Maybe a, Map (NonEmpty (Finite n)) a)
-separateMap = first (fmap getFirst) . M.foldMapWithKey go
+separateMap = bimap (fmap getFirst) (M.fromDistinctAscList . ($ [])) . M.foldMapWithKey go
   where
     go = \case
       [] -> \x -> (Just (First x), mempty)
-      k : ks -> \x -> (mempty, M.singleton (k :| ks) x)
+      k : ks -> \x -> (mempty, ((k :| ks, x):))
 
 trieFromList :: KnownNat n => [([Finite n], a)] -> NTrie n a
 trieFromList = ana \mp ->
@@ -134,7 +140,7 @@ lookupAlg CTF{..} = \case
   c : cs -> (ctThereF `SV.index` c) cs
 
 foreverTrie' :: (KnownNat n, Semigroup w) => [NonEmpty (Finite n)] -> w -> NTrie n w
-foreverTrie' strs x = fromMapForever $ M.fromList ((,x) <$> strs)
+foreverTrie' strs x = fromMapForever x (S.fromList strs)
 
 -- foreverTrie :: (KnownNat n, Semigroup w) => [[Finite n]] -> w -> NTrie n w
 -- foreverTrie strs x = infiniTrie
@@ -142,8 +148,8 @@ foreverTrie' strs x = fromMapForever $ M.fromList ((,x) <$> strs)
 --     tr = trieFromList $ (,x) <$> strs
 --     infiniTrie = singletonTrie [] x <> (tr `bindTrie` const infiniTrie)
 
-buildable :: (KnownNat n, Semigroup a) => Map (NonEmpty (Finite n)) a -> [Finite n] -> Maybe a
-buildable mp0 = hylo lookupAlg (fromMapCoalg mp0) (Nothing, mp0)
+buildable :: (KnownNat n, Semigroup a) => a -> Set (NonEmpty (Finite n)) -> [Finite n] -> Maybe a
+buildable x0 mp0 = hylo lookupAlg (fromMapCoalg mp0) (Nothing, M.fromSet (const x0) mp0)
 
 day19 :: Semigroup w => w -> ([w] -> Int) -> ([String], [String]) :~> Int
 day19 x agg =

From 910de4b9bb12b49383667ec472a9d7aa50ceeed5 Mon Sep 17 00:00:00 2001
From: justin <justin@jle.im>
Date: Sun, 29 Dec 2024 16:52:01 -0800
Subject: [PATCH 15/43] huh it's not too bad, runtime wise

---
 2024/AOC2024/Day19.hs | 124 ++++++++----------------------------------
 1 file changed, 24 insertions(+), 100 deletions(-)

diff --git a/2024/AOC2024/Day19.hs b/2024/AOC2024/Day19.hs
index fe3b471..4f61133 100644
--- a/2024/AOC2024/Day19.hs
+++ b/2024/AOC2024/Day19.hs
@@ -6,37 +6,25 @@
 -- Portability : non-portable
 --
 -- Day 19.  See "AOC.Solver" for the types used in this module!
-module AOC2024.Day19
+module AOC2024.Day19 (
+  day19a,
+  day19b,
+)
 where
 
--- (
--- day19a,
--- day19b,
--- )
-
 import AOC.Common.Parser (pAlphaNumWord, parseMaybe')
 import AOC.Solver (type (:~>) (..))
 import Control.DeepSeq (NFData)
-import Control.Monad
-import Control.Monad (guard)
-import Control.Monad.Free
-import Data.Bifunctor
 import Data.Finite (Finite)
-import Data.Foldable
-import Data.Foldable (fold)
+import Data.Foldable (fold, toList)
 import Data.Functor.Foldable hiding (fold)
 import Data.Functor.Foldable.TH (MakeBaseFunctor (makeBaseFunctor))
-import Data.List.NonEmpty (NonEmpty (..))
-import qualified Data.List.NonEmpty as NE
 import Data.Map (Map)
 import qualified Data.Map as M
-import Data.Map.NonEmpty (NEMap)
-import qualified Data.Set as S
-import Data.Set (Set)
-import qualified Data.Map.NonEmpty as NEM
 import Data.Maybe (mapMaybe)
 import Data.Semigroup
-import Data.These
+import Data.Set (Set)
+import qualified Data.Set as S
 import qualified Data.Vector.Sized as SV
 import GHC.Generics (Generic)
 import GHC.TypeNats (KnownNat)
@@ -50,106 +38,41 @@ deriving anyclass instance NFData a => NFData (NTrie n a)
 
 makeBaseFunctor ''NTrie
 
-instance Semigroup a => Semigroup (NTrie n a) where
-  CT h1 t1 <> CT h2 t2 = CT (h1 <> h2) (SV.zipWith (<>) t1 t2)
-
-instance (KnownNat n, Semigroup a) => Monoid (NTrie n a) where
-  mempty = CT Nothing (SV.replicate mempty)
-
-bindTrie :: Semigroup b => NTrie n a -> (a -> NTrie n b) -> NTrie n b
-bindTrie t f = flip cata t \case
-  CTF{..} -> case ctHereF of
-    Nothing -> CT Nothing ctThereF
-    Just x -> case f x of
-      CT here' there' -> CT here' (SV.zipWith (<>) ctThereF there')
-
--- fromMap :: KnownNat n => Map [Finite n] a -> NTrie n a
--- fromMap = ana \mp ->
---   let (here, there) = flip M.foldMapWithKey mp \case
---         [] -> \x -> (Just (First x), mempty)
---         k : ks -> \x -> (mempty, SV.generate \i -> [(ks, x)] <$ guard (i == k))
---    in CTF (getFirst <$> here) (fmap M.fromList <$> there)
-
-fromMapForever ::
-  forall n a. (KnownNat n, Semigroup a) => a -> Set (NonEmpty (Finite n)) -> NTrie n a
-fromMapForever x0 mp0 = ana (fromMapCoalg mp0) (Nothing, M.fromSet (const x0) mp0)
-
 fromMapCoalg ::
   forall n a.
   (KnownNat n, Semigroup a) =>
-  Set (NonEmpty (Finite n)) ->
-  (Maybe a, Map (NonEmpty (Finite n)) a) ->
-  NTrieF n a (Maybe a, Map (NonEmpty (Finite n)) a)
-fromMapCoalg mp0 = \(x, ks) ->
-  -- This x -> CTF (Just x) $ separateMap <$> initialSplit x
-  -- That ks -> CTF Nothing $ separateMap <$> splitTrie ks
-  -- These x ks ->
-  CTF x $
-    separateMap <$> case x of
-      Just y -> SV.zipWith (M.unionWith (<>)) (M.fromSet (const y) <$> initialSplit) (splitTrie ks)
-      Nothing -> splitTrie ks
+  Set [Finite n] ->
+  Map [Finite n] a ->
+  NTrieF n a (Map [Finite n] a)
+fromMapCoalg mp0 = \ks ->
+  let x = M.lookup [] ks
+      reAdd = case x of
+        Nothing -> id
+        Just y -> SV.zipWith (M.unionWith (<>)) (M.fromSet (const y) <$> initialSplit)
+   in CTF x $ reAdd (splitTrie ks)
   where
     initialSplit :: SV.Vector n (Set [Finite n])
     initialSplit = SV.generate \i ->
       S.fromDistinctAscList
         [ ks
-        | k :| ks <- toList mp0
+        | k : ks <- toList mp0
         , k == i
         ]
-    splitTrie :: Map (NonEmpty (Finite n)) a -> SV.Vector n (Map [Finite n] a)
+    splitTrie :: Map [Finite n] a -> SV.Vector n (Map [Finite n] a)
     splitTrie mp = SV.generate \i ->
       M.fromDistinctAscList
         [ (ks, x)
-        | (k :| ks, x) <- M.toList mp
+        | (k : ks, x) <- M.toList mp
         , k == i
         ]
 
-separateMap :: Map [Finite n] a -> (Maybe a, Map (NonEmpty (Finite n)) a)
-separateMap = bimap (fmap getFirst) (M.fromDistinctAscList . ($ [])) . M.foldMapWithKey go
-  where
-    go = \case
-      [] -> \x -> (Just (First x), mempty)
-      k : ks -> \x -> (mempty, ((k :| ks, x):))
-
-trieFromList :: KnownNat n => [([Finite n], a)] -> NTrie n a
-trieFromList = ana \mp ->
-  let (here, there) = flip foldMap mp \case
-        ([], x) -> (Just (First x), mempty)
-        (k : ks, x) -> (mempty, SV.generate \i -> [(ks, x) | i == k])
-   in CTF (getFirst <$> here) there
-
--- trieFromListForever :: KnownNat n => [([Finite n], a)] -> NTrie n a
--- trieFromListForever mp0 = flip ana mp0 \mp ->
---   let (here, there) = flip foldMap mp \case
---         ([], x) -> (Just (First x), SV.replicate (Just (first _ <$> mp0)))
---         (k : ks, x) -> (mempty, SV.generate \i -> [(ks, x)] <$ guard (i == k))
---    in CTF (getFirst <$> here) there
-
--- singletonTrie :: KnownNat n => [Finite n] -> a -> NTrie n a
--- singletonTrie str x = flip ana str \case
---   [] -> CTF (Just x) (SV.replicate undefined)
---   c : cs -> CTF Nothing (SV.generate \i -> _)
---   -- c : cs -> CTF Nothing (SV.generate \i -> [ cs | i == c])
-
-lookupTrie :: [Finite n] -> NTrie n a -> Maybe a
-lookupTrie str t = cata lookupAlg t str
-
 lookupAlg :: NTrieF n a ([Finite n] -> Maybe a) -> [Finite n] -> Maybe a
 lookupAlg CTF{..} = \case
   [] -> ctHereF
   c : cs -> (ctThereF `SV.index` c) cs
 
-foreverTrie' :: (KnownNat n, Semigroup w) => [NonEmpty (Finite n)] -> w -> NTrie n w
-foreverTrie' strs x = fromMapForever x (S.fromList strs)
-
--- foreverTrie :: (KnownNat n, Semigroup w) => [[Finite n]] -> w -> NTrie n w
--- foreverTrie strs x = infiniTrie
---   where
---     tr = trieFromList $ (,x) <$> strs
---     infiniTrie = singletonTrie [] x <> (tr `bindTrie` const infiniTrie)
-
-buildable :: (KnownNat n, Semigroup a) => a -> Set (NonEmpty (Finite n)) -> [Finite n] -> Maybe a
-buildable x0 mp0 = hylo lookupAlg (fromMapCoalg mp0) (Nothing, M.fromSet (const x0) mp0)
+buildable :: (KnownNat n, Semigroup a) => a -> Set [Finite n] -> [Finite n] -> Maybe a
+buildable x0 mp0 = hylo lookupAlg (fromMapCoalg mp0) (M.fromSet (const x0) mp0)
 
 day19 :: Semigroup w => w -> ([w] -> Int) -> ([String], [String]) :~> Int
 day19 x agg =
@@ -163,11 +86,12 @@ day19 x agg =
           pure (ws, ls)
     , sShow = show
     , sSolve = \(ws, ls) -> do
-        ws' <- traverse (NE.nonEmpty <=< toFinites) ws
+        ws' <- traverse toFinites ws
         ls' <- traverse toFinites ls
-        pure $ agg $ mapMaybe (`lookupTrie` (foreverTrie' @5) ws' x) ls'
+        pure $ agg $ mapMaybe (buildable x (S.fromList ws')) ls'
     }
   where
+    toFinites :: String -> Maybe [Finite 5]
     toFinites = traverse $ flip M.lookup (M.fromList $ zip "wubrg" [0 ..])
 
 day19a :: ([String], [String]) :~> Int

From 3f0b77c9cb1fdeef6717184af2379834732945db Mon Sep 17 00:00:00 2001
From: justin <justin@jle.im>
Date: Sun, 29 Dec 2024 17:08:31 -0800
Subject: [PATCH 16/43] more hylo oprtimize

---
 2024/AOC2024/Day19.hs | 72 +++++++++++++++++++++----------------------
 1 file changed, 35 insertions(+), 37 deletions(-)

diff --git a/2024/AOC2024/Day19.hs b/2024/AOC2024/Day19.hs
index 4f61133..8d6e3e4 100644
--- a/2024/AOC2024/Day19.hs
+++ b/2024/AOC2024/Day19.hs
@@ -13,65 +13,67 @@ module AOC2024.Day19 (
 where
 
 import AOC.Common.Parser (pAlphaNumWord, parseMaybe')
-import AOC.Solver (type (:~>) (..))
+import AOC.Solver (noFail, type (:~>) (..))
 import Control.DeepSeq (NFData)
-import Data.Finite (Finite)
+import Data.Char
 import Data.Foldable (fold, toList)
 import Data.Functor.Foldable hiding (fold)
 import Data.Functor.Foldable.TH (MakeBaseFunctor (makeBaseFunctor))
+import Data.IntMap (IntMap)
+import qualified Data.IntMap as IM
 import Data.Map (Map)
 import qualified Data.Map as M
 import Data.Maybe (mapMaybe)
 import Data.Semigroup
 import Data.Set (Set)
 import qualified Data.Set as S
-import qualified Data.Vector.Sized as SV
 import GHC.Generics (Generic)
-import GHC.TypeNats (KnownNat)
 import qualified Text.Megaparsec as P
 import qualified Text.Megaparsec.Char as P
 
-data NTrie n a = CT {ctHere :: Maybe a, ctThere :: SV.Vector n (NTrie n a)}
+data CharTrie a = CT {ctHere :: Maybe a, ctThere :: IntMap (CharTrie a)}
   deriving stock (Show, Functor, Traversable, Foldable, Generic)
 
-deriving anyclass instance NFData a => NFData (NTrie n a)
+deriving anyclass instance NFData a => NFData (CharTrie a)
 
-makeBaseFunctor ''NTrie
+makeBaseFunctor ''CharTrie
 
 fromMapCoalg ::
-  forall n a.
-  (KnownNat n, Semigroup a) =>
-  Set [Finite n] ->
-  Map [Finite n] a ->
-  NTrieF n a (Map [Finite n] a)
+  forall a.
+  (Semigroup a) =>
+  Set [Int] ->
+  Map [Int] a ->
+  CharTrieF a (Map [Int] a)
 fromMapCoalg mp0 = \ks ->
   let x = M.lookup [] ks
       reAdd = case x of
         Nothing -> id
-        Just y -> SV.zipWith (M.unionWith (<>)) (M.fromSet (const y) <$> initialSplit)
+        Just y -> IM.unionWith (M.unionWith (<>)) (M.fromSet (const y) <$> initialSplit)
    in CTF x $ reAdd (splitTrie ks)
   where
-    initialSplit :: SV.Vector n (Set [Finite n])
-    initialSplit = SV.generate \i ->
-      S.fromDistinctAscList
-        [ ks
-        | k : ks <- toList mp0
-        , k == i
-        ]
-    splitTrie :: Map [Finite n] a -> SV.Vector n (Map [Finite n] a)
-    splitTrie mp = SV.generate \i ->
-      M.fromDistinctAscList
-        [ (ks, x)
-        | (k : ks, x) <- M.toList mp
-        , k == i
-        ]
+    initialSplit :: IntMap (Set [Int])
+    initialSplit =
+      S.fromDistinctDescList . ($ [])
+        <$> IM.fromAscListWith
+          (<>)
+          [ (k, (ks :))
+          | k : ks <- toList mp0
+          ]
+    splitTrie :: Map [Int] a -> IntMap (Map [Int] a)
+    splitTrie mp =
+      M.fromDistinctDescList . ($ [])
+        <$> IM.fromAscListWith
+          (.)
+          [ (k, ((ks, x) :))
+          | (k : ks, x) <- M.toList mp
+          ]
 
-lookupAlg :: NTrieF n a ([Finite n] -> Maybe a) -> [Finite n] -> Maybe a
+lookupAlg :: CharTrieF a ([Int] -> Maybe a) -> [Int] -> Maybe a
 lookupAlg CTF{..} = \case
   [] -> ctHereF
-  c : cs -> (ctThereF `SV.index` c) cs
+  c : cs -> ($ cs) =<< IM.lookup c ctThereF
 
-buildable :: (KnownNat n, Semigroup a) => a -> Set [Finite n] -> [Finite n] -> Maybe a
+buildable :: (Semigroup a) => a -> Set [Int] -> [Int] -> Maybe a
 buildable x0 mp0 = hylo lookupAlg (fromMapCoalg mp0) (M.fromSet (const x0) mp0)
 
 day19 :: Semigroup w => w -> ([w] -> Int) -> ([String], [String]) :~> Int
@@ -85,14 +87,10 @@ day19 x agg =
           ls <- pAlphaNumWord `P.sepBy` P.newline
           pure (ws, ls)
     , sShow = show
-    , sSolve = \(ws, ls) -> do
-        ws' <- traverse toFinites ws
-        ls' <- traverse toFinites ls
-        pure $ agg $ mapMaybe (buildable x (S.fromList ws')) ls'
+    , sSolve = noFail \(ws, ls) ->
+        agg $
+          mapMaybe (buildable x (S.fromList (map ord <$> ws)) . map ord) ls
     }
-  where
-    toFinites :: String -> Maybe [Finite 5]
-    toFinites = traverse $ flip M.lookup (M.fromList $ zip "wubrg" [0 ..])
 
 day19a :: ([String], [String]) :~> Int
 day19a = day19 () length

From c57c0d68edebc2e34979acfea57465c737a8f8b2 Mon Sep 17 00:00:00 2001
From: justin <justin@jle.im>
Date: Sun, 29 Dec 2024 17:23:48 -0800
Subject: [PATCH 17/43] day 19 reflections

---
 2024/AOC2024/Day19.hs        |  2 +-
 bench-results/2024/day19.txt | 20 ----------
 reflections/2024/day19.md    | 77 +++++++++++++++++++++++++++++++++++-
 3 files changed, 77 insertions(+), 22 deletions(-)
 delete mode 100644 bench-results/2024/day19.txt

diff --git a/2024/AOC2024/Day19.hs b/2024/AOC2024/Day19.hs
index 8d6e3e4..531511a 100644
--- a/2024/AOC2024/Day19.hs
+++ b/2024/AOC2024/Day19.hs
@@ -55,7 +55,7 @@ fromMapCoalg mp0 = \ks ->
     initialSplit =
       S.fromDistinctDescList . ($ [])
         <$> IM.fromAscListWith
-          (<>)
+          (.)
           [ (k, (ks :))
           | k : ks <- toList mp0
           ]
diff --git a/bench-results/2024/day19.txt b/bench-results/2024/day19.txt
deleted file mode 100644
index 0fb1f97..0000000
--- a/bench-results/2024/day19.txt
+++ /dev/null
@@ -1,20 +0,0 @@
->> Day 19a
-benchmarking...
-time                 283.5 ms   (280.3 ms .. 286.0 ms)
-                     1.000 R²   (0.999 R² .. 1.000 R²)
-mean                 294.9 ms   (289.7 ms .. 301.0 ms)
-std dev              7.392 ms   (4.681 ms .. 9.426 ms)
-variance introduced by outliers: 16% (moderately inflated)
-
-* parsing and formatting times excluded
-
->> Day 19b
-benchmarking...
-time                 280.6 ms   (251.4 ms .. 302.0 ms)
-                     0.997 R²   (0.980 R² .. 1.000 R²)
-mean                 284.8 ms   (277.9 ms .. 289.1 ms)
-std dev              7.324 ms   (1.051 ms .. 10.79 ms)
-variance introduced by outliers: 16% (moderately inflated)
-
-* parsing and formatting times excluded
-
diff --git a/reflections/2024/day19.md b/reflections/2024/day19.md
index 5e94ca3..081f972 100644
--- a/reflections/2024/day19.md
+++ b/reflections/2024/day19.md
@@ -1 +1,76 @@
-This one can be solved in a fun way using an infinite n-trie.
+This one can be solved using an infinite trie --- we build up an infinite trie
+of possibilities using patterns, and then look up a given design by tearing
+down that trie. Written altogether that gives us a hylomorphism! I've written
+about using tries with recursion schemes [in my
+blog](https://blog.jle.im/entry/tries-with-recursion-schemes.html), so this
+seemed like a natural extension.
+
+```haskell
+data CharTrie a = CT {ctHere :: Maybe a, ctThere :: IntMap (CharTrie a)}
+  deriving stock (Show, Functor, Traversable, Foldable)
+
+makeBaseFunctor ''CharTrie
+
+-- generates for us:
+data CharTrieF a r = CTF {ctHereF :: Maybe a, ctThereF :: Map Char r}
+  deriving stock (Show, Functor, Traversable, Foldable)
+```
+
+We can parameterize on a monoid `a` to solve both parts. For part 1, `a` is
+`()`: `Just ()` means that the design is in the trie, and `Nothing` means it is
+not.  For part 2, `a` is `Sum Int`: `Just (Sum n)` means there are `n` ways to get
+this design, and `Nothing` means the design is unreachable.
+
+First, the lookup algebra, which is standard for tries:
+
+```haskell
+lookupAlg :: CharTrieF a (String -> Maybe a) -> String -> Maybe a
+lookupAlg CTF{..} = \case
+  [] -> ctHereF
+  c : cs -> ($ cs) =<< M.lookup c ctThereF
+```
+
+If we had a `CharTrie a`, then `cata lookupAlg myTree "hello"` would look up
+`"hello"` in the trie.
+
+The buildup co-algebra is an interesting one.  We will convert a `Map String a`
+into a `CharTrie a`, _but_, every time we reach the end of the string, we
+"restart" the building from the start. So, we'll take a `Set String` as well,
+which we will trigger when we hit the end of a pattern.
+
+```haskell
+fromMapCoalg ::
+  forall a.
+  (Semigroup a) =>
+  Set String ->
+  Map String a ->
+  CharTrieF a (Map String a)
+fromMapCoalg mp0 = \ks ->
+  let x = M.lookup [] ks
+      reAdd = case x of
+        Nothing -> id
+        Just y -> M.unionWith (M.unionWith (<>)) (M.fromSet (const y) <$> initialSplit)
+   in CTF x $ reAdd (splitTrie ks)
+  where
+    initialSplit :: Map Char (Set String)
+    initialSplit = M.fromAscListWith (<>) [ (k, S.singleton ks) | k : ks <- toList mp0 ]
+    splitTrie :: Map String a -> Map Char (Map String a)
+    splitTrie mp = M.fromAscListWith (<>) [ (k, M.singleton ks x) | (k : ks, x) <- M.toList mp ]
+```
+
+And that's it! Our hylomorphism will build up the infinite trie, but _only_ the
+specific branch that we end up looking up from it. Because it's a hylomorphism,
+we never actually generate any trie structure: we basically build up only the
+branch we care about (driven by the lookup) and stop when we finish looking up
+or hit a dead end.
+
+````haskell
+buildable :: (Semigroup a) => a -> Set String -> String -> Maybe a
+buildable x mp = hylo lookupAlg (fromMapCoalg mp) (M.fromSet (const x) mp)
+
+part1 :: Set String -> [String] -> Int
+part1 pats = length . mapMaybe (buildable () pats)
+
+part2 :: Set String -> [String] -> Int
+part2 pats = getSum . foldMap (fold . buildable (Sum 1) pats)
+```

From 46ce147435170fd90a7e53c26ca59934b0940cb9 Mon Sep 17 00:00:00 2001
From: justin <justin@jle.im>
Date: Sun, 29 Dec 2024 17:26:20 -0800
Subject: [PATCH 18/43] redo day 19 bench

---
 bench-results/2024/day19.txt | 20 ++++++++++++++++++++
 1 file changed, 20 insertions(+)
 create mode 100644 bench-results/2024/day19.txt

diff --git a/bench-results/2024/day19.txt b/bench-results/2024/day19.txt
new file mode 100644
index 0000000..ca09d6c
--- /dev/null
+++ b/bench-results/2024/day19.txt
@@ -0,0 +1,20 @@
+>> Day 19a
+benchmarking...
+time                 274.5 ms   (238.8 ms .. 319.5 ms)
+                     0.990 R²   (0.965 R² .. 1.000 R²)
+mean                 291.0 ms   (280.4 ms .. 304.0 ms)
+std dev              15.07 ms   (8.887 ms .. 20.78 ms)
+variance introduced by outliers: 16% (moderately inflated)
+
+* parsing and formatting times excluded
+
+>> Day 19b
+benchmarking...
+time                 263.2 ms   (252.7 ms .. 273.1 ms)
+                     1.000 R²   (0.999 R² .. 1.000 R²)
+mean                 274.3 ms   (268.5 ms .. 285.3 ms)
+std dev              10.64 ms   (1.505 ms .. 14.39 ms)
+variance introduced by outliers: 16% (moderately inflated)
+
+* parsing and formatting times excluded
+

From 7bfa29158401bf0afc6d86bacd284841406b2eb4 Mon Sep 17 00:00:00 2001
From: justin <justin@jle.im>
Date: Sun, 29 Dec 2024 17:29:14 -0800
Subject: [PATCH 19/43] fix formatting error

---
 reflections/2024/day19.md | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/reflections/2024/day19.md b/reflections/2024/day19.md
index 081f972..6f124e7 100644
--- a/reflections/2024/day19.md
+++ b/reflections/2024/day19.md
@@ -64,7 +64,7 @@ we never actually generate any trie structure: we basically build up only the
 branch we care about (driven by the lookup) and stop when we finish looking up
 or hit a dead end.
 
-````haskell
+```haskell
 buildable :: (Semigroup a) => a -> Set String -> String -> Maybe a
 buildable x mp = hylo lookupAlg (fromMapCoalg mp) (M.fromSet (const x) mp)
 

From f845c9a281b25c2467b7641da2bbc602efe0ce52 Mon Sep 17 00:00:00 2001
From: justin <justin@jle.im>
Date: Sun, 29 Dec 2024 17:50:30 -0800
Subject: [PATCH 20/43] slight day 20 search optimization

---
 2024/AOC2024/Day20.hs | 23 +++++++++++++++++++++--
 1 file changed, 21 insertions(+), 2 deletions(-)

diff --git a/2024/AOC2024/Day20.hs b/2024/AOC2024/Day20.hs
index 352c58d..129eafa 100644
--- a/2024/AOC2024/Day20.hs
+++ b/2024/AOC2024/Day20.hs
@@ -14,7 +14,6 @@ where
 
 import AOC.Common (findKeyFor, floodFill)
 import AOC.Common.Point (Point, cardinalNeighbsSet, mannDist, mannNorm, parseAsciiMap)
-import AOC.Common.Search (bfs)
 import AOC.Solver (noFail, type (:~>) (..))
 import Data.Map (Map)
 import qualified Data.Map as M
@@ -24,6 +23,26 @@ import qualified Data.Set as S
 import Data.Traversable (mapAccumR)
 import Data.Tuple.Strict (T2 (..))
 
+racePath ::
+  -- | walls
+  Set Point ->
+  -- | start
+  Point ->
+  -- | end
+  Point ->
+  Maybe [Point]
+racePath walls start end = go Nothing start
+  where
+    go :: Maybe Point -> Point -> Maybe [Point]
+    go prev here = do
+      next <- S.lookupMin candidates
+      (here :)
+        <$> if next == end
+          then pure [end]
+          else go (Just here) next
+      where
+        candidates = maybe id S.delete prev $ cardinalNeighbsSet here `S.difference` walls
+
 findCheats ::
   -- | walls
   Set Point ->
@@ -37,7 +56,7 @@ findCheats ::
   Int ->
   Maybe Int
 findCheats walls start end len thresh = do
-  path <- (start :) <$> bfs ((`S.difference` walls) . cardinalNeighbsSet) start (== end)
+  path <- racePath walls start end
   pure . sum . snd $ mapAccumR go (T2 0 M.empty) path
   where
     go :: T2 Int (Map Point Int) -> Point -> (T2 Int (Map Point Int), Int)

From 37e586e20084ed6f5ad03cc3c7d07a3dad92b15d Mon Sep 17 00:00:00 2001
From: justin <justin@jle.im>
Date: Sun, 29 Dec 2024 18:03:26 -0800
Subject: [PATCH 21/43] day 20 reflections

---
 bench-results/2024/day20.txt | 18 ++++++------
 reflections/2024/day18.md    | 12 +-------
 reflections/2024/day20.md    | 56 ++++++++++++++++++++++++++++++++++++
 3 files changed, 66 insertions(+), 20 deletions(-)
 create mode 100644 reflections/2024/day20.md

diff --git a/bench-results/2024/day20.txt b/bench-results/2024/day20.txt
index 68bced2..d324c82 100644
--- a/bench-results/2024/day20.txt
+++ b/bench-results/2024/day20.txt
@@ -1,19 +1,19 @@
 >> Day 20a
 benchmarking...
-time                 40.47 ms   (38.84 ms .. 41.22 ms)
-                     0.995 R²   (0.979 R² .. 1.000 R²)
-mean                 41.80 ms   (41.15 ms .. 43.37 ms)
-std dev              1.933 ms   (950.7 μs .. 3.288 ms)
-variance introduced by outliers: 12% (moderately inflated)
+time                 34.12 ms   (32.70 ms .. 35.54 ms)
+                     0.994 R²   (0.983 R² .. 1.000 R²)
+mean                 34.98 ms   (34.32 ms .. 36.48 ms)
+std dev              1.880 ms   (715.8 μs .. 3.355 ms)
+variance introduced by outliers: 18% (moderately inflated)
 
 * parsing and formatting times excluded
 
 >> Day 20b
 benchmarking...
-time                 393.2 ms   (380.9 ms .. 402.4 ms)
-                     1.000 R²   (1.000 R² .. 1.000 R²)
-mean                 393.2 ms   (391.2 ms .. 396.0 ms)
-std dev              2.621 ms   (1.132 ms .. 3.309 ms)
+time                 405.5 ms   (393.5 ms .. 431.8 ms)
+                     0.999 R²   (0.999 R² .. 1.000 R²)
+mean                 393.5 ms   (390.1 ms .. 399.7 ms)
+std dev              5.956 ms   (1.238 ms .. 7.831 ms)
 variance introduced by outliers: 19% (moderately inflated)
 
 * parsing and formatting times excluded
diff --git a/reflections/2024/day18.md b/reflections/2024/day18.md
index 5c7b494..c77f35f 100644
--- a/reflections/2024/day18.md
+++ b/reflections/2024/day18.md
@@ -16,17 +16,7 @@ data BFSState n = BS
   -- ^ queue
   }
 
-bfs ::
-  forall n.
-  Ord n =>
-  -- | neighborhood
-  (n -> Set n) ->
-  -- | start
-  n ->
-  -- | target
-  (n -> Bool) ->
-  -- | the shortest path, if it exists
-  Maybe [n]
+bfs :: forall n. Ord n => (n -> Set n) -> n -> (n -> Bool) -> Maybe [n]
 bfs ex x0 dest = reconstruct <$> go (addBack x0 Nothing (BS M.empty Seq.empty))
   where
     reconstruct :: (n, Map n (Maybe n)) -> [n]
diff --git a/reflections/2024/day20.md b/reflections/2024/day20.md
new file mode 100644
index 0000000..b0231b9
--- /dev/null
+++ b/reflections/2024/day20.md
@@ -0,0 +1,56 @@
+Because this is a "race track" with no branching, finding the path to the end
+can be a straightforward DFS with no-takebacksies:
+
+```haskell
+cardinalNeighbsSet :: Point -> Set Point
+cardinalNeighbsSet p = S.fromDistinctAscList . map (p +) $
+    [ V2 (-1) 0 , V2 0 (-1) , V2 0 1 , V2 1 0 ]
+
+racePath :: Set Point -> Point -> Point -> Maybe [Point]
+racePath walls start end = go Nothing start
+  where
+    go :: Maybe Point -> Point -> Maybe [Point]
+    go prev here = do
+      next <- S.lookupMin candidates
+      (here :)
+        <$> if next == end
+          then pure [end]
+          else go (Just here) next
+      where
+        candidates = maybe id S.delete prev $ cardinalNeighbsSet here `S.difference` walls
+```
+
+Since our racepath is one continuous line, a cheat therefore involves
+"pinching" the line so that you skip straight over one segment of the line. So,
+we can basically iterate over each point in the line and imagine if we jumped
+ahead N spaces. If the time saved by jumping N spaces minus the real-world
+distance is greater than the threshold, it's a legitimate cheat.
+
+```haskell
+mannDist :: Point -> Point
+mannDist x y = sum (abs (x - y))
+
+mannNorm :: Point -> Int
+mannNorm = mannDist 0
+
+findCheats :: Set Point -> Point -> Point -> Int -> Int -> Maybe Int
+findCheats walls start end len thresh = do
+  path <- racePath walls start end
+  pure . sum . snd $ mapAccumR go (0, M.empty) path
+  where
+    go :: (Int, Map Point Int) -> Point -> ((Int, Map Point Int), Int)
+    go (i, xs) x =
+      ( (i + 1, M.insert x i xs)
+      , M.size $
+          M.filterWithKey (\y j -> i - j - mannDist x y >= thresh) $
+            xs `M.restrictKeys` S.mapMonotonic (+ x) diamond
+      )
+    diamond = floodFill (S.filter ((<= len) . mannNorm) . cardinalNeighbsSet) (S.singleton 0)
+```
+
+Our `mapAccumR` here iterates from the end of the list with the index (`i`) and
+a map `xs` of points to the index where that point is on the racetrack. At each
+point, we output the number of cheats: it's the `xs` filtered by points legally
+jumpable within a given distance, and then further filtered where the jump in
+index `i - j` minus the time to travel `mannDist x y` is greater than the
+threshold for counting the cheat.  In the end we sum all of those outputs.

From 6191a6e289a757fd6ca38768a7cac548da928abf Mon Sep 17 00:00:00 2001
From: justin <justin@jle.im>
Date: Sun, 29 Dec 2024 18:10:45 -0800
Subject: [PATCH 22/43] simplify day 20 reflection

---
 reflections/2024/day20.md | 4 +---
 1 file changed, 1 insertion(+), 3 deletions(-)

diff --git a/reflections/2024/day20.md b/reflections/2024/day20.md
index b0231b9..7a92b02 100644
--- a/reflections/2024/day20.md
+++ b/reflections/2024/day20.md
@@ -42,10 +42,8 @@ findCheats walls start end len thresh = do
     go (i, xs) x =
       ( (i + 1, M.insert x i xs)
       , M.size $
-          M.filterWithKey (\y j -> i - j - mannDist x y >= thresh) $
-            xs `M.restrictKeys` S.mapMonotonic (+ x) diamond
+          M.filterWithKey (\y j -> let d = mannDist x y in d <= len && i - j - d >= thresh) xs
       )
-    diamond = floodFill (S.filter ((<= len) . mannNorm) . cardinalNeighbsSet) (S.singleton 0)
 ```
 
 Our `mapAccumR` here iterates from the end of the list with the index (`i`) and

From 44b3e82b54641c643b1181d74d129e3998cdd11f Mon Sep 17 00:00:00 2001
From: justin <justin@jle.im>
Date: Sun, 29 Dec 2024 19:05:34 -0800
Subject: [PATCH 23/43] note that the cata/ana is faster

---
 reflections/2024/day19.md | 10 ++++++++--
 1 file changed, 8 insertions(+), 2 deletions(-)

diff --git a/reflections/2024/day19.md b/reflections/2024/day19.md
index 6f124e7..99f3696 100644
--- a/reflections/2024/day19.md
+++ b/reflections/2024/day19.md
@@ -35,8 +35,9 @@ If we had a `CharTrie a`, then `cata lookupAlg myTree "hello"` would look up
 
 The buildup co-algebra is an interesting one.  We will convert a `Map String a`
 into a `CharTrie a`, _but_, every time we reach the end of the string, we
-"restart" the building from the start. So, we'll take a `Set String` as well,
-which we will trigger when we hit the end of a pattern.
+"restart" the building from the start, while merging all of the resulting
+leaves monoidally. So, we'll take a `Set String` as well, which we will trigger
+when we hit the end of a pattern.
 
 ```haskell
 fromMapCoalg ::
@@ -74,3 +75,8 @@ part1 pats = length . mapMaybe (buildable () pats)
 part2 :: Set String -> [String] -> Int
 part2 pats = getSum . foldMap (fold . buildable (Sum 1) pats)
 ```
+
+However, this may be a case where the hylomorphism is slower than doing the
+unfold and fold separately, because the full `CharTrie` is actually going to be
+re-used multiple times for each design. However, there's something a little
+more satisfying about just re-building and tearing down every time.

From d2c8e5732e17444b85ad1e5875a31d8dd29b88af Mon Sep 17 00:00:00 2001
From: justin <justin@jle.im>
Date: Tue, 31 Dec 2024 23:33:25 -0800
Subject: [PATCH 24/43] clean up day 13

---
 2024/AOC2024/Day13.hs        | 557 +++--------------------------------
 bench-results/2024/day13.txt |  17 +-
 common/AOC/Common.hs         |  84 +++++-
 3 files changed, 123 insertions(+), 535 deletions(-)

diff --git a/2024/AOC2024/Day13.hs b/2024/AOC2024/Day13.hs
index 8da37e2..2048fb4 100644
--- a/2024/AOC2024/Day13.hs
+++ b/2024/AOC2024/Day13.hs
@@ -1,6 +1,3 @@
-{-# OPTIONS_GHC -Wno-unused-imports #-}
-{-# OPTIONS_GHC -Wno-unused-top-binds #-}
-
 -- |
 -- Module      : AOC2024.Day13
 -- License     : BSD3
@@ -9,538 +6,58 @@
 -- Portability : non-portable
 --
 -- Day 13.  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.Day13 (
   day13a,
   day13b,
-  getPrize'',
-  testPrize'',
-  solveBezout,
-  restrictRange,
-  runBezout,
-  iterateRange,
-  applyRanges,
-  bezout2D,
-  positive,
-  toLattice,
 )
 where
 
-import AOC.Prelude
-import qualified Data.Graph.Inductive as G
-import qualified Data.IntMap as IM
-import qualified Data.IntMap.NonEmpty as IM
-import qualified Data.IntSet as IS
-import qualified Data.IntSet.NonEmpty as NEIS
-import qualified Data.Interval as IV
-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 Data.Proxy
-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 AOC.Common (inv22Int)
+import AOC.Common.Parser (pDecimal, parseMaybe', sequenceSepBy)
+import AOC.Common.Point (Point, V2 (..))
+import AOC.Solver (noFail, type (:~>) (..))
+import Control.Monad (guard)
+import Data.Bifunctor (second)
+import Data.Distributive (Distributive (distribute))
+import Data.Maybe (mapMaybe)
+import Linear ((!*))
 import qualified Text.Megaparsec as P
 import qualified Text.Megaparsec.Char as P
-import qualified Text.Megaparsec.Char.Lexer as PP
-import qualified Data.Foldable1 as F1
-
--- Button A: X+53, Y+35
--- Button B: X+11, Y+23
--- Prize: X=13386, Y=18840
-
--- a x + b y = z
--- a x = z - b y
-
-getPrize :: V2 (V2 Int) -> V2 Int -> Maybe Int
-getPrize (V2 a b) g =
-  minimumMay
-    [ na * 3 + nb
-    | na <- [0 .. 100]
-    , nb <- [0 .. 100]
-    , na *^ a + nb *^ b == g
-    ]
-
--- Button A: X+69, Y+48
--- Button B: X+41, Y+88
--- Prize: X=5242, Y=3944
 
-day13a :: _ :~> _
+-- |
+--
+-- [xa xb] [a] = [xc]
+-- [ya yb] [b] = [yc]
+getPrize :: V2 Point -> Point -> Maybe Int
+getPrize coeff targ = do
+  (det, invCoeff) <- inv22Int (distribute coeff)
+  let resDet = invCoeff !* targ
+      residues = (`mod` det) <$> resDet
+      V2 a b = (`div` det) <$> resDet
+  guard $ all (== 0) residues
+  pure $ 3 * a + b
+
+day13a :: [(V2 Point, Point)] :~> Int
 day13a =
   MkSol
-    { sParse = parseMaybe' $ flip P.sepBy "\n\n" $ do
-        "Button A: X+"
-        x <- pDecimal
-        ", Y+"
-        y <- pDecimal
-        P.newline
-        "Button B: X+"
-        x' <- pDecimal
-        ", Y+"
-        y' <- pDecimal
-        P.newline
-        "Prize: X="
-        x'' <- pDecimal
-        ", Y="
-        y'' <- pDecimal
-        pure (V3 (V2 x y) (V2 x' y') (V2 x'' y''))
+    { sParse = parseMaybe' $ flip P.sepBy "\n\n" do
+        coeff <- traverse parseButton $ V2 "A" "B"
+        "Prize: "
+        p <- sequenceSepBy ((*>) <$> V2 "X=" "Y=" <*> V2 pDecimal pDecimal) ", "
+        pure (coeff, p)
     , sShow = show
     , sSolve =
-        noFail $
-          sum . mapMaybe getPrize''
+        noFail $ sum . mapMaybe (uncurry getPrize)
     }
-
--- a x + b y = z
--- a x = z - b y
--- a = (z - by) / x
-
--- a = z/x - b*y/x
-
-getPrize' :: V2 (V2 Int) -> V2 Int -> Maybe Int
-getPrize' (V2 a@(V2 ax _) b) g =
-  listToMaybe
-    [ na * 3 + nb
-    | nb <- takeWhile zby [0 ..]
-    , let V2 zbx' _ = g - nb *^ b
-    , zbx' `mod` ax == 0
-    , let na = zbx' `div` ax
-    , na *^ a + nb *^ b == g
-    ]
-  where
-    zby nb = all (>= 0) $ g - nb *^ b
-
--- kx - xFactor * r' > 0
--- kx > xFactor * r'
--- r' < kx / xFactor, xFactor > 0
--- r' > kx / xFactor, xFactor < 0
-
--- ky + yFactor * r' > 0
--- yFactor * r' > -ky
--- r' > - kx / yFactor, yFactor > 0
--- r' < - kx / yFactor, yFactor < 0
-
---
-data BezoutSol a = BS
-  { bsA :: V2 a
-  -- ^ m r + b
-  , bsB :: V2 a
-  -- ^ m r + b
-  }
-  deriving stock (Show)
-
--- deriving stock instance Show (f Point) => Show (BezoutSol f)
-
--- solvePositiveBezout :: V3 Int -> Maybe (BezoutSol Identity)
--- solvePositiveBezout (V3 x y z) = do
---   guard $ dm == 0
---   (kx, ky) <- firstJust checkK [0 ..]
---   let xFactor = y `div` d
---       yFactor = x `div` d
---       rxRange
---         | xFactor > 0 = IV.NegInf IV.<=..<= IV.Finite (kx `div` xFactor)
---         | otherwise = IV.Finite (kx `div` xFactor) IV.<=..<= IV.PosInf
---       ryRange
---         | yFactor > 0 = IV.Finite (-(ky `div` yFactor)) IV.<=..<= IV.PosInf
---         | otherwise = IV.NegInf IV.<=..<= IV.Finite (-(ky `div` yFactor))
---       rRange = rxRange `IV.intersection` ryRange
---   (IV.Finite maxR, IV.Closed) <- pure $ IV.lowerBound' rRange
---   (IV.Finite minR, IV.Closed) <- pure $ IV.upperBound' rRange
---   pure
---     BS
---       { bsRange = Identity $ V2 minR maxR
---       , bsA = V2 (-xFactor) kx
---       , bsB = V2 yFactor ky
---       }
---   where
---     d = gcd x y
---     (dd, dm) = z `divMod` d
---     checkK i = [(dd * i, dd * zd) | zm == 0]
---       where
---         (zd, zm) = (d - i * x) `divMod` y
-
--- kx - xFactor * r' > min
--- xFactor * r' < kx - min
--- r' < (kx - min) / xFactor , xFactor > 0
--- r' < (kx - min) / xFactor , xFactor < 0
-
--- ky + yFactor * r' > min
--- yFactor * r' > min - ky
--- r' > (min - ky) / yFactor, yFactor > 0
--- r' < (min - kx) / yFactor, yFactor < 0
-
--- | Range of R such that a/b are within the given interval
-restrictRange :: (Fractional a, Ord a, Integral b) => IV.Interval a -> IV.Interval a -> BezoutSol b -> IV.Interval a
-restrictRange ivA ivB BS{..} = IV.intersections [minA, maxA, minB, maxB]
-  where
-    V2 ma ba = fromIntegral <$> bsA
-    V2 mb bb = fromIntegral <$> bsB
-    (minBoA, minClA) = IV.lowerBound' ivA
-    (maxBoA, maxClA) = IV.upperBound' ivA
-    (minBoB, minClB) = IV.lowerBound' ivB
-    (maxBoB, maxClB) = IV.upperBound' ivB
-    minALim = minBoA <&> \mbo -> (mbo - ba) / ma
-    maxALim = maxBoA <&> \mbo -> (mbo - ba) / ma
-    minBLim = minBoB <&> \mbo -> (mbo - bb) / mb
-    maxBLim = maxBoB <&> \mbo -> (mbo - bb) / mb
-    minA = mkIval (ma > 0) (minALim, minClA)
-    maxA = mkIval (ma < 0) (maxALim, maxClA)
-    minB = mkIval (mb > 0) (minBLim, minClB)
-    maxB = mkIval (mb < 0) (maxBLim, maxClB)
-    mkIval isGT l
-      | isGT = IV.interval (mkNeg `first` l) (IV.PosInf, IV.Open)
-      | otherwise = IV.interval (IV.NegInf, IV.Open) (mkPos `first` l)
-    mkNeg = \case
-      IV.PosInf -> IV.NegInf
-      c -> c
-    mkPos = \case
-      IV.NegInf -> IV.PosInf
-      c -> c
-
--- | Given range of R, give ranges of a/b
-applyRanges :: Integral b => IV.Interval Double -> BezoutSol b -> V2 (IV.Interval Double)
-applyRanges ivR BS{..} =
-  V2 (IV.mapMonotonic (+ ba) $ scaleInterval ma ivR) (IV.mapMonotonic (+ bb) $ scaleInterval mb ivR)
-  where
-    V2 ma ba = fromIntegral <$> bsA
-    V2 mb bb = fromIntegral <$> bsB
-
-scaleInterval :: (Ord a, Num a) => a -> IV.Interval a -> IV.Interval a
-scaleInterval x iv
-  | x > 0 = IV.interval ((* x) <$> minBo, minCl) ((* x) <$> maxBo, maxCl)
-  | otherwise = IV.interval ((* x) <$> flipInf maxBo, maxCl) ((* x) <$> flipInf minBo, minCl)
-  where
-    (minBo, minCl) = IV.lowerBound' iv
-    (maxBo, maxCl) = IV.upperBound' iv
-    flipInf = \case
-      IV.NegInf -> IV.PosInf
-      IV.PosInf -> IV.PosInf
-      IV.Finite q -> IV.Finite q
-
-solveBezout :: Integral a => V3 a -> Maybe (BezoutSol a)
-solveBezout (V3 x y z) = do
-  guard $ dm == 0
-  (kx, ky) <- firstJust checkK [0 ..]
-  let xFactor = y `div` d
-      yFactor = x `div` d
-  pure
-    BS
-      { bsA = V2 (-xFactor) kx
-      , bsB = V2 yFactor ky
-      }
   where
-    d = gcd x y
-    (dd, dm) = z `divMod` d
-    checkK i = [(dd * i, dd * zd) | zm == 0]
-      where
-        (zd, zm) = (d - i * x) `divMod` y
-
-runBezout :: Num a => BezoutSol a -> a  -> V2 a
-runBezout BS{..} r = (\(V2 m b) -> m * r + b) <$> V2 bsA bsB
-
--- okay now we want to find r, r' where
--- m r + b == m' r' + b'
--- m r - m' r' = b' - b
--- lol this becomes a second bezout
-getPrize'' :: V3 (V2 Integer) -> Maybe Integer
-getPrize'' = fmap (F1.maximum . fmap score) . bezout2D (V2 positive positive)
- where
-   score (V2 a b) = 3 * a + b
-  -- V2 cA cB <- solveBezout v
-  -- pure $ cA * 3 + cB
-
-  -- -- bsx: rx -> valid ax/bx/gx solutions
-  -- -- bsy: ry -> valid ay/by/gy solutions
-  -- V2 bsx bsy <- traverse solveBezout . sequenceA $ V3 a b g
-  -- -- rXs: rx giving valid solutions
-  -- -- rYs: ry giving valid solutions
-  -- let rXs = restrictRange positive positive bsx
-  --     rYs = restrictRange positive positive bsy
-  -- guard $ not (IV.null rXs)
-  -- guard $ not (IV.null rYs)
-  -- -- how to generate r's that match for both rx and ry for A
-  -- bsa <-
-  --   solveBezout $
-  --     V3 (view _1 $ bsA bsx) (negate $ view _1 $ bsA bsy) (view _2 (bsA bsy) - view _2 (bsA bsx))
-  -- -- -- how to generate r's that match for both rx and ry for B
-  -- -- bsb <- solveBezout $ V3 (view _1 $ bsB bsx) (negate $ view _1 $ bsB bsy) (view _2 (bsB bsy) - view _2 (bsB bsx))
-  -- rAs <- iterateRange $ restrictRange rXs rYs bsa
-  -- -- rBs <- iterateRange $ restrictRange rXs rYs bsb
-  -- listToMaybe
-  --   [ xa * 3 + xb
-  --   | V2 raA raB <- runBezout bsa <$> rAs
-  --   , -- , V2 rbA rbB <- runBezout bsb <$> rBs
-  --   let x = runBezout bsx raA
-  --       y = runBezout bsy raB
-  --       V2 xa xb = x
-  --       -- , x == y
-  --   ]
-
-positive :: (Num a, Ord a) => IV.Interval a
-positive = 0 IV.<=..< IV.PosInf
-
--- | Nothing: infinite
-widthMaybe :: (Num a, Ord a) => IV.Interval a -> Maybe a
-widthMaybe iv = do
-  IV.Finite _ <- pure $ IV.lowerBound iv
-  IV.Finite _ <- pure $ IV.upperBound iv
-  pure $ IV.width iv
-
--- safeFloor :: a -> Int
--- safeFloor = floor . (+ 1e-10)
-
--- safeCeil :: a -> Int
--- safeCeil = ceiling . subtract 1e-10
-
-toLattice :: RealFrac a => IV.Interval a -> IV.Interval Int
-toLattice iv = IV.interval (ceiling <$> mn, IV.Closed) (floor <$> mx, IV.Closed)
-  where
-    mn = IV.lowerBound iv
-    mx = IV.upperBound iv
-
-singleLattice :: RealFrac a => IV.Interval a -> Maybe Int
-singleLattice iv = do
-  IV.Finite mn <- pure $ ceiling <$> IV.lowerBound iv
-  IV.Finite mx <- pure $ floor <$> IV.upperBound iv
-  guard $ mn == mx
-  pure mn
+    parseButton c = do
+      "Button " *> c *> ": "
+      b <- sequenceSepBy ((*>) <$> V2 "X+" "Y+" <*> V2 pDecimal pDecimal) ", "
+      P.newline
+      pure b
 
-latticeWidth :: RealFrac a => IV.Interval a -> Maybe Int
-latticeWidth iv
-   | IV.null iv = Just 0
-   | otherwise = do
-      IV.Finite mn <- pure $ ceiling <$> IV.lowerBound iv
-      IV.Finite mx <- pure $ floor <$> IV.upperBound iv
-      pure $ mx - mn + 1
-
-bezout2D :: V2 (IV.Interval Rational) -> V3 (V2 Integer) -> Maybe (NonEmpty (V2 Integer))
-bezout2D (V2 ivA ivB) (V3 a b g) = do
-  V2 bsx bsy <- traverse solveBezout . sequenceA $ V3 a b g
-  let rXs = restrictRange ivA ivB bsx
-      rYs = restrictRange ivA ivB bsy
-  -- traceM $ show $ IV.mapMonotonic realToFrac <$> [rXs, rYs]
-  -- traceM $ "widths: " ++ show (latticeWidth <$> [rXs, rYs])
-  -- traceM $ "double widths: " ++ show (fmap realToFrac . widthMaybe <$> [rXs, rYs])
-  -- guard . not $ isNothing (latticeWidth rXs) && isNothing (latticeWidth rYs)
-  -- traceM $ "nulls: " ++ show (IV.null <$> [rXs, rYs])
-  guard . not $ isNothing (mfilter (> 0) $ latticeWidth rXs) && isNothing (mfilter (> 0) $ latticeWidth rYs)
-  -- guard . not $ IV.null rXs && IV.null rYs
-  let feasibles :: Maybe (NonEmpty (V2 Integer))
-      feasibles = do
-        wX <- fromIntegral @Int @Integer <$> latticeWidth rXs
-        wY <- fromIntegral <$> latticeWidth rYs
-        -- traceM $ show (wX, wY)
-        guard $ wX * wY < 10
-        -- traceM $ "good feasibles: " ++ show (wX, wY)
-        sequenceA <$> (V2 <$> (NE.nonEmpty =<< iterateRange rXs) <*> (NE.nonEmpty =<< iterateRange rYs))
-      runWithOption :: NonEmpty (V2 Integer) -> Maybe (NonEmpty (V2 Integer))
-      runWithOption cs = NE.nonEmpty [ resA
-                | V2 resA resB <- toList $ liftA2 runBezout (V2 bsx bsy) <$> cs
-              , resA == resB
-              ]
-  -- traceM $ "feasibles:" ++ show feasibles
-  -- traceM $ show $ realToFrac @_ @Double <$> [IV.width rXs, IV.width rYs]
-  -- traceM $ show [singleLattice rXs, singleLattice rYs]
-  -- Nothing
-  let options =
-        [ runWithOption =<< feasibles
-        , runWithOption =<< bezout2D (V2 rXs rYs) (V3
-            (V2 (view _1 $ bsA bsx) (view _1 $ bsB bsx))
-            (V2 (negate $ view _1 $ bsA bsy) (negate $ view _1 $ bsB bsy))
-            (V2 (view _2 (bsA bsy) - view _2 (bsA bsx)) (view _2 (bsB bsy) - view _2 (bsB bsx))))
-        ]
-  -- fold options
-  asum options
-  -- NE.nonEmpty [ resA
-  --               | V2 resA resB <- toList $ liftA2 runBezout (V2 bsx bsy) <$> coeffs
-  --             , resA == resB
-
-  --             ]
-    -- pullSingle <|> bezout2D (V2 rXs rYs) (V3
-    --       (V2 (view _1 $ bsA bsx) (view _1 $ bsB bsx))
-    --       (V2 (negate $ view _1 $ bsA bsy) (negate $ view _1 $ bsB bsy))
-    --       (V2 (view _2 (bsA bsy) - view _2 (bsA bsx)) (view _2 (bsB bsy) - view _2 (bsB bsx))))
-  -- let V2 resA resB = runBezout <$> V2 bsx bsy <*> coeffs
-  -- guard $ resA == resB
-  -- pure resA
-
--- okay now we want to find r, r' where
--- m r + b == m' r' + b'
--- m r - m' r' = b' - b
--- lol this becomes a second bezout
-testPrize'' :: V3 (V2 Int) -> Maybe _
-testPrize'' (V3 a b g) = Nothing
-
-  ---- bsx: rx -> valid ax/bx/gx solutions
-  ---- bsy: ry -> valid ay/by/gy solutions
-  --V2 bsx bsy <- traverse solveBezout . sequenceA $ V3 a b g
-  ---- at this point we have ways to solve A ax + B bx = gx, A by + B by = gy
-  ---- but we want to know there are any (A,B) pair that would work for both.
-  ----
-  ---- A,B are of the form (ma r + ba, mb r + bb) for both. so if we want them
-  ---- to be equal, we need r where:
-  ----
-  ---- max rA + bax == may rA' + bay
-  ---- => max rA - may rA' == bay - bax
-  ---- mbx rB + bbx == mby rB' + bby
-  ---- => mbx rB - mbx rB' == bby - bbx
-  ----
-  ---- that gives us valid rA/rB's, but that space is still too huge. How do
-  ---- we link it back to the original xyz...
-  ----
-  ---- Ah okay yeah we must remember that each A and B are themselves related.
-  ---- how do we pick (A,B) now considering they work for both?
-  ----
-  ---- what can rA be? well:
-  ----
-  ---- (max rAx + bax) ax + (mbx rBx + bbx) bx = gx
-  ---- (may rAy + bay) ay + (mby rBy + bby) by = gy
-  ----
-  ---- every choice of rAx and rBx within rXs produces a valid 1st eq
-  ---- every choice of rAy and rBy within rXy produces a valid 2st eq
-  ----
-  ---- but rAx rAy cannot vary independently. we can parameterize possible
-  ---- (rAx, rAy) pairs by a variable qA. And same for (rBx rBy) by a variable
-  ---- qB. and then we want to know what ranges qA and qB can take.
-  ----
-  ---- But, even those ranges are way too big, we need some way to intercept
-  ---- them again. I guess if we plub them back in, we can get q to emerge
-  ---- from the big equation.
-  ----
-  ---- Actually wait that's wrong, they have to have the same R across (A,B),
-  ---- so that means our equations are actually:
-  ----
-  ---- (max rX + bax) ax + (mbx rX + bbx) bx = gx
-  ---- (may rY + bay) ay + (mby rY + bby) by = gy
-  ----
-  ---- and of course our A's have to be the same, which means we have:
-  ----
-  ---- max rX + bax == may rY + bay
-  ---- => max rX - may rY = bay - bax
-  ---- mbx rX + bbx == may rY + bby
-  ---- => mab rX - mab rY = bby - bbx
-  ----
-  ---- yeah this is starting to get more constrained. Okay now let's break
-  ---- this down into qA and qB... and see if that helps at all
-  ----
-  ---- max (max' qA + bax') - may (may' qA + bay') = bay - bax
-  ---- mbx (mbx' qB + bbx') - mby (mby' qB + bby') = bby - bbx
-  ----
-  ---- hey it looks like every time we go deeper, the range of values gets
-  ---- smaller. maybe there's something going on here.
-  ----
-  ---- rXs: rx giving valid solutions
-  ---- rYs: ry giving valid solutions
-  --let rXs = restrictRange positive positive bsx
-  --    rYs = restrictRange positive positive bsy
-  --guard $ not (IV.null rXs)
-  --guard $ not (IV.null rYs)
-  ---- how to generate r's that match for both rx and ry for A
-  --bsa <-
-  --  solveBezout $
-  --    V3 (view _1 $ bsA bsx) (negate $ view _1 $ bsA bsy) (view _2 (bsA bsy) - view _2 (bsA bsx))
-  ---- how to generate r's that match for both rx and ry for B
-  --bsb <-
-  --  solveBezout $
-  --    V3 (view _1 $ bsB bsx) (negate $ view _1 $ bsB bsy) (view _2 (bsB bsy) - view _2 (bsB bsx))
-  --let qAs = restrictRange rXs rYs bsa
-  --    qBs = restrictRange rXs rYs bsb
-  --traceM $
-  --  show
-  --    ( rXs
-  --    , rYs
-  --    , V3 (view _1 $ bsA bsx) (negate $ view _1 $ bsA bsy) (view _2 (bsA bsy) - view _2 (bsA bsx))
-  --    , V3 (view _1 $ bsB bsx) (negate $ view _1 $ bsB bsy) (view _2 (bsB bsy) - view _2 (bsB bsx))
-  --    )
-  --bsa' <-
-  --  solveBezout $
-  --    V3 (view _1 $ bsA bsa) (negate $ view _1 $ bsA bsb) (view _2 (bsA bsb) - view _2 (bsA bsa))
-  --bsb' <-
-  --  solveBezout $
-  --    V3 (view _1 $ bsB bsa) (negate $ view _1 $ bsB bsb) (view _2 (bsB bsb) - view _2 (bsB bsa))
-  --let qAs' = restrictRange qAs qBs bsa'
-  --    qBs' = restrictRange qAs qBs bsb'
-  --bsa'' <-
-  --  solveBezout $
-  --    V3 (view _1 $ bsA bsa') (negate $ view _1 $ bsA bsb') (view _2 (bsA bsb') - view _2 (bsA bsa'))
-  --bsb'' <-
-  --  solveBezout $
-  --    V3 (view _1 $ bsB bsa') (negate $ view _1 $ bsB bsb') (view _2 (bsB bsb') - view _2 (bsB bsa'))
-  --let qAs'' = restrictRange qAs' qBs' bsa''
-  --    qBs'' = restrictRange qAs' qBs' bsb''
-  ---- pure $ [ applyRanges rXs bsx, applyRanges rYs bsy ]
-  ---- pure $ [rXs, rYs, rAs, rBs]
-  ---- pure $ IV.mapMonotonic (round @Double @Int) <$> [rXs, rYs, rAs, rBs]
-  ---- pure $ [rXs, rYs, qAs, qBs, qAs', qBs']
-  --pure $ IV.width <$> [rXs, rYs, qAs, qBs, qAs', qBs', qAs'', qBs'']
-
--- minimumMay [ xa * 3 + xb
---      | V2 raA raB <- runBezout bsa <$> rAs
---      -- , V2 rbA rbB <- runBezout bsb <$> rBs
---      , let x = runBezout bsx raA
---            y = runBezout bsy raB
---            V2 xa xb = x
---      , x == y
---      ]
--- listToMaybe [ V2 xa xb
---      | V2 raA raB <- map (runBezout bsa) $ fold $ iterateRange rAs
---      -- , V2 rbA rbB <- runBezout bsb <$> rBs
---      , let x = runBezout bsx raA
---            y = runBezout bsy raB
---            V2 xa xb = x
---      -- , x == y
---      ]
-
--- | Nothing if range is infinite
-iterateRange :: (RealFrac a, Integral b) => IV.Interval a -> Maybe [b]
-iterateRange iv = case (IV.lowerBound' iv, IV.upperBound' iv) of
-  ((IV.Finite mn, _), (IV.Finite mx, _)) -> Just [ceiling mn .. floor mx]
-  _ -> Nothing
-
--- [ (candA *^ a + candB *^ b)
--- \| let dx = gcd ax bx
---       (dxd, dxm) = gx `divMod` dx
--- , dxm == 0
--- , (kax, kbx) <- maybeToList $ firstJust (checkK dx) [0 ..]
--- , rx <- [0 .. 10]
--- , let candA = dxd * kax - ((bx `div` dx) * rx)
---       candB = dxd * kbx + ((ax `div` dx) * rx)
---       -- nb <- takeWhile zby [0 .. ]
---       -- , let V2 zbx' _ = g - nb *^ b
---       -- , zbx' `mod` ax == 0
---       -- , let na = zbx' `div` ax
---       -- , na *^ a + nb *^ b == g
--- ]
--- where
---   checkK dx i = [(i, d) | m == 0]
---     where
---       (d, m) = (dx - i * ax) `divMod` bx
-
---   -- where
---   --   zby nb = all (>= 0) $ g - nb *^ b
-
-day13b :: _ :~> _
+day13b :: [(V2 Point, Point)] :~> Int
 day13b =
-  MkSol
-    { sParse = sParse day13a
-    , sShow = show
-    , sSolve =
-        noFail $
-          sum . mapMaybe (getPrize'' . over _z (10000000000000 +))
+  day13a
+    { sSolve = sSolve day13a . map (second (10000000000000 +))
     }
diff --git a/bench-results/2024/day13.txt b/bench-results/2024/day13.txt
index c243e8f..d00eeac 100644
--- a/bench-results/2024/day13.txt
+++ b/bench-results/2024/day13.txt
@@ -1,18 +1,19 @@
 >> Day 13a
 benchmarking...
-time                 1.887 ms   (1.881 ms .. 1.893 ms)
-                     1.000 R²   (1.000 R² .. 1.000 R²)
-mean                 1.891 ms   (1.887 ms .. 1.898 ms)
-std dev              18.44 μs   (14.30 μs .. 26.49 μs)
+time                 10.70 μs   (10.55 μs .. 10.96 μs)
+                     0.993 R²   (0.987 R² .. 0.997 R²)
+mean                 11.74 μs   (11.23 μs .. 12.34 μs)
+std dev              1.963 μs   (1.546 μs .. 2.237 μs)
+variance introduced by outliers: 95% (severely inflated)
 
 * parsing and formatting times excluded
 
 >> Day 13b
 benchmarking...
-time                 12.28 ms   (12.09 ms .. 12.54 ms)
-                     0.998 R²   (0.996 R² .. 1.000 R²)
-mean                 12.06 ms   (12.00 ms .. 12.22 ms)
-std dev              246.8 μs   (174.1 μs .. 402.2 μs)
+time                 11.78 μs   (11.76 μs .. 11.80 μs)
+                     1.000 R²   (1.000 R² .. 1.000 R²)
+mean                 11.79 μs   (11.77 μs .. 11.81 μs)
+std dev              70.24 ns   (48.18 ns .. 88.93 ns)
 
 * parsing and formatting times excluded
 
diff --git a/common/AOC/Common.hs b/common/AOC/Common.hs
index 65bc1d1..3440704 100644
--- a/common/AOC/Common.hs
+++ b/common/AOC/Common.hs
@@ -120,12 +120,6 @@ module AOC.Common (
   caeser,
   eitherItem,
   chooseEither,
-  toNatural,
-  factorial,
-  integerFactorial,
-  pascals,
-  triangles,
-  triangleNumber,
   mapMaybeSet,
   findKeyFor,
   flipMap,
@@ -139,6 +133,18 @@ module AOC.Common (
   unListDigits,
   _DigitList,
 
+  -- * Integers
+  egcd,
+  modInverse,
+  bezout,
+  inv22Int,
+  toNatural,
+  factorial,
+  integerFactorial,
+  pascals,
+  triangles,
+  triangleNumber,
+
   -- * Comonad stuff
   matchMap,
   storeMapNeighborhood,
@@ -214,7 +220,7 @@ import qualified Data.Vector.Unboxed.Mutable.Sized as UVM
 import Data.Word
 import Debug.Trace
 import GHC.TypeNats
-import Linear (Additive (..), R1 (..), R2 (..), R3 (..), R4 (..), V2 (..), V3 (..), V4 (..))
+import Linear (Additive (..), R1 (..), R2 (..), R3 (..), R4 (..), V2 (..), V3 (..), V4 (..), det22, M22)
 import qualified Numeric.Lens as L
 import Safe
 
@@ -1039,6 +1045,70 @@ factorial n = go 2 1
       | i > n = x
       | otherwise = go (i + 1) (x * i)
 
+-- | case egcd a b of
+--      (d, u, v) ->
+--          u * a + v * b = d
+--       && d == gcd(a,b)
+--
+-- from arithmoi library
+egcd :: Integral a => a -> a -> (a, a, a)
+egcd a b = (d, u, v)
+  where
+    (d, x, y) = eGCD 0 1 1 0 (abs a) (abs b)
+    u
+      | a < 0 = negate x
+      | otherwise = x
+    v
+      | b < 0 = negate y
+      | otherwise = y
+    eGCD !n1 o1 !n2 o2 r s
+      | s == 0 = (r, o1, o2)
+      | otherwise = case r `quotRem` s of
+          (q, t) -> eGCD (o1 - q * n1) n1 (o2 - q * n2) n2 s t
+{-# SPECIALIZE egcd ::
+  Int -> Int -> (Int, Int, Int)
+  , Word -> Word -> (Word, Word, Word)
+  , Integer -> Integer -> (Integer, Integer, Integer)
+  #-}
+
+-- | modInverse(a,b) is (a^-1 in Z_b, b^-1 in Z_a)
+modInverse :: Integral a => a -> a -> Maybe (a, a)
+modInverse x y = case egcd x y of
+  (1, u, v) -> Just (u, v)
+  _ -> Nothing
+
+-- | gives (V2 (V2 mx bx) (V2 my by)), where x solutions are (mx k + bx) and y
+-- solutions are (my k + by)
+bezout :: Integral a => a -> a -> a -> Maybe (V2 (V2 a))
+bezout a b c
+  | r == 0 =
+      Just $
+        V2
+          (V2 (b `div` d) (u * c'))
+          (V2 (- (a `div` d)) (v * c'))
+  | otherwise = Nothing
+  where
+    (d, u, v) = egcd a b
+    (c', r) = c `divMod` d
+{-# SPECIALIZE bezout ::
+  Int -> Int -> Int -> Maybe (V2 (V2 Int)),
+  Word -> Word -> Word -> Maybe (V2 (V2 Word)),
+  Integer -> Integer -> Integer -> Maybe (V2 (V2 Integer))
+  #-}
+
+-- | Returns det(A) and inv(A)det(A)
+inv22Int :: (Num a, Eq a) => M22 a -> Maybe (a, M22 a)
+inv22Int m@(V2 (V2 a b) (V2 c d))
+  | det == 0 = Nothing
+  | otherwise = Just (det, V2 (V2 d (-b)) (V2 (-c) a))
+  where
+    det = det22 m
+{-# SPECIALIZE inv22Int ::
+   M22 Int -> Maybe (Int, M22 Int),
+   M22 Word -> Maybe (Word, M22 Word),
+   M22 Integer -> Maybe (Integer, M22 Integer)
+  #-}
+
 integerFactorial :: Integer -> Integer
 integerFactorial n = go 2 1
   where

From ec6beeb1000912ef24d0bbb3d18a46830a3a2f79 Mon Sep 17 00:00:00 2001
From: justin <justin@jle.im>
Date: Tue, 31 Dec 2024 23:54:49 -0800
Subject: [PATCH 25/43] day 13 reflections

---
 2024/AOC2024/Day13.hs     |  3 +--
 reflections/2024/day13.md | 55 +++++++++++++++++++++++++++++++++++++++
 2 files changed, 56 insertions(+), 2 deletions(-)
 create mode 100644 reflections/2024/day13.md

diff --git a/2024/AOC2024/Day13.hs b/2024/AOC2024/Day13.hs
index 2048fb4..acd6e34 100644
--- a/2024/AOC2024/Day13.hs
+++ b/2024/AOC2024/Day13.hs
@@ -32,9 +32,8 @@ getPrize :: V2 Point -> Point -> Maybe Int
 getPrize coeff targ = do
   (det, invCoeff) <- inv22Int (distribute coeff)
   let resDet = invCoeff !* targ
-      residues = (`mod` det) <$> resDet
       V2 a b = (`div` det) <$> resDet
-  guard $ all (== 0) residues
+  guard $ all ((== 0) . (`mod` det)) resDet
   pure $ 3 * a + b
 
 day13a :: [(V2 Point, Point)] :~> Int
diff --git a/reflections/2024/day13.md b/reflections/2024/day13.md
new file mode 100644
index 0000000..af0ff61
--- /dev/null
+++ b/reflections/2024/day13.md
@@ -0,0 +1,55 @@
+This one reduces to basically solving two linear equations, but it's kind of
+fun to see what the *linear* haskell library gives us to make things more
+convenient.
+
+Basically for `xa`, `ya`, `xb`, `yb`, we want to solve the matrix equation `M p
+= c` for `p`, where `c` is our target `<x, y>`, and `M` is `[ xa xb; ya yb ]`.  We're
+going to assume that our two buttons are linearly independent (they are not
+multiples of each other).  Note that the `M` matrix is the transpose of the
+numbers as we originally parse them.
+
+Normally we can solve this as `p = M^-1 C`, where `M^-1 = [ yb -xb; -ya xa] /
+(ad - bc)`. However, we only care about integer solutions. This means that we
+can do some checks:
+
+1.  Compute `det = ad - bc` and a matrix `U = [yb -xb ; -ya xa]`, which is
+    `M^-1 * det`.
+2.  Compute `p*det = U c`
+3.  Check that `det` is not 0
+4.  Check that ``(`mod` det)`` is 0 for all items in `U c`
+5.  Our result is then the ``(`div` det)`` for all items in `U c`.
+
+*linear* has the `det22` method for the determinant of a 2x2 matrix, but it
+doesn't quite have the `M^-1 * det` function, it only has `M^-1` for
+`Fractional` instances.  So we can write our own:
+
+```haskell
+-- | Returns det(A) and inv(A)det(A)
+inv22Int :: (Num a, Eq a) => M22 a -> Maybe (a, M22 a)
+inv22Int m@(V2 (V2 a b) (V2 c d))
+  | det == 0 = Nothing
+  | otherwise = Just (det, V2 (V2 d (-b)) (V2 (-c) a))
+  where
+    det = det22 m
+
+type Point = V2 Int
+
+getPrize :: V2 Point -> Point -> Maybe Int
+getPrize coeff targ = do
+  (det, invTimesDet) <- inv22Int (transpose coeff)
+  let resTimesDet = invTimesDet !* targ
+      V2 a b = (`div` det) <$> resTimesDet
+  guard $ all ((== 0) . (`mod` det)) resTimesDet
+  pure $ 3 * a + b
+
+part1 :: [(V2 Point, Point)] -> Int
+part1 = sum . mapMaybe (uncurry getPrize)
+
+part2 :: [(V2 Point, Point)] -> Int
+part2 = part2 . map (second (10000000000000 +))
+```
+
+Here we take advantage of `transpose`, `det22`, `!*` for matrix-vector
+multiplication, the `Functor` instance of vectors for `<$>`, the `Foldable`
+instance of vectors for `all`, and the `Num` instance of vectors for numeric
+literals and `+`.

From 5a3439f3b27360e818ad824b2840c9b91266c751 Mon Sep 17 00:00:00 2001
From: justin <justin@jle.im>
Date: Wed, 1 Jan 2025 00:39:50 -0800
Subject: [PATCH 26/43] day 22 reflections and cleanup

---
 2024/AOC2024/Day22.hs        | 101 +++++++++++------------------------
 bench-results/2024/day22.txt |  19 +++----
 reflections/2024/day22.md    |  48 +++++++++++++++++
 3 files changed, 90 insertions(+), 78 deletions(-)
 create mode 100644 reflections/2024/day22.md

diff --git a/2024/AOC2024/Day22.hs b/2024/AOC2024/Day22.hs
index de0da61..feede78 100644
--- 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
index 8a4aee6..d98a350 100644
--- 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
new file mode 100644
index 0000000..a116d7e
--- /dev/null
+++ 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).

From f10cbd0eb6f53585562854e9b431326e962bcf40 Mon Sep 17 00:00:00 2001
From: justin <justin@jle.im>
Date: Wed, 1 Jan 2025 11:15:34 -0800
Subject: [PATCH 27/43] day 22 using array

---
 2024/AOC2024/Day22.hs | 45 ++++++++++++++++++++++++++++---------------
 1 file changed, 30 insertions(+), 15 deletions(-)

diff --git a/2024/AOC2024/Day22.hs b/2024/AOC2024/Day22.hs
index feede78..3b45a12 100644
--- a/2024/AOC2024/Day22.hs
+++ b/2024/AOC2024/Day22.hs
@@ -15,9 +15,11 @@ where
 import AOC.Common (strictIterate, (!!!))
 import AOC.Common.Parser (pDecimal, parseMaybe', sepByLines)
 import AOC.Solver (noFail, type (:~>) (..))
+import Control.Monad (unless)
 import Data.Bits (Bits (shift, xor, (.&.)))
-import Data.Foldable (Foldable (toList))
-import qualified Data.IntMap as IM
+import Data.Foldable (for_)
+import qualified Data.Vector.Storable as VS
+import qualified Data.Vector.Storable.Mutable as MVS
 import Safe.Foldable (maximumMay)
 
 step :: Int -> Int
@@ -41,18 +43,31 @@ day22b =
   MkSol
     { sParse = sParse day22a
     , sShow = show
-    , sSolve = maximumMay . toList . IM.unionsWith (+) . map genSeries
+    , sSolve = \xs -> do
+        let serieses = take 2000 . map (`mod` 10) . strictIterate step <$> xs
+            tots = VS.create do
+              v <- MVS.replicate maxSeq 0
+              for_ serieses \series -> do
+                seens <- MVS.replicate maxSeq False
+                for_ (chompChomp series) \(i, n) -> do
+                  seen <- MVS.exchange seens i True
+                  unless seen $
+                    MVS.modify v (+ n) i
+              pure v
+        maximumMay $ VS.toList tots
     }
   where
-    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 _ = []
+    maxSeq = encodeSeq [9, 9, 9, 9]
+
+encodeSeq :: [Int] -> Int
+encodeSeq = sum . zipWith (\i x -> x * 19 ^ (i :: Int)) [0 ..] . map (+ 9)
+
+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 _ = []

From 388ce4ca970e3b5bb9a4269582013ef7a8860c34 Mon Sep 17 00:00:00 2001
From: justin <justin@jle.im>
Date: Wed, 1 Jan 2025 11:26:43 -0800
Subject: [PATCH 28/43] dupate 22 bench and reflections

---
 bench-results/2024/day22.txt | 15 +++++++--------
 reflections/2024/day22.md    |  5 ++++-
 2 files changed, 11 insertions(+), 9 deletions(-)

diff --git a/bench-results/2024/day22.txt b/bench-results/2024/day22.txt
index d98a350..a04580d 100644
--- a/bench-results/2024/day22.txt
+++ b/bench-results/2024/day22.txt
@@ -1,19 +1,18 @@
 >> Day 22a
 benchmarking...
-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)
+time                 30.33 ms   (29.99 ms .. 30.67 ms)
+                     0.999 R²   (0.998 R² .. 1.000 R²)
+mean                 30.51 ms   (30.30 ms .. 30.90 ms)
+std dev              550.9 μs   (203.2 μs .. 935.3 μs)
 
 * parsing and formatting times excluded
 
 >> Day 22b
 benchmarking...
-time                 3.095 s    (3.060 s .. 3.129 s)
+time                 776.3 ms   (767.0 ms .. 784.6 ms)
                      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)
+mean                 780.4 ms   (778.0 ms .. 782.1 ms)
+std dev              2.663 ms   (2.009 ms .. 3.144 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
index a116d7e..cd81a4c 100644
--- a/reflections/2024/day22.md
+++ b/reflections/2024/day22.md
@@ -45,4 +45,7 @@ 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).
+optimizing to using `IntMap` on a base-19 encoding of the sequence). Switching
+to a single mutable vector doing all of the summing (and a mutable vector for
+every seed preventing double-adds) we bring it down to 800ms which still isn't
+particularly ideal.

From 450a40eceb5c40a4305259112ba77115c5a676b6 Mon Sep 17 00:00:00 2001
From: justin <justin@jle.im>
Date: Wed, 1 Jan 2025 11:50:07 -0800
Subject: [PATCH 29/43] day 16 reflections and cleanup

---
 2024/AOC2024/Day16.hs        |   5 +-
 bench-results/2024/day16.txt |  14 ++---
 reflections/2024/day16.md    | 111 +++++++++++++++++++++++++++++++++++
 3 files changed, 120 insertions(+), 10 deletions(-)
 create mode 100644 reflections/2024/day16.md

diff --git a/2024/AOC2024/Day16.hs b/2024/AOC2024/Day16.hs
index 6361dde..c3e4c5d 100644
--- a/2024/AOC2024/Day16.hs
+++ b/2024/AOC2024/Day16.hs
@@ -15,7 +15,6 @@ where
 import AOC.Common.Point (Dir (..), Point, dirPoint, parseAsciiMap)
 import AOC.Solver (noFail, type (:~>) (..))
 import Data.Bifunctor (Bifunctor (second))
-import Data.Foldable (Foldable (fold))
 import Data.Map (Map)
 import qualified Data.Map as M
 import Data.Sequence.NonEmpty (NESeq (..))
@@ -50,7 +49,7 @@ day16b =
   MkSol
     { sParse = sParse day16a
     , sShow = show
-    , sSolve = fmap (S.size . fold . snd) . solve
+    , sSolve = fmap (S.size . mconcat . snd) . solve
     }
 
 step :: Set Point -> (Point, Dir) -> Map (Point, Dir) Int
@@ -66,7 +65,7 @@ step walls (p, d) =
   where
     p' = p + dirPoint d
 
-data Path n m p = Path {pCurr :: n, pSeen :: Set m, pCost :: p}
+data Path n m p = Path {pCurr :: !n, pSeen :: !(Set m), pCost :: !p}
   deriving stock (Eq, Ord, Show)
 
 allMinimalPaths ::
diff --git a/bench-results/2024/day16.txt b/bench-results/2024/day16.txt
index 66805d4..0ed9674 100644
--- a/bench-results/2024/day16.txt
+++ b/bench-results/2024/day16.txt
@@ -1,19 +1,19 @@
 >> Day 16a
 benchmarking...
-time                 313.6 ms   (307.1 ms .. 319.8 ms)
-                     1.000 R²   (1.000 R² .. 1.000 R²)
-mean                 314.8 ms   (313.9 ms .. 316.4 ms)
-std dev              1.616 ms   (315.0 μs .. 2.207 ms)
+time                 314.6 ms   (288.1 ms .. 337.2 ms)
+                     0.998 R²   (0.995 R² .. 1.000 R²)
+mean                 322.6 ms   (315.8 ms .. 327.8 ms)
+std dev              7.420 ms   (5.508 ms .. 9.232 ms)
 variance introduced by outliers: 16% (moderately inflated)
 
 * parsing and formatting times excluded
 
 >> Day 16b
 benchmarking...
-time                 322.2 ms   (311.2 ms .. 332.4 ms)
+time                 323.8 ms   (320.3 ms .. 330.2 ms)
                      1.000 R²   (0.999 R² .. 1.000 R²)
-mean                 320.8 ms   (317.9 ms .. 324.1 ms)
-std dev              3.921 ms   (2.314 ms .. 5.846 ms)
+mean                 323.5 ms   (319.1 ms .. 326.7 ms)
+std dev              4.496 ms   (2.480 ms .. 6.795 ms)
 variance introduced by outliers: 16% (moderately inflated)
 
 * parsing and formatting times excluded
diff --git a/reflections/2024/day16.md b/reflections/2024/day16.md
new file mode 100644
index 0000000..fe4333e
--- /dev/null
+++ b/reflections/2024/day16.md
@@ -0,0 +1,111 @@
+Nothing too deep I could think of for this one other than a specialized
+dijkstra BFS, that initially acts like normal dijkstra until the first
+successful path is found: after that, it treats that as the best cost, and it
+only re-adds points back to the queue if the cost is less than the known best
+cost.
+
+```haskell
+data Path n p = Path {pCurr :: n, pSeen :: Set n, pCost :: p}
+  deriving stock (Eq, Ord, Show)
+
+allMinimalPaths ::
+  forall n p.
+  (Ord n, Ord p, Num p) =>
+  -- | neighborhood
+  (n -> Map n p) ->
+  -- | start
+  n ->
+  -- | target
+  (n -> Bool) ->
+  -- | all paths with the shortest cost
+  Maybe (p, [Set n])
+allMinimalPaths expand start targ = go0 (M.singleton start path0) (M.singleton 0 (NESeq.singleton path0))
+  where
+    path0 = Path start S.empty 0
+    go0 :: Map n (Path n p) -> Map p (NESeq (Path n p)) -> Maybe (p, [Set n])
+    go0 bests queue = do
+      ((p, Path{..} NESeq.:<|| xs), queue') <- M.minViewWithKey queue
+      let queue'' = case NESeq.nonEmptySeq xs of
+            Nothing -> queue'
+            Just xs' -> M.insert p xs' queue'
+      if targ pCurr
+        then Just (p, pSeen : go1 p bests (M.takeWhileAntitone (<= p) queue''))
+        else
+          uncurry go0 . M.foldlWithKey' (processNeighbor pCost pSeen) (bests, queue'') $ expand pCurr
+    go1 :: p -> Map n (Path n p) -> Map p (NESeq (Path n m p)) -> [Set n]
+    go1 minCost bests queue = case M.minViewWithKey queue of
+      Nothing -> []
+      Just ((p, Path{..} NESeq.:<|| xs), queue') ->
+        let queue'' = case NESeq.nonEmptySeq xs of
+              Nothing -> queue'
+              Just xs' -> M.insert p xs' queue'
+         in if targ pCurr
+              then pSeen : go1 minCost bests queue''
+              else
+                uncurry (go1 minCost)
+                  . second (M.takeWhileAntitone (<= minCost))
+                  . M.foldlWithKey' (processNeighbor pCost pSeen) (bests, queue'')
+                  $ expand pCurr
+    processNeighbor ::
+      p ->
+      Set n ->
+      (Map n (Path n p), Map p (NESeq (Path n p))) ->
+      n ->
+      p ->
+      (Map n (Path n p), Map p (NESeq (Path n p)))
+    processNeighbor cost seen (bests, queue) x newCost
+      | x `S.member` seen = (bests, queue)
+      | otherwise = case M.lookup x bests of
+          Nothing -> (M.insert x newPath bests, newQueue)
+          Just Path{..}
+            | cost + newCost <= pCost -> (M.insert x newPath bests, newQueue)
+            | otherwise -> (bests, queue)
+      where
+        newPath = Path x (S.insert x seen) (cost + newCost)
+        newQueue =
+          M.insertWith
+            (flip (<>))
+            (cost + newCost)
+            (NESeq.singleton newPath)
+            queue
+```
+
+Then we can solve part 1 and part 2 with the same search:
+
+```haskell
+type Point = V2 Int
+
+type Dir = Finite 4
+
+dirPoint :: Dir -> Point
+dirPoint = SV.index $ SV.fromTuple (V2 0 (-1), V2 1 0, V2 0 1, V2 (-1) 0)
+
+step :: Set Point -> (Point, Dir) -> Map (Point, Dir) Int
+step walls (p, d) =
+  M.fromList
+    [ ((p, d'), 1000)
+    | d' <- [d + 1, d - 1]
+    , (p + dirPoint d') `S.notMember` walls
+    ]
+    <> if p' `S.member` walls
+      then mempty
+      else M.singleton (p', d) 1
+  where
+    p' = p + dirPoint d
+
+solve :: Set Point -> Point -> Point -> Maybe (Int, [Set Point])
+solve walls start end = 
+  second (map (S.map fst)) <$> allMinimalPaths proj (step walls) (start, East) ((== end) . fst)
+
+part1 :: Set Point -> Point -> Point -> Maybe Int
+part1 walls start end = fst <$> solve walls start end
+
+part2 :: Set Point -> Point -> Point -> Maybe Int
+part2 walls start end = S.size mconcat . snd <$> solve walls start end
+```
+
+Right now we consider two nodes to be the same if they have the same position
+and the same direction, but there's a slight optimization we can do if we
+consider them to be the same if they are in the same position and on the same
+axis (going north/south vs going east/west) since it closes off paths that
+backtrack.  However in practice this isn't really a big savings (5% for me).

From a894c6c0f824d7a0bd7ba93121dd1d1fef3471fb Mon Sep 17 00:00:00 2001
From: justin <justin@jle.im>
Date: Wed, 1 Jan 2025 16:35:07 -0800
Subject: [PATCH 30/43] use fgl for day 21

---
 2024/AOC2024/Day21.hs      | 72 ++++++++++++++++++++++++--------------
 common/AOC/Common/Point.hs |  2 --
 site/default.nix           |  2 +-
 3 files changed, 47 insertions(+), 29 deletions(-)

diff --git a/2024/AOC2024/Day21.hs b/2024/AOC2024/Day21.hs
index 855937c..d7eafbd 100644
--- a/2024/AOC2024/Day21.hs
+++ b/2024/AOC2024/Day21.hs
@@ -14,15 +14,17 @@ where
 
 import AOC.Common (digitToIntSafe, (!!!))
 import AOC.Common.Point (Dir (..), Point, V2 (V2), dirPoint)
-import AOC.Common.Search (bfsActions)
 import AOC.Solver (noFail, type (:~>) (..))
+import Control.Applicative (liftA3)
 import Control.Monad (mfilter, (<=<))
 import Data.Char (intToDigit, isDigit)
 import Data.Finite (Finite, finites)
+import Data.Functor ((<&>))
+import qualified Data.Graph.Inductive as G
 import Data.Map (Map)
 import qualified Data.Map as M
-import Data.Maybe (fromJust, mapMaybe, maybeToList)
-import qualified Data.Set as S
+import Data.Maybe (mapMaybe, maybeToList)
+import Data.Tuple (swap)
 
 type NumPad = Maybe (Finite 10)
 type DirPad = Maybe Dir
@@ -82,32 +84,50 @@ instance Pushable (Finite 10) where
   allPushable = finites
   pushMap = pushMapFromLayout numPad
 
+buttonGraph ::
+  forall a.
+  Pushable a =>
+  (G.Gr (Either (Maybe a, DirPad, DirPad) (Maybe a)) DirPad, Map (Maybe a) Int, Map (Maybe a) Int)
+buttonGraph = (G.mkGraph (swap <$> M.toList nodes) edges, startMap, endMap)
+  where
+    nodes :: Map (Either (Maybe a, DirPad, DirPad) (Maybe a)) Int
+    nodes =
+      M.fromList . flip zip [0 ..] $
+        (Left <$> liftA3 (,,) allPushable' allPushable' allPushable')
+          ++ (Right <$> allPushable')
+    startMap =
+      M.fromList
+        [ (n, i)
+        | (Left (n, Nothing, Nothing), i) <- M.toList nodes
+        ]
+    endMap =
+      M.fromList
+        [ (n, i)
+        | (Right n, i) <- M.toList nodes
+        ]
+    edges :: [(Int, Int, DirPad)]
+    edges = do
+      (Left (b, d, e), node) <- M.toList nodes
+      push <- reverse allPushable'
+      (e', eout) <- maybeToList $ applyPush push e
+      (d', dout) <- case eout of
+        Nothing -> pure (d, Nothing)
+        Just push' -> maybeToList $ applyPush push' d
+      (b', bout) <- case dout of
+        Nothing -> pure (b, Nothing)
+        Just push' -> maybeToList $ applyPush push' b
+      pure case bout of
+        Nothing -> (node, nodes M.! Left (b', d', e'), push)
+        Just o -> (node, nodes M.! Right o, push)
+
 -- | Best way to get from button to button. penalize motion two bots down
 dirPath :: forall a. Pushable a => Map (Maybe a) (Map (Maybe a) [DirPad])
-dirPath = M.fromSet ((`M.fromSet` S.fromList allPushable') . go) (S.fromList allPushable')
+dirPath =
+  st <&> \i ->
+    en <&> \j ->
+      runPath Nothing . runPath Nothing . drop 1 . map snd . G.unLPath $ G.lesp i j bg
   where
-    go :: Maybe a -> Maybe a -> [DirPad]
-    go x y =
-      runPath Nothing . runPath Nothing . fromJust $
-        bfsActions step (Left (x, Nothing, Nothing)) (== Right y)
-      where
-        step (Left (b, d, e)) =
-          reverse
-            [ ( push
-              , case bout of
-                  Nothing -> Left (b', d', e')
-                  Just o -> Right o
-              )
-            | push <- allPushable'
-            , (e', eout) <- maybeToList $ applyPush push e
-            , (d', dout) <- case eout of
-                Nothing -> pure (d, Nothing)
-                Just push' -> maybeToList $ applyPush push' d
-            , (b', bout) <- case dout of
-                Nothing -> pure (b, Nothing)
-                Just push' -> maybeToList $ applyPush push' b
-            ]
-        step (Right _) = []
+    (bg, st, en) = buttonGraph
 
 dirPathCosts :: Pushable a => Map (Maybe a) (Map (Maybe a) Int)
 dirPathCosts = (fmap . fmap) length dirPath
diff --git a/common/AOC/Common/Point.hs b/common/AOC/Common/Point.hs
index fc7ae20..4bf67cb 100644
--- a/common/AOC/Common/Point.hs
+++ b/common/AOC/Common/Point.hs
@@ -320,8 +320,6 @@ centeredFinite =
     (subtract d . (% 1) . getFinite)
     (Finite . numerator . (+ d))
   where
-    -- Finite . numerator . (+ d) <$> f ((getFinite i % 1) - d)
-
     d = fromIntegral (natVal (Proxy @n) - 1) % 2
 
 parseDir :: Char -> Maybe Dir
diff --git a/site/default.nix b/site/default.nix
index f3183aa..3e1351b 100644
--- a/site/default.nix
+++ b/site/default.nix
@@ -41,7 +41,7 @@ let
                     *[Top](#)* / *[Prompt][d${daylong}p]* / *[Code][d${daylong}g]*${standaloneLink}
 
                     [d${daylong}p]: https://adventofcode.com/${year}/day/${dayshort}
-                    [d${daylong}g]: https://github.com/${github}/advent-of-code/blob/master/${year}/AOC${year}/Day${daylong}.hs
+                    [d${daylong}g]: https://github.com/${github}/advent-of-code/blob/main/${year}/AOC${year}/Day${daylong}.hs
                     [d${daylong}s]: https://github.com/mstksg/advent-of-code/blob/main/reflections/${year}/day${daylong}.md
 
                     ${lib.optionalString

From b95ad7e17dd5da383a0efd242f70322845da543b Mon Sep 17 00:00:00 2001
From: justin <justin@jle.im>
Date: Wed, 1 Jan 2025 18:57:20 -0800
Subject: [PATCH 31/43] day 21 reflections

---
 2024/AOC2024/Day21.hs        | 18 ++++---------
 bench-results/2024/day21.txt | 18 ++++++-------
 reflections/2024/day21.md    | 51 ++++++++++++++++++++++++++++++++++++
 3 files changed, 65 insertions(+), 22 deletions(-)
 create mode 100644 reflections/2024/day21.md

diff --git a/2024/AOC2024/Day21.hs b/2024/AOC2024/Day21.hs
index d7eafbd..0f93d00 100644
--- a/2024/AOC2024/Day21.hs
+++ b/2024/AOC2024/Day21.hs
@@ -95,16 +95,8 @@ buttonGraph = (G.mkGraph (swap <$> M.toList nodes) edges, startMap, endMap)
       M.fromList . flip zip [0 ..] $
         (Left <$> liftA3 (,,) allPushable' allPushable' allPushable')
           ++ (Right <$> allPushable')
-    startMap =
-      M.fromList
-        [ (n, i)
-        | (Left (n, Nothing, Nothing), i) <- M.toList nodes
-        ]
-    endMap =
-      M.fromList
-        [ (n, i)
-        | (Right n, i) <- M.toList nodes
-        ]
+    startMap = M.fromList [(n, i) | (Left (n, Nothing, Nothing), i) <- M.toList nodes]
+    endMap = M.fromList [(n, i) | (Right n, i) <- M.toList nodes]
     edges :: [(Int, Int, DirPad)]
     edges = do
       (Left (b, d, e), node) <- M.toList nodes
@@ -156,8 +148,8 @@ runPath x = \case
 dirPathChain :: Int -> Map DirPad (Map DirPad Int)
 dirPathChain n = iterate (`composeDirPathLengths` dirPath @Dir) (dirPathCosts @Dir) !!! n
 
-solveCodeNoSearch :: Int -> [NumPad] -> Int
-solveCodeNoSearch n = spellDirPathLengths mp . (Nothing :)
+solveCode :: Int -> [NumPad] -> Int
+solveCode n = spellDirPathLengths mp . (Nothing :)
   where
     mp = dirPathChain (n - 1) `composeDirPathLengths` dirPath @(Finite 10)
 
@@ -174,7 +166,7 @@ day21 n =
           sum . map solve
     }
   where
-    solve p = num * solveCodeNoSearch n p
+    solve p = num * solveCode n p
       where
         num = read (map intToDigit (mapMaybe (fmap fromIntegral) p :: [Int]))
 
diff --git a/bench-results/2024/day21.txt b/bench-results/2024/day21.txt
index 4e1fdcc..8db2ed0 100644
--- a/bench-results/2024/day21.txt
+++ b/bench-results/2024/day21.txt
@@ -1,19 +1,19 @@
 >> Day 21a
 benchmarking...
-time                 3.965 μs   (3.959 μs .. 3.970 μs)
-                     1.000 R²   (1.000 R² .. 1.000 R²)
-mean                 3.967 μs   (3.961 μs .. 3.973 μs)
-std dev              17.27 ns   (14.75 ns .. 20.43 ns)
+time                 3.840 μs   (3.834 μs .. 3.851 μs)
+                     1.000 R²   (0.999 R² .. 1.000 R²)
+mean                 3.883 μs   (3.848 μs .. 4.052 μs)
+std dev              222.9 ns   (19.15 ns .. 512.1 ns)
+variance introduced by outliers: 69% (severely inflated)
 
 * parsing and formatting times excluded
 
 >> Day 21b
 benchmarking...
-time                 3.971 μs   (3.958 μs .. 3.988 μs)
-                     0.999 R²   (0.996 R² .. 1.000 R²)
-mean                 4.020 μs   (3.971 μs .. 4.206 μs)
-std dev              304.7 ns   (22.58 ns .. 645.9 ns)
-variance introduced by outliers: 80% (severely inflated)
+time                 3.839 μs   (3.831 μs .. 3.849 μs)
+                     1.000 R²   (1.000 R² .. 1.000 R²)
+mean                 3.841 μs   (3.835 μs .. 3.845 μs)
+std dev              16.92 ns   (13.66 ns .. 20.87 ns)
 
 * parsing and formatting times excluded
 
diff --git a/reflections/2024/day21.md b/reflections/2024/day21.md
new file mode 100644
index 0000000..56ef49d
--- /dev/null
+++ b/reflections/2024/day21.md
@@ -0,0 +1,51 @@
+Everything reveals itself if we imagine a lookup table of "best path from A to
+B".  For my own purposes I've made the functions parameterized by button pad,
+using `Maybe a`, where `Nothing` is the `A` key and `Just x` is the `x` key.
+
+```haskell
+type LookupTable a b = Map (Maybe a) (Map (Maybe a) [Maybe b])
+
+type LookupTableLengths a = Map (Maybe a) (Map (Maybe a) Int)
+
+toLengths :: LookupTable a b -> LookupTableLengths a
+toLengths = fmap (fmap length)
+```
+
+The key is that now these maps are composable:
+
+```haskell
+spellDirPathLengths :: Ord a => LookupTableLengths a -> [Maybe a] -> Int
+spellDirPathLengths mp xs = sum $ zipWith (\x y -> (mp M.! x) M.! y) xs (drop 1 xs)
+
+composeDirPathLengths :: Ord b => LookupTableLengths b -> LookupTable a b -> LookupTableLengths a
+composeDirPathLengths mp = (fmap . fmap) (spellDirPathLengths mp . (Nothing :))
+```
+
+That is, if you have the lookup table for two layers, you can compose them to
+create one big lookup table.
+
+```haskell
+data Dir = North | East | West | South
+data NumButton = Finite 10
+
+dirPathChain :: [LookupTableLengths NumButton]
+dirPathChain = iterate (`composeDirPathLengths` dirPath @Dir) (dirPathCosts @Dir)
+
+solveCode :: Int -> [Maybe NumButton] -> Int
+solveCode n = spellDirPathLengths mp . (Nothing :)
+  where
+    lengthChain = dirPathChain !! (n - 1)
+    mp = lengthChain `composeDirPathLengths` dirPath @NumButton
+````
+
+The nice thing is that you only need to compute `dirPathChain` once, to get the
+final `LookupTableLengths` for a given `n`, and you can re-use it for
+everything.
+
+Generating the actual `LookupTable NumButton Dir` and `LookupTable Dir Dir` is
+the tricky part. For me I generated it based on the shortest path considering
+the third bot up the chain from the bottom: I used an *fgl* graph where the
+nodes were the state of three bots and the edges were the actions that the
+fourth "controller" would take, and computed the shortest path in terms of the
+fourth controller.  This seems to be the magic number: anything higher and you
+get the same answer, anything lower and you get suboptimal final paths.

From 1f487d3e82071cd1765c0b62138e268a40b163ec Mon Sep 17 00:00:00 2001
From: justin <justin@jle.im>
Date: Sun, 5 Jan 2025 21:25:06 -0800
Subject: [PATCH 32/43] clean up day 17

---
 2024/AOC2024/Day17.hs | 125 ++++++++++++++++++++++++++++++++++++------
 1 file changed, 107 insertions(+), 18 deletions(-)

diff --git a/2024/AOC2024/Day17.hs b/2024/AOC2024/Day17.hs
index 7264683..bb015ff 100644
--- a/2024/AOC2024/Day17.hs
+++ b/2024/AOC2024/Day17.hs
@@ -1,3 +1,4 @@
+{-# OPTIONS_GHC -Wno-orphans #-}
 {-# OPTIONS_GHC -Wno-unused-imports #-}
 {-# OPTIONS_GHC -Wno-unused-top-binds #-}
 
@@ -20,14 +21,21 @@
 --     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.Day17 (
-  day17a,
-  day17b,
-)
+module AOC2024.Day17
 where
 
-import AOC.Prelude
+-- (
+-- day17a,
+-- day17b,
+-- )
+
+import AOC.Prelude hiding (Finite, modulo, packFinite)
+import Control.Monad.Primitive
+import Control.Monad.ST
 import Data.Bits
+import qualified Data.Conduino as C
+import qualified Data.Conduino.Combinators as C
+import Data.Finite.Integral hiding (shift)
 import qualified Data.Graph.Inductive as G
 import qualified Data.IntMap as IM
 import qualified Data.IntMap.NonEmpty as IM
@@ -39,37 +47,110 @@ 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 Data.Primitive.MutVar
+import Data.STRef
 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 Data.Vector.Mutable.Sized as SMV
+import qualified Data.Vector.Sized as SV
+import qualified Data.Vector.Storable.Mutable.Sized as SMVS
+import qualified Data.Vector.Storable.Sized as SVS
 import qualified Linear as L
 import qualified Numeric.Lens as L
 import qualified Text.Megaparsec as P
 import qualified Text.Megaparsec.Char as P
 import qualified Text.Megaparsec.Char.Lexer as PP
 
-day17a :: _ :~> _
+day17a :: _ :~> [Int]
 day17a =
   MkSol
     { sParse = parseMaybe' do
-        a <- "Register A: " *> pDecimal
-        P.newline
-        b <- "Register B: " *> pDecimal
-        P.newline
-        c <- "Register C: " *> pDecimal
-        P.newline
+        a <- "Register A: " *> pDecimal <* P.newline
+        b <- "Register B: " *> pDecimal <* P.newline
+        c <- "Register C: " *> pDecimal <* P.newline
         P.newline
         d <- "Program: " *> (pDecimal `sepBy'` ",")
-        pure (a, b, c, d)
+        p <- case parseProgram d of
+          Nothing -> fail "Bad program"
+          Just p -> pure p
+        pure (a, b, c, p)
     , sShow = intercalate "," . map show
-    , sSolve =
-        noFail $ \(a, b, c, p :: [Int]) ->
-          go 0 (V3 a b c) (Seq.fromList p)
+    , sSolve = \(a, b, c, instrs) -> do
+        pure . map fromIntegral $ stepProg instrs (V3 a b c)
     }
 
+data Combo
+  = CLiteral (Finite Word 4)
+  | CReg (Finite Word 3)
+  deriving stock (Show, Eq, Ord)
+
+data Instr
+  = ADV Combo
+  | BXL (Finite Word 8)
+  | BST Combo
+  | JNZ (Finite Word 4)
+  | BXC
+  | OUT Combo
+  | BDV Combo
+  | CDV Combo
+  deriving stock (Show, Eq, Ord)
+
+comboParser :: Finite Word 7 -> Combo
+comboParser = either CLiteral CReg . separateSum
+
+instrParser :: Finite Word 8 -> Finite Word 8 -> Maybe Instr
+instrParser i =
+  SV.fromTuple @_ @8
+    ( fmap (ADV . comboParser) . strengthen
+    , Just . BXL
+    , fmap (BST . comboParser) . strengthen
+    , Just . JNZ . snd . separateProduct @2 @4
+    , const $ Just BXC
+    , fmap (OUT . comboParser) . strengthen
+    , fmap (BDV . comboParser) . strengthen
+    , fmap (CDV . comboParser) . strengthen
+    )
+    `SV.index` fromIntegral i
+
+parseProgram :: [Int] -> Maybe (SV.Vector 8 Instr)
+parseProgram xs = do
+  xsVec <- SV.fromList @16 =<< traverse (packFinite . fromIntegral) xs
+  SV.generateM \i ->
+    instrParser (xsVec `SV.index` combineProduct (0, i)) (xsVec `SV.index` combineProduct (1, i))
+
+readComboV3 :: Combo -> V3 Word -> Word
+readComboV3 = \case
+  CLiteral l -> \_ -> fromIntegral l
+  CReg 0 -> \(V3 a _ _) -> a
+  CReg 1 -> \(V3 _ b _) -> b
+  CReg 2 -> \(V3 _ _ c) -> c
+  _ -> undefined
+
+stepProg :: SV.Vector 8 Instr -> V3 Word -> [Finite Word 8]
+stepProg tp = go' 0
+  where
+    go' :: Finite Word 8 -> V3 Word -> [Finite Word 8]
+    go' i v@(V3 a b c) = case tp `SV.index` fromIntegral i of
+      ADV r -> withStep $ V3 (a `div` (2 ^ combo r)) b c
+      BXL l -> withStep $ V3 a (b `xor` fromIntegral l) c
+      BST r -> withStep $ V3 a (combo r `mod` 8) c
+      JNZ l
+        | a == 0 -> withStep v
+        | otherwise -> go' (weakenN l) v
+      BXC -> withStep $ V3 a (b `xor` c) c
+      OUT r -> modulo (combo r) : withStep v
+      BDV r -> withStep $ V3 a (a `div` (2 ^ combo r)) c
+      CDV r -> withStep $ V3 a b (a `div` (2 ^ combo r))
+      where
+        combo = flip readComboV3 v
+        withStep
+          | i == maxBound = const []
+          | otherwise = go' (succ i)
+
 go :: Int -> V3 Int -> Seq Int -> [Int]
 -- go i (V3 a b c) tp = case (,) <$> Seq.lookup i tp <*> Seq.lookup (i + 1) tp of
 go i (V3 a b c) tp = case (,) <$> Seq.lookup i tp <*> Seq.lookup (i + 1) tp of
@@ -158,10 +239,18 @@ go i (V3 a b c) tp = case (,) <$> Seq.lookup i tp <*> Seq.lookup (i + 1) tp of
 day17b :: _ :~> _
 day17b =
   MkSol
-    { sParse = sParse day17a
+    { sParse = parseMaybe' do
+        _ <- "Register A: " *> pDecimal @Int
+        P.newline
+        _ <- "Register B: " *> pDecimal @Int
+        P.newline
+        _ <- "Register C: " *> pDecimal @Int
+        P.newline
+        P.newline
+        "Program: " *> (pDecimal `sepBy'` ",")
     , sShow = show
     , sSolve =
-        \(_, _, _, p :: [Int]) -> listToMaybe do
+        \p -> listToMaybe do
           option <- stepBackwards (reverse p)
           guard $ go 0 (V3 option 0 0) (Seq.fromList p) == p
           pure option

From 92130ab8a3c1bf75091c7fa9cf3de4bb78be814c Mon Sep 17 00:00:00 2001
From: justin <justin@jle.im>
Date: Sun, 5 Jan 2025 21:31:13 -0800
Subject: [PATCH 33/43] fix

---
 2024/AOC2024/Day17.hs | 27 ++++++++++++---------------
 1 file changed, 12 insertions(+), 15 deletions(-)

diff --git a/2024/AOC2024/Day17.hs b/2024/AOC2024/Day17.hs
index bb015ff..6422d25 100644
--- a/2024/AOC2024/Day17.hs
+++ b/2024/AOC2024/Day17.hs
@@ -29,13 +29,13 @@ where
 -- day17b,
 -- )
 
-import AOC.Prelude hiding (Finite, modulo, packFinite)
+import AOC.Prelude
 import Control.Monad.Primitive
 import Control.Monad.ST
 import Data.Bits
 import qualified Data.Conduino as C
 import qualified Data.Conduino.Combinators as C
-import Data.Finite.Integral hiding (shift)
+import Data.Finite hiding (shift)
 import qualified Data.Graph.Inductive as G
 import qualified Data.IntMap as IM
 import qualified Data.IntMap.NonEmpty as IM
@@ -84,25 +84,25 @@ day17a =
     }
 
 data Combo
-  = CLiteral (Finite Word 4)
-  | CReg (Finite Word 3)
+  = CLiteral (Finite 4)
+  | CReg (Finite 3)
   deriving stock (Show, Eq, Ord)
 
 data Instr
   = ADV Combo
-  | BXL (Finite Word 8)
+  | BXL (Finite 8)
   | BST Combo
-  | JNZ (Finite Word 4)
+  | JNZ (Finite 4)
   | BXC
   | OUT Combo
   | BDV Combo
   | CDV Combo
   deriving stock (Show, Eq, Ord)
 
-comboParser :: Finite Word 7 -> Combo
+comboParser :: Finite 7 -> Combo
 comboParser = either CLiteral CReg . separateSum
 
-instrParser :: Finite Word 8 -> Finite Word 8 -> Maybe Instr
+instrParser :: Finite 8 -> Finite 8 -> Maybe Instr
 instrParser i =
   SV.fromTuple @_ @8
     ( fmap (ADV . comboParser) . strengthen
@@ -125,15 +125,12 @@ parseProgram xs = do
 readComboV3 :: Combo -> V3 Word -> Word
 readComboV3 = \case
   CLiteral l -> \_ -> fromIntegral l
-  CReg 0 -> \(V3 a _ _) -> a
-  CReg 1 -> \(V3 _ b _) -> b
-  CReg 2 -> \(V3 _ _ c) -> c
-  _ -> undefined
+  CReg r -> view (SV.fromTuple (_x, _y, _z) `SV.index` r)
 
-stepProg :: SV.Vector 8 Instr -> V3 Word -> [Finite Word 8]
+stepProg :: SV.Vector 8 Instr -> V3 Word -> [Finite 8]
 stepProg tp = go' 0
   where
-    go' :: Finite Word 8 -> V3 Word -> [Finite Word 8]
+    go' :: Finite 8 -> V3 Word -> [Finite 8]
     go' i v@(V3 a b c) = case tp `SV.index` fromIntegral i of
       ADV r -> withStep $ V3 (a `div` (2 ^ combo r)) b c
       BXL l -> withStep $ V3 a (b `xor` fromIntegral l) c
@@ -142,7 +139,7 @@ stepProg tp = go' 0
         | a == 0 -> withStep v
         | otherwise -> go' (weakenN l) v
       BXC -> withStep $ V3 a (b `xor` c) c
-      OUT r -> modulo (combo r) : withStep v
+      OUT r -> modulo (fromIntegral (combo r)) : withStep v
       BDV r -> withStep $ V3 a (a `div` (2 ^ combo r)) c
       CDV r -> withStep $ V3 a b (a `div` (2 ^ combo r))
       where

From 3df3844808f7d38d283f08a2edfeca2597ad20d0 Mon Sep 17 00:00:00 2001
From: justin <justin@jle.im>
Date: Sat, 11 Jan 2025 16:05:23 -0800
Subject: [PATCH 34/43] start working on auto solve

---
 2024/AOC2024/Day17.hs | 131 +++++++++++++++++++++++++++---------------
 1 file changed, 84 insertions(+), 47 deletions(-)

diff --git a/2024/AOC2024/Day17.hs b/2024/AOC2024/Day17.hs
index 6422d25..67a4bb6 100644
--- a/2024/AOC2024/Day17.hs
+++ b/2024/AOC2024/Day17.hs
@@ -1,7 +1,3 @@
-{-# OPTIONS_GHC -Wno-orphans #-}
-{-# OPTIONS_GHC -Wno-unused-imports #-}
-{-# OPTIONS_GHC -Wno-unused-top-binds #-}
-
 -- |
 -- Module      : AOC2024.Day17
 -- License     : BSD3
@@ -114,7 +110,7 @@ instrParser i =
     , fmap (BDV . comboParser) . strengthen
     , fmap (CDV . comboParser) . strengthen
     )
-    `SV.index` fromIntegral i
+    `SV.index` i
 
 parseProgram :: [Int] -> Maybe (SV.Vector 8 Instr)
 parseProgram xs = do
@@ -122,57 +118,71 @@ parseProgram xs = do
   SV.generateM \i ->
     instrParser (xsVec `SV.index` combineProduct (0, i)) (xsVec `SV.index` combineProduct (1, i))
 
-readComboV3 :: Combo -> V3 Word -> Word
-readComboV3 = \case
+readCombo :: Combo -> V3 Word -> Word
+readCombo = \case
   CLiteral l -> \_ -> fromIntegral l
   CReg r -> view (SV.fromTuple (_x, _y, _z) `SV.index` r)
 
 stepProg :: SV.Vector 8 Instr -> V3 Word -> [Finite 8]
-stepProg tp = go' 0
+stepProg tp (V3 a0 b0 c0) = go' 0 a0 b0 c0
   where
-    go' :: Finite 8 -> V3 Word -> [Finite 8]
-    go' i v@(V3 a b c) = case tp `SV.index` fromIntegral i of
-      ADV r -> withStep $ V3 (a `div` (2 ^ combo r)) b c
-      BXL l -> withStep $ V3 a (b `xor` fromIntegral l) c
-      BST r -> withStep $ V3 a (combo r `mod` 8) c
+    go' :: Finite 8 -> Word -> Word -> Word -> [Finite 8]
+    go' i !a !b !c = case tp `SV.index` i of
+      ADV r -> withStep (a `div` (2 ^ combo r)) b c
+      BXL l -> withStep a (b `xor` fromIntegral l) c
+      BST r -> withStep a (combo r `mod` 8) c
       JNZ l
-        | a == 0 -> withStep v
-        | otherwise -> go' (weakenN l) v
-      BXC -> withStep $ V3 a (b `xor` c) c
-      OUT r -> modulo (fromIntegral (combo r)) : withStep v
-      BDV r -> withStep $ V3 a (a `div` (2 ^ combo r)) c
-      CDV r -> withStep $ V3 a b (a `div` (2 ^ combo r))
+        | a == 0 -> withStep 0 b c
+        | otherwise -> go' (weakenN l) a b c
+      BXC -> withStep a (b `xor` c) c
+      OUT r -> modulo (fromIntegral (combo r)) : withStep a b c
+      BDV r -> withStep a (a `div` (2 ^ combo r)) c
+      CDV r -> withStep a b (a `div` (2 ^ combo r))
       where
-        combo = flip readComboV3 v
+        combo = \case
+          CLiteral l -> fromIntegral l
+          CReg 0 -> a
+          CReg 1 -> b
+          CReg _ -> c
         withStep
-          | i == maxBound = const []
-          | otherwise = go' (succ i)
+          | i == maxBound = \_ _ _ -> []
+          | otherwise = go' (i + 1)
 
-go :: Int -> V3 Int -> Seq Int -> [Int]
--- go i (V3 a b c) tp = case (,) <$> Seq.lookup i tp <*> Seq.lookup (i + 1) tp of
-go i (V3 a b c) tp = case (,) <$> Seq.lookup i tp <*> Seq.lookup (i + 1) tp of
-  Nothing -> []
-  Just (q, o) ->
-    let x = case o of
-          0 -> 0
-          1 -> 1
-          2 -> 2
-          3 -> 3
-          4 -> a
-          5 -> b
-          6 -> c
-     in case q of
-          0 -> go (i + 2) (V3 (a `div` (2 ^ x)) b c) tp
-          1 -> go (i + 2) (V3 a (b `xor` o) c) tp
-          2 -> go (i + 2) (V3 a (x `mod` 8) c) tp
-          3
-            | a == 0 -> go (i + 2) (V3 a b c) tp
-            | otherwise -> go o (V3 a b c) tp
-          4 -> go (i + 2) (V3 a (b `xor` c) c) tp
-          5 -> (x `mod` 8) : go (i + 2) (V3 a b c) tp
-          -- 5 -> trace (show (x `mod` 8, o, x)) (x `mod` 8) : go (i + 2) (V3 a b c) tp
-          6 -> go (i + 2) (V3 a (a `div` (2 ^ x)) c) tp
-          7 -> go (i + 2) (V3 a b (a `div` (2 ^ x))) tp
+-- | Assumes that:
+--
+-- 1. Only A is persistent across each "loop"
+-- 2. The last instruction is a jump to 0
+unstepProg :: SV.Vector 8 Instr -> [Finite 8] -> [Int]
+unstepProg prog = unLoop jnzIx 0 Nothing Nothing
+  where
+    jnzIx :: Finite 8
+    jnzIx = maxBound
+    unLoop :: Finite 8 -> Word -> Maybe Word -> Maybe Word -> [Finite 8] -> [Int]
+    unLoop i a b c = case prog `SV.index` i of
+      ADV r -> _ (combo r)
+      -- JNZ l
+      --   | a == 0    -> unLoop
+      --   | otherwise -> undefined
+      where
+        combo = \case
+          CLiteral l -> [fromIntegral l]
+          CReg 0 -> pure a
+          CReg 1 -> maybeToList b   -- hmm could really be anything
+          CReg _ -> maybeToList c   -- hmm could really be anything
+        withStep
+          | i == minBound = undefined
+          | otherwise = unLoop (pred i)
+
+  -- search 0
+  -- where
+  --   search a = \case
+  --     [] -> pure a
+  --     o : os -> do
+  --       a' <- ((a `shift` 3) +) <$> [0 .. 7]
+  --       let b0 = (a' .&. 7) `xor` 6
+  --       let c = a' `shift` (-b0)
+  --       guard $ modulo (fromIntegral $ (b0 `xor` c) `xor` 4) == o
+  --       search a' os
 
 -- 2,4, 1,6, 7,5, 4,6, 1,4, 5,5, 0,3, 3,0
 --
@@ -253,6 +263,33 @@ day17b =
           pure option
     }
 
+go :: Int -> V3 Int -> Seq Int -> [Int]
+-- go i (V3 a b c) tp = case (,) <$> Seq.lookup i tp <*> Seq.lookup (i + 1) tp of
+go i (V3 a b c) tp = case (,) <$> Seq.lookup i tp <*> Seq.lookup (i + 1) tp of
+  Nothing -> []
+  Just (q, o) ->
+    let x = case o of
+          0 -> 0
+          1 -> 1
+          2 -> 2
+          3 -> 3
+          4 -> a
+          5 -> b
+          6 -> c
+     in case q of
+          0 -> go (i + 2) (V3 (a `div` (2 ^ x)) b c) tp
+          1 -> go (i + 2) (V3 a (b `xor` o) c) tp
+          2 -> go (i + 2) (V3 a (x `mod` 8) c) tp
+          3
+            | a == 0 -> go (i + 2) (V3 a b c) tp
+            | otherwise -> go o (V3 a b c) tp
+          4 -> go (i + 2) (V3 a (b `xor` c) c) tp
+          5 -> (x `mod` 8) : go (i + 2) (V3 a b c) tp
+          -- 5 -> trace (show (x `mod` 8, o, x)) (x `mod` 8) : go (i + 2) (V3 a b c) tp
+          6 -> go (i + 2) (V3 a (a `div` (2 ^ x)) c) tp
+          7 -> go (i + 2) (V3 a b (a `div` (2 ^ x))) tp
+
+
 -- [ (go 0 (V3 i b c) (Seq.fromList p))
 -- -- | i <- [45184372088832]
 -- \| i <- [1999]

From 70ac3b7c61469378c90ddde40e81fdf865953ed5 Mon Sep 17 00:00:00 2001
From: justin <justin@jle.im>
Date: Mon, 13 Jan 2025 00:30:22 -0800
Subject: [PATCH 35/43] CPS stype day 17

---
 2024/AOC2024/Day17.hs | 157 ++++++++++++++++++++++++++----------------
 1 file changed, 99 insertions(+), 58 deletions(-)

diff --git a/2024/AOC2024/Day17.hs b/2024/AOC2024/Day17.hs
index 67a4bb6..93e69c9 100644
--- a/2024/AOC2024/Day17.hs
+++ b/2024/AOC2024/Day17.hs
@@ -124,65 +124,107 @@ readCombo = \case
   CReg r -> view (SV.fromTuple (_x, _y, _z) `SV.index` r)
 
 stepProg :: SV.Vector 8 Instr -> V3 Word -> [Finite 8]
-stepProg tp (V3 a0 b0 c0) = go' 0 a0 b0 c0
+stepProg tp (V3 a0 b0 c0) = stepAll 0 a0 b0 c0
   where
-    go' :: Finite 8 -> Word -> Word -> Word -> [Finite 8]
-    go' i !a !b !c = case tp `SV.index` i of
-      ADV r -> withStep (a `div` (2 ^ combo r)) b c
-      BXL l -> withStep a (b `xor` fromIntegral l) c
-      BST r -> withStep a (combo r `mod` 8) c
-      JNZ l
-        | a == 0 -> withStep 0 b c
-        | otherwise -> go' (weakenN l) a b c
-      BXC -> withStep a (b `xor` c) c
-      OUT r -> modulo (fromIntegral (combo r)) : withStep a b c
-      BDV r -> withStep a (a `div` (2 ^ combo r)) c
-      CDV r -> withStep a b (a `div` (2 ^ combo r))
-      where
-        combo = \case
-          CLiteral l -> fromIntegral l
-          CReg 0 -> a
-          CReg 1 -> b
-          CReg _ -> c
-        withStep
-          | i == maxBound = \_ _ _ -> []
-          | otherwise = go' (i + 1)
-
--- | Assumes that:
---
--- 1. Only A is persistent across each "loop"
--- 2. The last instruction is a jump to 0
-unstepProg :: SV.Vector 8 Instr -> [Finite 8] -> [Int]
-unstepProg prog = unLoop jnzIx 0 Nothing Nothing
+    stepAll = stepWith tp (\o i a b c -> o : stepAll i a b c) stepAll
+
+type Stepper a = Finite 8 -> Word -> Word -> Word -> a
+
+stepWith ::
+  Monoid a =>
+  SV.Vector 8 Instr ->
+  -- | out
+  (Finite 8 -> Stepper a) ->
+  -- | next
+  Stepper a ->
+  Stepper a
+stepWith tp out next i !a !b !c = case tp `SV.index` i of
+  ADV r -> withStep next (a `div` (2 ^ combo r)) b c
+  BXL l -> withStep next a (b `xor` fromIntegral l) c
+  BST r -> withStep next a (combo r `mod` 8) c
+  JNZ l
+    | a == 0 -> withStep next 0 b c
+    | otherwise -> next (weakenN l) a b c
+  BXC -> withStep next a (b `xor` c) c
+  OUT r ->
+    let o = modulo (fromIntegral (combo r))
+     in withStep (out o) a b c
+  BDV r -> withStep next a (a `div` (2 ^ combo r)) c
+  CDV r -> withStep next a b (a `div` (2 ^ combo r))
   where
-    jnzIx :: Finite 8
-    jnzIx = maxBound
-    unLoop :: Finite 8 -> Word -> Maybe Word -> Maybe Word -> [Finite 8] -> [Int]
-    unLoop i a b c = case prog `SV.index` i of
-      ADV r -> _ (combo r)
-      -- JNZ l
-      --   | a == 0    -> unLoop
-      --   | otherwise -> undefined
-      where
-        combo = \case
-          CLiteral l -> [fromIntegral l]
-          CReg 0 -> pure a
-          CReg 1 -> maybeToList b   -- hmm could really be anything
-          CReg _ -> maybeToList c   -- hmm could really be anything
-        withStep
-          | i == minBound = undefined
-          | otherwise = unLoop (pred i)
-
-  -- search 0
-  -- where
-  --   search a = \case
-  --     [] -> pure a
-  --     o : os -> do
-  --       a' <- ((a `shift` 3) +) <$> [0 .. 7]
-  --       let b0 = (a' .&. 7) `xor` 6
-  --       let c = a' `shift` (-b0)
-  --       guard $ modulo (fromIntegral $ (b0 `xor` c) `xor` 4) == o
-  --       search a' os
+    combo = \case
+      CLiteral l -> fromIntegral l
+      CReg 0 -> a
+      CReg 1 -> b
+      CReg _ -> c
+    withStep p
+      | i == maxBound = \_ _ _ -> mempty
+      | otherwise = p (i + 1)
+
+-- -- | Assumes that:
+-- --
+-- -- 1. Only A is persistent across each "loop"
+-- -- 2. The last instruction is a jump to 0
+-- unstepProg :: SV.Vector 8 Instr -> [Finite 8] -> [Int]
+-- unstepProg prog = unLoop jnzIx 0 Nothing Nothing
+--   where
+--     jnzIx :: Finite 8
+--     jnzIx = maxBound
+--     unLoop :: Finite 8 -> Word -> Maybe Word -> Maybe Word -> [Finite 8] -> [Int]
+--     unLoop i a b c os = case prog `SV.index` i of
+--       ADV r -> do
+--         unshift <- fromIntegral <$> combo r
+--         possibleUnshifts <- [0.. 2^unshift - 1]
+--         withStep (a `shift` unshift + possibleUnshifts) b c os
+--       BXL l -> do
+--         b' <- maybeToList b
+--         withStep a (Just $ b' `xor` fromIntegral l) c os
+--       BST r -> case r of
+--          CLiteral l -> do
+--            for_ b \b' -> guard $ fromIntegral l == b'
+--            withStep a b c os
+--          CReg g -> do
+--            possibleUnshift <- [0 .. 7]
+--            let stored = fromMaybe 0 b `shift` 3 + possibleUnshift
+--            case g of
+--              0 -> withStep stored b c os
+--              1 -> withStep a (Just stored) c os
+--              _ -> withStep a b (Just stored) os
+--       JNZ _
+--         | a == 0    -> undefined
+--         | otherwise -> undefined
+--       BXC -> _
+--         -- withStep a (b `xor` c) c
+--       OUT r -> do
+--         o:os' <- pure os
+--         let setModulo x = ((x `shift` (-3)) `shift` 3) + fromIntegral o
+--         case r of
+--           CLiteral l -> do
+--             guard $ weakenN l == o
+--             withStep a b c os'
+--           CReg 0 -> withStep (setModulo a) b c os'
+--           CReg 1 -> withStep a (Just $ maybe (fromIntegral o) setModulo b) c os'
+--           CReg _ -> withStep a b (Just $ maybe (fromIntegral o) setModulo c) os'
+--       where
+--         combo = \case
+--           CLiteral l -> [fromIntegral l]
+--           CReg 0 -> pure a
+--           CReg 1 -> maybeToList b   -- hmm could really be anything
+--           CReg _ -> maybeToList c   -- hmm could really be anything
+--         withStep
+--           | i == minBound = undefined
+--           | otherwise = unLoop (pred i)
+
+-- search 0
+-- where
+--   search a = \case
+--     [] -> pure a
+--     o : os -> do
+--       a' <- ((a `shift` 3) +) <$> [0 .. 7]
+--       let b0 = (a' .&. 7) `xor` 6
+--       let c = a' `shift` (-b0)
+--       guard $ modulo (fromIntegral $ (b0 `xor` c) `xor` 4) == o
+--       search a' os
 
 -- 2,4, 1,6, 7,5, 4,6, 1,4, 5,5, 0,3, 3,0
 --
@@ -289,7 +331,6 @@ go i (V3 a b c) tp = case (,) <$> Seq.lookup i tp <*> Seq.lookup (i + 1) tp of
           6 -> go (i + 2) (V3 a (a `div` (2 ^ x)) c) tp
           7 -> go (i + 2) (V3 a b (a `div` (2 ^ x))) tp
 
-
 -- [ (go 0 (V3 i b c) (Seq.fromList p))
 -- -- | i <- [45184372088832]
 -- \| i <- [1999]

From 960f91b3869de9c51cf77c65dd24fb92510fe6ae Mon Sep 17 00:00:00 2001
From: justin <justin@jle.im>
Date: Thu, 16 Jan 2025 21:42:17 -0800
Subject: [PATCH 36/43] hey it works

---
 2024/AOC2024/Day17.hs | 118 ++++++++++++++++++++++++++++++++++++------
 1 file changed, 101 insertions(+), 17 deletions(-)

diff --git a/2024/AOC2024/Day17.hs b/2024/AOC2024/Day17.hs
index 93e69c9..855d9bc 100644
--- a/2024/AOC2024/Day17.hs
+++ b/2024/AOC2024/Day17.hs
@@ -73,9 +73,9 @@ day17a =
         p <- case parseProgram d of
           Nothing -> fail "Bad program"
           Just p -> pure p
-        pure (a, b, c, p)
+        pure (a, b, c, p, fromIntegral <$> d)
     , sShow = intercalate "," . map show
-    , sSolve = \(a, b, c, instrs) -> do
+    , sSolve = \(a, b, c, instrs, _) -> do
         pure . map fromIntegral $ stepProg instrs (V3 a b c)
     }
 
@@ -161,6 +161,70 @@ stepWith tp out next i !a !b !c = case tp `SV.index` i of
       | i == maxBound = \_ _ _ -> mempty
       | otherwise = p (i + 1)
 
+-- BST A    --- b = a & 111
+-- BXL 6    --- b ^= 110    (6)
+-- CDV B    --- c = a >> b
+-- BXC      --- b ^= c
+-- BXL 4    --- b ^= 100    (4)
+-- OUT B    --- print b
+-- ADV 3    --- a >> 3
+-- JNZ 0
+--
+-- ok maybe we step from the back until the Out (to generate the options), and
+-- then jump from the beginning to the out (to generate the constraints)
+--
+-- so "step backwards" from JNZ 2 to OUT B to generate all possible previous
+-- values of a, then jump from BST A down to OUT B to limit which ones are
+-- possible.
+
+searchStep :: SV.Vector 8 Instr -> [Finite 8] -> [Word]
+searchStep tp outs = do
+  JNZ 0 <- pure $ tp `SV.index` maxBound
+  [CReg _] <- pure [r | OUT r <- toList tp]
+  let search a = \case
+        o : os -> do
+          a' <- stepBack a
+          guard $ stepForward a' == Just o
+          search a' os
+        [] -> pure a
+  search 0 (reverse outs)
+  where
+    stepForward :: Word -> Maybe (Finite 8)
+    stepForward a0 = getFirst <$> go' 0 a0 0 0
+      where
+        go' = stepWith tp (\o _ _ _ _ -> Just (First o)) go'
+    stepBack :: Word -> [Word]
+    stepBack = go' maxBound
+      where
+        go' i a = case tp `SV.index` i of
+          ADV r -> do
+            a' <- case r of
+              CLiteral l -> ((a `shift` fromIntegral l) +) <$> [0 .. 2 ^ getFinite l - 1]
+              CReg _ -> []
+            go' (pred i) a'
+          OUT _ -> pure a
+          _ -> go' (pred i) a
+
+-- stepProg tp (V3 a0 b0 c0) = stepAll 0 a0 b0 c0
+--   where
+--     stepAll = stepWith tp (\o i a b c -> o : stepAll i a b c) stepAll
+
+-- 0 undefined undefined
+-- go' (o : os) = stepWith tp (\r i a b c -> guard (o == r) >> go' os i a b c) \i a b c ->
+--     if i == 0
+--        then go' (o:os) i a undefined undefined
+--        else go' (o:os) i a b c
+
+-- where
+--   search a = \case
+--     [] -> pure a
+--     o : os -> do
+--       a' <- ((a `shift` 3) +) <$> [0 .. 7]
+--       let b0 = (a' .&. 7) `xor` 6
+--       let c = a' `shift` (-b0)
+--       guard $ ((b0 `xor` c) `xor` 4) .&. 7 == o
+--       search a' os
+
 -- -- | Assumes that:
 -- --
 -- -- 1. Only A is persistent across each "loop"
@@ -237,6 +301,17 @@ stepWith tp out next i !a !b !c = case tp `SV.index` i of
 -- ADV 3    --- a /= 8
 -- JNZ 0
 
+-- 2,4, 1,6, 7,5, 4,6, 1,4, 5,5, 0,3, 3,0
+--
+-- BST A    --- b = a & 111
+-- BXL 6    --- b ^= 110    (6)
+-- CDV B    --- c = a >> b
+-- BXC      --- b ^= c
+-- BXL 4    --- b ^= 100    (4)
+-- OUT B    --- print b
+-- ADV 3    --- a >> 3
+-- JNZ 0
+
 -- The *`adv`* instruction (opcode *`0`*) performs *division*. The
 -- numerator is the value in the `A` register. The denominator is found by
 -- raising 2 to the power of the instruction's *combo* operand. (So, an
@@ -287,22 +362,31 @@ stepWith tp out next i !a !b !c = case tp `SV.index` i of
 
 day17b :: _ :~> _
 day17b =
+  -- MkSol
+    -- { sParse = parseMaybe' do
+    --     _ <- "Register A: " *> pDecimal @Int
+    --     P.newline
+    --     _ <- "Register B: " *> pDecimal @Int
+    --     P.newline
+    --     _ <- "Register C: " *> pDecimal @Int
+    --     P.newline
+    --     P.newline
+    --     "Program: " *> (pDecimal `sepBy'` ",")
+    -- , sShow = show
+    -- , sSolve =
+    --     \p -> listToMaybe do
+    --       option <- stepBackwards (reverse p)
+    --       guard $ go 0 (V3 option 0 0) (Seq.fromList p) == p
+    --       pure option
   MkSol
-    { sParse = parseMaybe' do
-        _ <- "Register A: " *> pDecimal @Int
-        P.newline
-        _ <- "Register B: " *> pDecimal @Int
-        P.newline
-        _ <- "Register C: " *> pDecimal @Int
-        P.newline
-        P.newline
-        "Program: " *> (pDecimal `sepBy'` ",")
-    , sShow = show
-    , sSolve =
-        \p -> listToMaybe do
-          option <- stepBackwards (reverse p)
-          guard $ go 0 (V3 option 0 0) (Seq.fromList p) == p
-          pure option
+    { sParse = sParse day17a 
+    , sShow = show 
+    , sSolve = \(_, _, _, instrs, o) -> listToMaybe $
+        searchStep instrs o
+-- searchStep :: SV.Vector 8 Instr -> [Finite 8] -> [Word]
+-- searchStep tp outs = do
+
+        -- pure . map fromIntegral $ stepProg instrs (V3 a b c)
     }
 
 go :: Int -> V3 Int -> Seq Int -> [Int]

From 0253357ae5f209e1205eb6aabcb573c4b317b268 Mon Sep 17 00:00:00 2001
From: justin <justin@jle.im>
Date: Thu, 16 Jan 2025 22:13:48 -0800
Subject: [PATCH 37/43] clean up day 17

---
 2024/AOC2024/Day17.hs | 461 +++++++-----------------------------------
 1 file changed, 75 insertions(+), 386 deletions(-)

diff --git a/2024/AOC2024/Day17.hs b/2024/AOC2024/Day17.hs
index 855d9bc..ee7f2dd 100644
--- a/2024/AOC2024/Day17.hs
+++ b/2024/AOC2024/Day17.hs
@@ -6,78 +6,33 @@
 -- Portability : non-portable
 --
 -- Day 17.  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.Day17
+module AOC2024.Day17 (
+  day17a,
+  day17b,
+)
 where
 
--- (
--- day17a,
--- day17b,
--- )
-
-import AOC.Prelude
-import Control.Monad.Primitive
-import Control.Monad.ST
-import Data.Bits
-import qualified Data.Conduino as C
-import qualified Data.Conduino.Combinators as C
-import Data.Finite hiding (shift)
-import qualified Data.Graph.Inductive as G
-import qualified Data.IntMap as IM
-import qualified Data.IntMap.NonEmpty as IM
-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 Data.Primitive.MutVar
-import Data.STRef
-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 Data.Vector.Mutable.Sized as SMV
+import AOC.Common.Parser (pDecimal, parseMaybe', sepBy')
+import AOC.Solver (noFail, type (:~>) (..))
+import Control.Monad (guard)
+import Data.Bits (Bits (shift, xor))
+import Data.Finite (
+  Finite,
+  combineProduct,
+  getFinite,
+  modulo,
+  packFinite,
+  separateProduct,
+  separateSum,
+  strengthen,
+  weakenN,
+ )
+import Data.Foldable (Foldable (toList))
+import Data.List (intercalate)
+import Data.Maybe (listToMaybe)
+import Data.Semigroup (Endo (Endo, appEndo))
 import qualified Data.Vector.Sized as SV
-import qualified Data.Vector.Storable.Mutable.Sized as SMVS
-import qualified Data.Vector.Storable.Sized as SVS
-import qualified Linear as L
-import qualified Numeric.Lens as L
-import qualified Text.Megaparsec as P
 import qualified Text.Megaparsec.Char as P
-import qualified Text.Megaparsec.Char.Lexer as PP
-
-day17a :: _ :~> [Int]
-day17a =
-  MkSol
-    { sParse = parseMaybe' do
-        a <- "Register A: " *> pDecimal <* P.newline
-        b <- "Register B: " *> pDecimal <* P.newline
-        c <- "Register C: " *> pDecimal <* P.newline
-        P.newline
-        d <- "Program: " *> (pDecimal `sepBy'` ",")
-        p <- case parseProgram d of
-          Nothing -> fail "Bad program"
-          Just p -> pure p
-        pure (a, b, c, p, fromIntegral <$> d)
-    , sShow = intercalate "," . map show
-    , sSolve = \(a, b, c, instrs, _) -> do
-        pure . map fromIntegral $ stepProg instrs (V3 a b c)
-    }
 
 data Combo
   = CLiteral (Finite 4)
@@ -118,64 +73,58 @@ parseProgram xs = do
   SV.generateM \i ->
     instrParser (xsVec `SV.index` combineProduct (0, i)) (xsVec `SV.index` combineProduct (1, i))
 
-readCombo :: Combo -> V3 Word -> Word
-readCombo = \case
-  CLiteral l -> \_ -> fromIntegral l
-  CReg r -> view (SV.fromTuple (_x, _y, _z) `SV.index` r)
-
-stepProg :: SV.Vector 8 Instr -> V3 Word -> [Finite 8]
-stepProg tp (V3 a0 b0 c0) = stepAll 0 a0 b0 c0
-  where
-    stepAll = stepWith tp (\o i a b c -> o : stepAll i a b c) stepAll
-
-type Stepper a = Finite 8 -> Word -> Word -> Word -> a
+day17a :: (Word, Word, Word, SV.Vector 8 Instr, [Finite 8]) :~> [Finite 8]
+day17a =
+  MkSol
+    { sParse = parseMaybe' do
+        a <- "Register A: " *> pDecimal <* P.newline
+        b <- "Register B: " *> pDecimal <* P.newline
+        c <- "Register C: " *> pDecimal <* P.newline
+        P.newline
+        d <- "Program: " *> (pDecimal `sepBy'` ",")
+        p <- case parseProgram d of
+          Nothing -> fail "Bad program"
+          Just p -> pure p
+        pure (a, b, c, p, fromIntegral <$> d)
+    , sShow = intercalate "," . map (show . getFinite)
+    , sSolve = noFail \(a0, b0, c0, instrs, _) ->
+        appEndo (stepWith instrs (Endo . (:)) 0 a0 b0 c0) []
+    }
 
 stepWith ::
   Monoid a =>
   SV.Vector 8 Instr ->
   -- | out
-  (Finite 8 -> Stepper a) ->
-  -- | next
-  Stepper a ->
-  Stepper a
-stepWith tp out next i !a !b !c = case tp `SV.index` i of
-  ADV r -> withStep next (a `div` (2 ^ combo r)) b c
-  BXL l -> withStep next a (b `xor` fromIntegral l) c
-  BST r -> withStep next a (combo r `mod` 8) c
-  JNZ l
-    | a == 0 -> withStep next 0 b c
-    | otherwise -> next (weakenN l) a b c
-  BXC -> withStep next a (b `xor` c) c
-  OUT r ->
-    let o = modulo (fromIntegral (combo r))
-     in withStep (out o) a b c
-  BDV r -> withStep next a (a `div` (2 ^ combo r)) c
-  CDV r -> withStep next a b (a `div` (2 ^ combo r))
+  (Finite 8 -> a) ->
+  Finite 8 ->
+  Word ->
+  Word ->
+  Word ->
+  a
+stepWith tp out = go
   where
-    combo = \case
-      CLiteral l -> fromIntegral l
-      CReg 0 -> a
-      CReg 1 -> b
-      CReg _ -> c
-    withStep p
-      | i == maxBound = \_ _ _ -> mempty
-      | otherwise = p (i + 1)
-
--- BST A    --- b = a & 111
--- BXL 6    --- b ^= 110    (6)
--- CDV B    --- c = a >> b
--- BXC      --- b ^= c
--- BXL 4    --- b ^= 100    (4)
--- OUT B    --- print b
--- ADV 3    --- a >> 3
--- JNZ 0
---
--- ok maybe we step from the back until the Out (to generate the options), and
--- then jump from the beginning to the out (to generate the constraints)
---
--- so "step backwards" from JNZ 2 to OUT B to generate all possible previous
--- values of a, then jump from BST A down to OUT B to limit which ones are
--- possible.
+    go i !a !b !c = case tp `SV.index` i of
+      ADV r -> withStep go (a `div` (2 ^ combo r)) b c
+      BXL l -> withStep go a (b `xor` fromIntegral l) c
+      BST r -> withStep go a (combo r `mod` 8) c
+      JNZ l
+        | a == 0 -> withStep go 0 b c
+        | otherwise -> go (weakenN l) a b c
+      BXC -> withStep go a (b `xor` c) c
+      OUT r ->
+        let o = modulo (fromIntegral (combo r))
+         in out o <> withStep go a b c
+      BDV r -> withStep go a (a `div` (2 ^ combo r)) c
+      CDV r -> withStep go a b (a `div` (2 ^ combo r))
+      where
+        combo = \case
+          CLiteral l -> fromIntegral l
+          CReg 0 -> a
+          CReg 1 -> b
+          CReg _ -> c
+        withStep p
+          | i == maxBound = \_ _ _ -> mempty
+          | otherwise = p (i + 1)
 
 searchStep :: SV.Vector 8 Instr -> [Finite 8] -> [Word]
 searchStep tp outs = do
@@ -190,9 +139,9 @@ searchStep tp outs = do
   search 0 (reverse outs)
   where
     stepForward :: Word -> Maybe (Finite 8)
-    stepForward a0 = getFirst <$> go' 0 a0 0 0
+    stepForward a0 = appEndo (go 0 a0 0 0) Nothing
       where
-        go' = stepWith tp (\o _ _ _ _ -> Just (First o)) go'
+        go = stepWith tp (Endo . const . Just)
     stepBack :: Word -> [Word]
     stepBack = go' maxBound
       where
@@ -205,270 +154,10 @@ searchStep tp outs = do
           OUT _ -> pure a
           _ -> go' (pred i) a
 
--- stepProg tp (V3 a0 b0 c0) = stepAll 0 a0 b0 c0
---   where
---     stepAll = stepWith tp (\o i a b c -> o : stepAll i a b c) stepAll
-
--- 0 undefined undefined
--- go' (o : os) = stepWith tp (\r i a b c -> guard (o == r) >> go' os i a b c) \i a b c ->
---     if i == 0
---        then go' (o:os) i a undefined undefined
---        else go' (o:os) i a b c
-
--- where
---   search a = \case
---     [] -> pure a
---     o : os -> do
---       a' <- ((a `shift` 3) +) <$> [0 .. 7]
---       let b0 = (a' .&. 7) `xor` 6
---       let c = a' `shift` (-b0)
---       guard $ ((b0 `xor` c) `xor` 4) .&. 7 == o
---       search a' os
-
--- -- | Assumes that:
--- --
--- -- 1. Only A is persistent across each "loop"
--- -- 2. The last instruction is a jump to 0
--- unstepProg :: SV.Vector 8 Instr -> [Finite 8] -> [Int]
--- unstepProg prog = unLoop jnzIx 0 Nothing Nothing
---   where
---     jnzIx :: Finite 8
---     jnzIx = maxBound
---     unLoop :: Finite 8 -> Word -> Maybe Word -> Maybe Word -> [Finite 8] -> [Int]
---     unLoop i a b c os = case prog `SV.index` i of
---       ADV r -> do
---         unshift <- fromIntegral <$> combo r
---         possibleUnshifts <- [0.. 2^unshift - 1]
---         withStep (a `shift` unshift + possibleUnshifts) b c os
---       BXL l -> do
---         b' <- maybeToList b
---         withStep a (Just $ b' `xor` fromIntegral l) c os
---       BST r -> case r of
---          CLiteral l -> do
---            for_ b \b' -> guard $ fromIntegral l == b'
---            withStep a b c os
---          CReg g -> do
---            possibleUnshift <- [0 .. 7]
---            let stored = fromMaybe 0 b `shift` 3 + possibleUnshift
---            case g of
---              0 -> withStep stored b c os
---              1 -> withStep a (Just stored) c os
---              _ -> withStep a b (Just stored) os
---       JNZ _
---         | a == 0    -> undefined
---         | otherwise -> undefined
---       BXC -> _
---         -- withStep a (b `xor` c) c
---       OUT r -> do
---         o:os' <- pure os
---         let setModulo x = ((x `shift` (-3)) `shift` 3) + fromIntegral o
---         case r of
---           CLiteral l -> do
---             guard $ weakenN l == o
---             withStep a b c os'
---           CReg 0 -> withStep (setModulo a) b c os'
---           CReg 1 -> withStep a (Just $ maybe (fromIntegral o) setModulo b) c os'
---           CReg _ -> withStep a b (Just $ maybe (fromIntegral o) setModulo c) os'
---       where
---         combo = \case
---           CLiteral l -> [fromIntegral l]
---           CReg 0 -> pure a
---           CReg 1 -> maybeToList b   -- hmm could really be anything
---           CReg _ -> maybeToList c   -- hmm could really be anything
---         withStep
---           | i == minBound = undefined
---           | otherwise = unLoop (pred i)
-
--- search 0
--- where
---   search a = \case
---     [] -> pure a
---     o : os -> do
---       a' <- ((a `shift` 3) +) <$> [0 .. 7]
---       let b0 = (a' .&. 7) `xor` 6
---       let c = a' `shift` (-b0)
---       guard $ modulo (fromIntegral $ (b0 `xor` c) `xor` 4) == o
---       search a' os
-
--- 2,4, 1,6, 7,5, 4,6, 1,4, 5,5, 0,3, 3,0
---
--- BST A    --- b = (a `mod` 8)
--- BXL 6    --- b ^= 110    (6)
--- CDV B    --- c = a / (2^b)
--- BXC      --- b ^= c
--- BXL 4    --- b ^= 100    (4)
--- OUT B    --- print b
--- ADV 3    --- a /= 8
--- JNZ 0
-
--- 2,4, 1,6, 7,5, 4,6, 1,4, 5,5, 0,3, 3,0
---
--- BST A    --- b = a & 111
--- BXL 6    --- b ^= 110    (6)
--- CDV B    --- c = a >> b
--- BXC      --- b ^= c
--- BXL 4    --- b ^= 100    (4)
--- OUT B    --- print b
--- ADV 3    --- a >> 3
--- JNZ 0
-
--- The *`adv`* instruction (opcode *`0`*) performs *division*. The
--- numerator is the value in the `A` register. The denominator is found by
--- raising 2 to the power of the instruction's *combo* operand. (So, an
--- operand of `2` would divide `A` by `4` (`2^2`); an operand of `5` would
--- divide `A` by `2^B`.) The result of the division operation is
-
--- * truncated* to an integer and then written to the `A` register.
-
--- The *`bxl`* instruction (opcode *`1`*) calculates the [bitwise
--- XOR](https://en.wikipedia.org/wiki/Bitwise_operation#XOR){target="_blank"}
--- of register `B` and the instruction's *literal* operand, then stores the
--- result in register `B`.
-
--- The *`bst`* instruction (opcode *`2`*) calculates the value of its
-
--- * combo* operand
-
--- [modulo](https://en.wikipedia.org/wiki/Modulo){target="_blank"} 8
--- (thereby keeping only its lowest 3 bits), then writes that value to the
--- `B` register.
-
--- The *`jnz`* instruction (opcode *`3`*) does *nothing* if the `A`
--- register is `0`. However, if the `A` register is *not zero*, it
--- [*jumps*]{title="The instruction does this using a little trampoline."}
--- by setting the instruction pointer to the value of its *literal*
--- operand; if this instruction jumps, the instruction pointer is *not*
--- increased by `2` after this instruction.
-
--- The *`bxc`* instruction (opcode *`4`*) calculates the *bitwise XOR* of
--- register `B` and register `C`, then stores the result in register `B`.
--- (For legacy reasons, this instruction reads an operand but *ignores*
--- it.)
-
--- The *`out`* instruction (opcode *`5`*) calculates the value of its
-
--- * combo* operand modulo 8, then *outputs* that value. (If a program
-
--- outputs multiple values, they are separated by commas.)
-
--- The *`bdv`* instruction (opcode *`6`*) works exactly like the `adv`
--- instruction except that the result is stored in the *`B` register*. (The
--- numerator is still read from the `A` register.)
-
--- The *`cdv`* instruction (opcode *`7`*) works exactly like the `adv`
--- instruction except that the result is stored in the *`C` register*. (The
--- numerator is still read from the `A` register.)
--- --
-
-day17b :: _ :~> _
+day17b :: (Word, Word, Word, SV.Vector 8 Instr, [Finite 8]) :~> Word
 day17b =
-  -- MkSol
-    -- { sParse = parseMaybe' do
-    --     _ <- "Register A: " *> pDecimal @Int
-    --     P.newline
-    --     _ <- "Register B: " *> pDecimal @Int
-    --     P.newline
-    --     _ <- "Register C: " *> pDecimal @Int
-    --     P.newline
-    --     P.newline
-    --     "Program: " *> (pDecimal `sepBy'` ",")
-    -- , sShow = show
-    -- , sSolve =
-    --     \p -> listToMaybe do
-    --       option <- stepBackwards (reverse p)
-    --       guard $ go 0 (V3 option 0 0) (Seq.fromList p) == p
-    --       pure option
   MkSol
-    { sParse = sParse day17a 
-    , sShow = show 
-    , sSolve = \(_, _, _, instrs, o) -> listToMaybe $
-        searchStep instrs o
--- searchStep :: SV.Vector 8 Instr -> [Finite 8] -> [Word]
--- searchStep tp outs = do
-
-        -- pure . map fromIntegral $ stepProg instrs (V3 a b c)
+    { sParse = sParse day17a
+    , sShow = show
+    , sSolve = \(_, _, _, instrs, o) -> listToMaybe $ searchStep instrs o
     }
-
-go :: Int -> V3 Int -> Seq Int -> [Int]
--- go i (V3 a b c) tp = case (,) <$> Seq.lookup i tp <*> Seq.lookup (i + 1) tp of
-go i (V3 a b c) tp = case (,) <$> Seq.lookup i tp <*> Seq.lookup (i + 1) tp of
-  Nothing -> []
-  Just (q, o) ->
-    let x = case o of
-          0 -> 0
-          1 -> 1
-          2 -> 2
-          3 -> 3
-          4 -> a
-          5 -> b
-          6 -> c
-     in case q of
-          0 -> go (i + 2) (V3 (a `div` (2 ^ x)) b c) tp
-          1 -> go (i + 2) (V3 a (b `xor` o) c) tp
-          2 -> go (i + 2) (V3 a (x `mod` 8) c) tp
-          3
-            | a == 0 -> go (i + 2) (V3 a b c) tp
-            | otherwise -> go o (V3 a b c) tp
-          4 -> go (i + 2) (V3 a (b `xor` c) c) tp
-          5 -> (x `mod` 8) : go (i + 2) (V3 a b c) tp
-          -- 5 -> trace (show (x `mod` 8, o, x)) (x `mod` 8) : go (i + 2) (V3 a b c) tp
-          6 -> go (i + 2) (V3 a (a `div` (2 ^ x)) c) tp
-          7 -> go (i + 2) (V3 a b (a `div` (2 ^ x))) tp
-
--- [ (go 0 (V3 i b c) (Seq.fromList p))
--- -- | i <- [45184372088832]
--- \| i <- [1999]
--- ]
-
-stepBackwards :: [Int] -> [Int]
-stepBackwards = search 0
-  where
-    search a = \case
-      [] -> pure a
-      o : os -> do
-        a' <- ((a `shift` 3) +) <$> [0 .. 7]
-        let b0 = (a' .&. 7) `xor` 6
-        let c = a' `shift` (-b0)
-        guard $ ((b0 `xor` c) `xor` 4) .&. 7 == o
-        search a' os
-
--- traceM $ show $ V3 last10A last3B last7C
--- pure ()
-
--- CDV B    --- c = a / (2^b)
--- BXC      --- b ^= c
---
--- c = a / (2^b0)
--- b = b0 ^ c
---
--- b = b0 ^ (a >> b0)
---
--- b = (b0 ^ 110) ^ (a >> (b0 ^ 110))
---
--- b = ((a `mod` 8) ^ 110) ^ (a >> ((a `mod` 8) ^ 110))
---
--- mod 8 is & 111
---
--- b & 111 = ((a & 111) ^ 110) ^ (a >> ((a & 111) ^ 110))
--- b & 111 = ((a ^ 110) & 111) ^ (a >> ((a ^ 110) & 111))
---
--- i guess we can do a search for what (a & 111) is, it's only 7 possible
--- items. But how do we get from that to the full A?
---
--- Ah hah i guess we can store the rest of the A trit-by-trit.
---
---
---
-
--- stepBackwards r@(V3 a b c) = \case
---   [] -> r
---   x:xs ->
-
--- BST A    --- b = (a `mod` 8)
--- BXL 6    --- b ^= 110    (6)
--- CDV B    --- c = a >> b
--- BXC      --- b ^= c
--- BXL 4    --- b ^= 100    (4)
--- OUT B    --- print (b `mod` 8)
--- ADV 3    --- a /= 8
--- JNZ 0

From 0a2219aabfe4ddf96defcf44fc80e6a43b92ca33 Mon Sep 17 00:00:00 2001
From: justin <justin@jle.im>
Date: Fri, 17 Jan 2025 00:40:43 -0800
Subject: [PATCH 38/43] clean up day 17

---
 2024/AOC2024/Day17.hs | 5 ++---
 1 file changed, 2 insertions(+), 3 deletions(-)

diff --git a/2024/AOC2024/Day17.hs b/2024/AOC2024/Day17.hs
index ee7f2dd..79cbc2d 100644
--- a/2024/AOC2024/Day17.hs
+++ b/2024/AOC2024/Day17.hs
@@ -30,6 +30,7 @@ import Data.Finite (
 import Data.Foldable (Foldable (toList))
 import Data.List (intercalate)
 import Data.Maybe (listToMaybe)
+import Data.Monoid (Alt (..))
 import Data.Semigroup (Endo (Endo, appEndo))
 import qualified Data.Vector.Sized as SV
 import qualified Text.Megaparsec.Char as P
@@ -139,9 +140,7 @@ searchStep tp outs = do
   search 0 (reverse outs)
   where
     stepForward :: Word -> Maybe (Finite 8)
-    stepForward a0 = appEndo (go 0 a0 0 0) Nothing
-      where
-        go = stepWith tp (Endo . const . Just)
+    stepForward a0 = getAlt $ stepWith tp (Alt . Just) 0 a0 0 0
     stepBack :: Word -> [Word]
     stepBack = go' maxBound
       where

From 0128ceaf8981889c5e0a6efa967b66412c2d0c3c Mon Sep 17 00:00:00 2001
From: justin <justin@jle.im>
Date: Sun, 19 Jan 2025 17:11:48 -0800
Subject: [PATCH 39/43] day 17 reflections

---
 2024/AOC2024/Day17.hs     |  22 ++++---
 reflections/2024/day17.md | 135 ++++++++++++++++++++++++++++++++++++++
 2 files changed, 147 insertions(+), 10 deletions(-)
 create mode 100644 reflections/2024/day17.md

diff --git a/2024/AOC2024/Day17.hs b/2024/AOC2024/Day17.hs
index 79cbc2d..a8b97ae 100644
--- a/2024/AOC2024/Day17.hs
+++ b/2024/AOC2024/Day17.hs
@@ -89,7 +89,7 @@ day17a =
         pure (a, b, c, p, fromIntegral <$> d)
     , sShow = intercalate "," . map (show . getFinite)
     , sSolve = noFail \(a0, b0, c0, instrs, _) ->
-        appEndo (stepWith instrs (Endo . (:)) 0 a0 b0 c0) []
+        appEndo (stepWith instrs (Endo . (:)) a0 b0 c0) []
     }
 
 stepWith ::
@@ -97,12 +97,14 @@ stepWith ::
   SV.Vector 8 Instr ->
   -- | out
   (Finite 8 -> a) ->
-  Finite 8 ->
+  -- | Starting a
   Word ->
+  -- | Starting b
   Word ->
+  -- | Starting c
   Word ->
   a
-stepWith tp out = go
+stepWith tp out = go 0
   where
     go i !a !b !c = case tp `SV.index` i of
       ADV r -> withStep go (a `div` (2 ^ combo r)) b c
@@ -131,16 +133,16 @@ searchStep :: SV.Vector 8 Instr -> [Finite 8] -> [Word]
 searchStep tp outs = do
   JNZ 0 <- pure $ tp `SV.index` maxBound
   [CReg _] <- pure [r | OUT r <- toList tp]
-  let search a = \case
-        o : os -> do
-          a' <- stepBack a
-          guard $ stepForward a' == Just o
-          search a' os
-        [] -> pure a
   search 0 (reverse outs)
   where
+    search a = \case
+      o : os -> do
+        a' <- stepBack a
+        guard $ stepForward a' == Just o
+        search a' os
+      [] -> pure a
     stepForward :: Word -> Maybe (Finite 8)
-    stepForward a0 = getAlt $ stepWith tp (Alt . Just) 0 a0 0 0
+    stepForward a0 = getAlt $ stepWith tp (Alt . Just) a0 0 0
     stepBack :: Word -> [Word]
     stepBack = go' maxBound
       where
diff --git a/reflections/2024/day17.md b/reflections/2024/day17.md
new file mode 100644
index 0000000..79c0449
--- /dev/null
+++ b/reflections/2024/day17.md
@@ -0,0 +1,135 @@
+This one is a cute little interpreter problem, a staple of advent of code.
+Let's write Part 1 in a way that makes Part 2 easy, where we will have to
+eventually "run" it backwards. We can use `Finite n` as the type with `n`
+inhabitants, so `Finite 8` will, for example, have the numbers 0 to 7. And also
+`Vector n a` from `Data.Vector.Sized`, which contains `n` items.
+
+```haskell
+data Combo
+  = CLiteral (Finite 4)
+  | CReg (Finite 3)
+
+data Instr
+  = ADV Combo
+  | BXL (Finite 8)
+  | BST Combo
+  | JNZ (Finite 4)
+  | BXC
+  | OUT Combo
+  | BDV Combo
+  | CDV Combo
+```
+
+We can then write a function to interpret the outputs into a monoid.
+
+```haskell
+stepWith ::
+  Monoid a =>
+  Vector 8 Instr ->
+  -- | out
+  (Finite 8 -> a) ->
+  -- | Starting a
+  Word ->
+  -- | Starting b
+  Word ->
+  -- | Starting c
+  Word ->
+  a
+stepWith prog out = go 0
+  where
+    go i !a !b !c = case prog `SV.index` i of
+      ADV r -> withStep go (a `div` (2 ^ combo r)) b c
+      BXL l -> withStep go a (b `xor` fromIntegral l) c
+      BST r -> withStep go a (combo r `mod` 8) c
+      JNZ l
+        | a == 0 -> withStep go 0 b c
+        | otherwise -> go (weakenN l) a b c   -- weakenN :: Finite 4 -> Finite 8
+      BXC -> withStep go a (b `xor` c) c
+      OUT r ->
+        let o = modulo (fromIntegral (combo r))
+         in out o <> withStep go a b c
+      BDV r -> withStep go a (a `div` (2 ^ combo r)) c
+      CDV r -> withStep go a b (a `div` (2 ^ combo r))
+      where
+        combo = \case
+          CLiteral l -> fromIntegral l
+          CReg 0 -> a
+          CReg 1 -> b
+          CReg _ -> c
+        withStep p
+          | i == maxBound = \_ _ _ -> mempty
+          | otherwise = p (i + 1)
+```
+
+Part 1 is a straightforward application, although we can use a difflist to get
+O(n) concats instead of O(n^2)
+
+```haskell
+import Data.DList as DL
+
+part1 :: Vector 8 Instr -> Word -> Word -> Word -> [Finite 8]
+part1 prog a b c = DL.toList $ stepWith prog DL.singleton a b c
+```
+
+Part 2 it gets a bit interesting. We can solve it "in general" under the
+conditions:
+
+
+1.  The final instruction is JNZ 0
+2.  There is one `OUT` per loop, with a register
+3.  b and c are overwritten at the start of each loop
+
+The plan would be:
+
+
+1.  Start from the end with a known `a` and move backwards, accumulating all
+    possible values of `a` that would lead to the end value, ignoring b and c
+2.  For each of those possible a's, start from the beginning with that `a` and
+    filter the ones that don't produce the correct `OUT`.
+
+We have to write a "step backwards" from scratch, but we can actually use our
+original `stepWith` to write a version that _bails_ after the first output, by
+having our monoid be `Data.Monoid.First`. Then in the line `out o <> withStep
+go a abc`, it'll just completely ignore the right hand side and output the
+first `OUT` result.
+
+```haskell
+searchStep :: Vector 8 Instr -> [Finite 8] -> [Word]
+searchStep prog outs = do
+  -- enforce the invariants
+  JNZ 0 <- pure $ prog `SV.index` maxBound
+  [CReg _] <- pure [r | OUT r <- toList prog]
+  search 0 (reverse outs)
+  where
+    search a = \case
+      o : os -> do
+        a' <- stepBack a
+        guard $ stepForward a' == Just o
+        search a' os
+      [] -> pure a
+    -- doesn't enforce that b and c are reset, because i'm lazy
+    stepForward :: Word -> Maybe (Finite 8)
+    stepForward a0 = getFirst $ stepWith tp (First . Just) a0 0 0
+    stepBack :: Word -> [Word]
+    stepBack = go' maxBound
+      where
+        go' i a = case tp `SV.index` i of
+          ADV r -> do
+            a' <- case r of
+              CLiteral l -> ((a `shift` fromIntegral l) +) <$> [0 .. 2 ^ getFinite l - 1]
+              CReg _ -> []
+            go' (pred i) a'
+          OUT _ -> pure a
+          _ -> go' (pred i) a
+```
+
+We really only have to handle the `ADV r` case because that's the only
+instruction that modifies `A`. If we `ADV 3`, that means that the possible
+"starting A's" are `known_a * 8 + x`, where `x` is between 0 and 7.
+
+Wrapping it all up:
+
+```haskell
+part2 :: Vector 8 Instr -> [Finite 8] -> Maybe Word
+part2 instrs = listToMaybe . searchStep instrs
+```

From 7e3f0b05124bc488ee62672da118cf8a17f008fc Mon Sep 17 00:00:00 2001
From: justin <justin@jle.im>
Date: Mon, 20 Jan 2025 19:22:26 -0800
Subject: [PATCH 40/43] day 24 better with stable names

---
 2024/AOC2024/Day24.hs | 86 ++++++++++++++++++++++---------------------
 1 file changed, 44 insertions(+), 42 deletions(-)

diff --git a/2024/AOC2024/Day24.hs b/2024/AOC2024/Day24.hs
index b3c801e..3c605e8 100644
--- a/2024/AOC2024/Day24.hs
+++ b/2024/AOC2024/Day24.hs
@@ -6,23 +6,27 @@
 -- Portability : non-portable
 --
 -- Day 24.  See "AOC.Solver" for the types used in this module!
-module AOC2024.Day24 (
-  day24a,
-  day24b,
-)
+module AOC2024.Day24
 where
 
+-- (
+-- day24a,
+-- day24b,
+-- )
+
 import AOC.Common (asString, loopEither, parseBinary)
 import AOC.Common.Parser (CharParser, pAlphaNumWord, parseMaybe', sepByLines, tokenAssoc)
 import AOC.Solver (noFail, type (:~>) (..))
 import Control.Applicative (Alternative (empty, many))
 import Control.DeepSeq (NFData)
-import Control.Lens ((%=))
+import Control.Lens
 import Control.Monad.Free (Free, MonadFree (wrap), iterA)
-import Control.Monad.Logic (LogicT, MonadLogic (interleave), observeT)
-import Control.Monad.State (MonadState (get, put), State, StateT, execState, execStateT)
+import Control.Monad.Logic
+import Control.Monad.State
 import Data.Bifunctor (Bifunctor (second))
+import Data.Either
 import Data.Foldable (Foldable (toList))
+import Data.Functor
 import Data.Generics.Labels ()
 import Data.IntMap (IntMap)
 import qualified Data.IntMap as IM
@@ -32,6 +36,7 @@ import qualified Data.List.NonEmpty as NE
 import Data.Map (Map)
 import qualified Data.Map as M
 import Data.Tuple (swap)
+import Debug.Trace
 import GHC.Generics (Generic)
 import qualified Text.Megaparsec as P
 import qualified Text.Megaparsec.Char as P
@@ -146,16 +151,17 @@ unrollGates = iterA go . fmap Right
           pure $ Left currIx
         Just i -> pure $ Left i
 
-unrollAdderTree :: Int -> IntMap (Gate (Either Int VarBit))
-unrollAdderTree n = IM.fromList $ swap <$> M.toList mp
+unrollAdderTree :: Int -> ([Int], IntMap (Gate (Either Int VarBit)))
+unrollAdderTree n = (lefts $ toList outs, IM.fromList $ swap <$> M.toList mp)
   where
     (carry, adder) = adderTree n
-    full = carry `NE.cons` adder
-    (_, mp) = execState (traverse unrollGates full) (0, M.empty)
+    full = NE.reverse $ carry `NE.cons` adder
+    (outs, (_, mp)) = runState (traverse unrollGates full) (0, M.empty)
 
 data NameState = NS
   { nsRenames :: Map String String
   , nsNames :: IntMap String
+  , nsFound :: Bool
   }
   deriving stock (Generic, Show, Eq, Ord)
   deriving anyclass (NFData)
@@ -163,52 +169,48 @@ data NameState = NS
 nameGate ::
   Map (Gate String) String ->
   Int ->
-  Int ->
   Gate (Either Int VarBit) ->
-  LogicT (StateT NameState Maybe) String
-nameGate avail renameLimit ng g0 = do
+  LogicT (StateT NameState Maybe) ()
+nameGate avail ng g0 = do
   NS{..} <- get
   let gate = either (nsNames IM.!) showVarBit <$> g0
-  Just here <- pure $ applySwaps nsRenames <$> M.lookup gate avail
-  (here <$ (#nsNames %= IM.insert ng here))
-    `interleave` foldr
-      interleave
-      empty
-      [ there <$ put (NS renames (IM.insert ng there nsNames))
-      | here `M.notMember` nsRenames
-      , here `notElem` nsNames
-      , M.size nsRenames < renameLimit
-      , there <- toList avail
-      , here /= there
-      , there `M.notMember` nsRenames
-      , there `notElem` nsNames
-      , let renames = M.fromList [(here, there), (there, here)] <> nsRenames
-      ]
+  case applySwaps nsRenames <$> M.lookup gate avail of
+    Nothing -> empty
+    Just here ->
+      (#nsNames %= IM.insert ng here)
+        `interleave` foldr
+          interleave
+          empty
+          [ put (NS renames (IM.insert ng there nsNames) True)
+          | not nsFound
+          , here `M.notMember` nsRenames
+          , here `notElem` nsNames
+          , there <- toList avail
+          , here /= there
+          , there `M.notMember` nsRenames
+          , there `notElem` nsNames
+          , let renames = M.fromList [(here, there), (there, here)] <> nsRenames
+          ]
   where
     applySwaps :: Map String String -> String -> String
     applySwaps mp x = M.findWithDefault x x mp
 
 nameTree ::
   Map (Gate String) String ->
-  Map String String ->
-  IntMap (Gate (Either Int VarBit)) ->
   Maybe (Map String String)
-nameTree avail renames0 =
-  fmap nsRenames
-    . flip execStateT s0
-    . observeT
-    . IM.traverseWithKey (nameGate avail (min 8 $ M.size renames0 + 2))
+nameTree avail = nsRenames <$> execStateT (observeT (traverse go outGates)) s0
   where
-    s0 = NS renames0 IM.empty
+    s0 = NS M.empty IM.empty False
+    (outGates, gates) = unrollAdderTree 44
+    go outGate = do
+      #nsFound .= False
+      IM.traverseWithKey (nameGate avail) $
+        IM.takeWhileAntitone (<= outGate) gates
 
 day24b :: [(Gate String, String)] :~> [String]
 day24b =
   MkSol
     { sParse = fmap snd . sParse day24a
     , sShow = intercalate ","
-    , sSolve = noFail \xs ->
-        flip loopEither (0, M.empty) \(i, subs) ->
-          case nameTree (M.fromList xs) subs (unrollAdderTree i) of
-            Nothing -> Left $ M.keys subs
-            Just subs' -> Right (i + 1, subs')
+    , sSolve = fmap M.keys . nameTree . M.fromList
     }

From 0b4243ce6d696025bc1fc00aba78f3f97f283399 Mon Sep 17 00:00:00 2001
From: justin <justin@jle.im>
Date: Mon, 20 Jan 2025 19:41:21 -0800
Subject: [PATCH 41/43] more day 24 cleanup, from 1.7s to 10ms

---
 2024/AOC2024/Day24.hs | 40 +++++++++++++++-------------------------
 1 file changed, 15 insertions(+), 25 deletions(-)

diff --git a/2024/AOC2024/Day24.hs b/2024/AOC2024/Day24.hs
index 3c605e8..7227b82 100644
--- a/2024/AOC2024/Day24.hs
+++ b/2024/AOC2024/Day24.hs
@@ -6,27 +6,23 @@
 -- Portability : non-portable
 --
 -- Day 24.  See "AOC.Solver" for the types used in this module!
-module AOC2024.Day24
+module AOC2024.Day24 (
+  day24a,
+  day24b,
+)
 where
 
--- (
--- day24a,
--- day24b,
--- )
-
-import AOC.Common (asString, loopEither, parseBinary)
+import AOC.Common (asString, parseBinary)
 import AOC.Common.Parser (CharParser, pAlphaNumWord, parseMaybe', sepByLines, tokenAssoc)
 import AOC.Solver (noFail, type (:~>) (..))
-import Control.Applicative (Alternative (empty, many))
+import Control.Applicative (Alternative (empty, many, (<|>)), asum)
 import Control.DeepSeq (NFData)
-import Control.Lens
+import Control.Lens ((%=), (.=))
 import Control.Monad.Free (Free, MonadFree (wrap), iterA)
-import Control.Monad.Logic
-import Control.Monad.State
+import Control.Monad.State (MonadState (get, put), State, StateT, execStateT, runState)
 import Data.Bifunctor (Bifunctor (second))
-import Data.Either
+import Data.Either (lefts)
 import Data.Foldable (Foldable (toList))
-import Data.Functor
 import Data.Generics.Labels ()
 import Data.IntMap (IntMap)
 import qualified Data.IntMap as IM
@@ -35,8 +31,8 @@ import Data.List.NonEmpty (NonEmpty (..))
 import qualified Data.List.NonEmpty as NE
 import Data.Map (Map)
 import qualified Data.Map as M
+import Data.Maybe (listToMaybe)
 import Data.Tuple (swap)
-import Debug.Trace
 import GHC.Generics (Generic)
 import qualified Text.Megaparsec as P
 import qualified Text.Megaparsec.Char as P
@@ -170,7 +166,7 @@ nameGate ::
   Map (Gate String) String ->
   Int ->
   Gate (Either Int VarBit) ->
-  LogicT (StateT NameState Maybe) ()
+  StateT NameState [] ()
 nameGate avail ng g0 = do
   NS{..} <- get
   let gate = either (nsNames IM.!) showVarBit <$> g0
@@ -178,17 +174,11 @@ nameGate avail ng g0 = do
     Nothing -> empty
     Just here ->
       (#nsNames %= IM.insert ng here)
-        `interleave` foldr
-          interleave
-          empty
+        <|> asum
           [ put (NS renames (IM.insert ng there nsNames) True)
           | not nsFound
-          , here `M.notMember` nsRenames
-          , here `notElem` nsNames
           , there <- toList avail
           , here /= there
-          , there `M.notMember` nsRenames
-          , there `notElem` nsNames
           , let renames = M.fromList [(here, there), (there, here)] <> nsRenames
           ]
   where
@@ -197,8 +187,8 @@ nameGate avail ng g0 = do
 
 nameTree ::
   Map (Gate String) String ->
-  Maybe (Map String String)
-nameTree avail = nsRenames <$> execStateT (observeT (traverse go outGates)) s0
+  [Map String String]
+nameTree avail = nsRenames <$> execStateT (traverse go outGates) s0
   where
     s0 = NS M.empty IM.empty False
     (outGates, gates) = unrollAdderTree 44
@@ -212,5 +202,5 @@ day24b =
   MkSol
     { sParse = fmap snd . sParse day24a
     , sShow = intercalate ","
-    , sSolve = fmap M.keys . nameTree . M.fromList
+    , sSolve = fmap M.keys . listToMaybe . nameTree . M.fromList
     }

From 5ca31d793677516f1d6964ca42f16a042c4a304c Mon Sep 17 00:00:00 2001
From: justin <justin@jle.im>
Date: Mon, 20 Jan 2025 20:00:41 -0800
Subject: [PATCH 42/43] early short circuit, down to 3ms

---
 2024/AOC2024/Day24.hs | 41 ++++++++++++++++++++---------------------
 1 file changed, 20 insertions(+), 21 deletions(-)

diff --git a/2024/AOC2024/Day24.hs b/2024/AOC2024/Day24.hs
index 7227b82..31d10a8 100644
--- a/2024/AOC2024/Day24.hs
+++ b/2024/AOC2024/Day24.hs
@@ -15,11 +15,10 @@ where
 import AOC.Common (asString, parseBinary)
 import AOC.Common.Parser (CharParser, pAlphaNumWord, parseMaybe', sepByLines, tokenAssoc)
 import AOC.Solver (noFail, type (:~>) (..))
-import Control.Applicative (Alternative (empty, many, (<|>)), asum)
 import Control.DeepSeq (NFData)
-import Control.Lens ((%=), (.=))
+import Control.Monad ((>=>))
 import Control.Monad.Free (Free, MonadFree (wrap), iterA)
-import Control.Monad.State (MonadState (get, put), State, StateT, execStateT, runState)
+import Control.Monad.State (MonadState (get, put), State, runState)
 import Data.Bifunctor (Bifunctor (second))
 import Data.Either (lefts)
 import Data.Foldable (Foldable (toList))
@@ -72,7 +71,7 @@ parseGate = do
   pure Gate{..}
 
 parseInitial :: CharParser (String, Bool)
-parseInitial = (,) <$> many P.alphaNumChar <* ": " <*> tokenAssoc [('0', False), ('1', True)]
+parseInitial = (,) <$> P.many P.alphaNumChar <* ": " <*> tokenAssoc [('0', False), ('1', True)]
 
 applyOp :: Op -> Bool -> Bool -> Bool
 applyOp = \case
@@ -166,36 +165,36 @@ nameGate ::
   Map (Gate String) String ->
   Int ->
   Gate (Either Int VarBit) ->
-  StateT NameState [] ()
-nameGate avail ng g0 = do
-  NS{..} <- get
-  let gate = either (nsNames IM.!) showVarBit <$> g0
+  NameState ->
+  [NameState]
+nameGate avail ng g0 NS{..} =
   case applySwaps nsRenames <$> M.lookup gate avail of
-    Nothing -> empty
+    Nothing -> []
     Just here ->
-      (#nsNames %= IM.insert ng here)
-        <|> asum
-          [ put (NS renames (IM.insert ng there nsNames) True)
+      NS{nsNames = IM.insert ng here nsNames, ..}
+        : [ NS renames (IM.insert ng there nsNames) True
           | not nsFound
           , there <- toList avail
           , here /= there
           , let renames = M.fromList [(here, there), (there, here)] <> nsRenames
           ]
   where
-    applySwaps :: Map String String -> String -> String
+    gate = either (nsNames IM.!) showVarBit <$> g0
     applySwaps mp x = M.findWithDefault x x mp
 
-nameTree ::
-  Map (Gate String) String ->
-  [Map String String]
-nameTree avail = nsRenames <$> execStateT (traverse go outGates) s0
+nameTree :: Map (Gate String) String -> [Map String String]
+nameTree avail = nsRenames <$> foldr (\o -> (go o >=>)) pure outGates s0
   where
     s0 = NS M.empty IM.empty False
     (outGates, gates) = unrollAdderTree 44
-    go outGate = do
-      #nsFound .= False
-      IM.traverseWithKey (nameGate avail) $
-        IM.takeWhileAntitone (<= outGate) gates
+    go outGate ns0
+      | M.size (nsRenames ns0) == 8 = [ns0]
+      | otherwise =
+          IM.foldrWithKey
+            (\k g -> (nameGate avail k g >=>))
+            pure
+            (IM.takeWhileAntitone (<= outGate) gates)
+            (ns0{nsFound = False})
 
 day24b :: [(Gate String, String)] :~> [String]
 day24b =

From 99ed07731b15ee2e17b8b6979cf8f9ed2d1dfe53 Mon Sep 17 00:00:00 2001
From: justin <justin@jle.im>
Date: Mon, 20 Jan 2025 22:20:24 -0800
Subject: [PATCH 43/43] day 24 reflections

---
 2024/AOC2024/Day24.hs        |  40 +++-------
 bench-results/2024/day24.txt |  20 ++---
 reflections/2024/day24.md    | 145 +++++++++++++++++++++++++++++++++++
 3 files changed, 164 insertions(+), 41 deletions(-)
 create mode 100644 reflections/2024/day24.md

diff --git a/2024/AOC2024/Day24.hs b/2024/AOC2024/Day24.hs
index 31d10a8..e9eb59c 100644
--- a/2024/AOC2024/Day24.hs
+++ b/2024/AOC2024/Day24.hs
@@ -12,7 +12,6 @@ module AOC2024.Day24 (
 )
 where
 
-import AOC.Common (asString, parseBinary)
 import AOC.Common.Parser (CharParser, pAlphaNumWord, parseMaybe', sepByLines, tokenAssoc)
 import AOC.Solver (noFail, type (:~>) (..))
 import Control.DeepSeq (NFData)
@@ -25,7 +24,7 @@ import Data.Foldable (Foldable (toList))
 import Data.Generics.Labels ()
 import Data.IntMap (IntMap)
 import qualified Data.IntMap as IM
-import Data.List (intercalate, isPrefixOf)
+import Data.List (intercalate)
 import Data.List.NonEmpty (NonEmpty (..))
 import qualified Data.List.NonEmpty as NE
 import Data.Map (Map)
@@ -82,7 +81,7 @@ applyOp = \case
 applyGate :: Gate Bool -> Bool
 applyGate Gate{..} = applyOp gOp gX gY
 
-day24a :: ([(String, Bool)], [(Gate String, String)]) :~> _
+day24a :: ([(String, Bool)], [(Gate String, String)]) :~> Int
 day24a =
   MkSol
     { sParse = parseMaybe' do
@@ -95,25 +94,9 @@ day24a =
         noFail \(st, xs) ->
           let rules = M.fromList $ swap <$> xs
               res = M.fromList st <> (applyGate . fmap (res M.!) <$> rules)
-           in parseBinary . reverse . toList $ M.filterWithKey (\k _ -> "z" `isPrefixOf` k) res
+           in sum [2 ^ read @Int n | ('z' : n, True) <- M.toList res]
     }
 
-data Var = VX | VY | VZ
-  deriving stock (Eq, Ord, Show, Generic)
-  deriving anyclass (NFData)
-
-data VarBit = VB {vbVar :: Var, vbBit :: Int}
-  deriving stock (Eq, Ord, Show, Generic)
-  deriving anyclass (NFData)
-
-showVarBit :: VarBit -> String
-showVarBit VB{..} = printf (asString "%s%02d") vstr vbBit
-  where
-    vstr = asString case vbVar of
-      VX -> "x"
-      VY -> "y"
-      VZ -> "z"
-
 type GateTree = Free Gate
 
 halfAdder :: GateTree a -> GateTree a -> (GateTree a, GateTree a)
@@ -125,12 +108,12 @@ fullAdder x y carry0 = (wrap $ Gate OOr carry1 carry2, o)
     (carry1, z) = halfAdder x y
     (carry2, o) = halfAdder z carry0
 
-adderTree :: Int -> (GateTree VarBit, NonEmpty (GateTree VarBit))
+adderTree :: Int -> (GateTree String, NonEmpty (GateTree String))
 adderTree n
-  | n == 0 = (:| []) `second` halfAdder (pure (VB VX 0)) (pure (VB VY 0))
+  | n == 0 = (:| []) `second` halfAdder (pure "x00") (pure "y00")
   | otherwise =
       let (carryIn, rest) = adderTree (n - 1)
-          (carryOut, new) = fullAdder (pure (VB VX n)) (pure (VB VY n)) carryIn
+          (carryOut, new) = fullAdder (pure (printf "x%02d" n)) (pure (printf "y%02d" n)) carryIn
        in (carryOut, new `NE.cons` rest)
 
 unrollGates ::
@@ -146,7 +129,7 @@ unrollGates = iterA go . fmap Right
           pure $ Left currIx
         Just i -> pure $ Left i
 
-unrollAdderTree :: Int -> ([Int], IntMap (Gate (Either Int VarBit)))
+unrollAdderTree :: Int -> ([Int], IntMap (Gate (Either Int String)))
 unrollAdderTree n = (lefts $ toList outs, IM.fromList $ swap <$> M.toList mp)
   where
     (carry, adder) = adderTree n
@@ -161,12 +144,7 @@ data NameState = NS
   deriving stock (Generic, Show, Eq, Ord)
   deriving anyclass (NFData)
 
-nameGate ::
-  Map (Gate String) String ->
-  Int ->
-  Gate (Either Int VarBit) ->
-  NameState ->
-  [NameState]
+nameGate :: Map (Gate String) String -> Int -> Gate (Either Int String) -> NameState -> [NameState]
 nameGate avail ng g0 NS{..} =
   case applySwaps nsRenames <$> M.lookup gate avail of
     Nothing -> []
@@ -179,7 +157,7 @@ nameGate avail ng g0 NS{..} =
           , let renames = M.fromList [(here, there), (there, here)] <> nsRenames
           ]
   where
-    gate = either (nsNames IM.!) showVarBit <$> g0
+    gate = either (nsNames IM.!) id <$> g0
     applySwaps mp x = M.findWithDefault x x mp
 
 nameTree :: Map (Gate String) String -> [Map String String]
diff --git a/bench-results/2024/day24.txt b/bench-results/2024/day24.txt
index 9acdc7c..1a2cbc3 100644
--- a/bench-results/2024/day24.txt
+++ b/bench-results/2024/day24.txt
@@ -1,20 +1,20 @@
 >> Day 24a
 benchmarking...
-time                 97.06 μs   (95.96 μs .. 97.88 μs)
-                     0.999 R²   (0.999 R² .. 1.000 R²)
-mean                 94.19 μs   (93.47 μs .. 94.95 μs)
-std dev              2.477 μs   (2.155 μs .. 2.931 μs)
-variance introduced by outliers: 23% (moderately inflated)
+time                 104.0 μs   (103.9 μs .. 104.2 μs)
+                     1.000 R²   (1.000 R² .. 1.000 R²)
+mean                 104.9 μs   (104.5 μs .. 106.1 μs)
+std dev              2.157 μs   (1.014 μs .. 4.014 μs)
+variance introduced by outliers: 16% (moderately inflated)
 
 * parsing and formatting times excluded
 
 >> Day 24b
 benchmarking...
-time                 1.696 s    (1.664 s .. 1.734 s)
-                     1.000 R²   (1.000 R² .. 1.000 R²)
-mean                 1.699 s    (1.690 s .. 1.712 s)
-std dev              12.02 ms   (88.75 μs .. 14.67 ms)
-variance introduced by outliers: 19% (moderately inflated)
+time                 1.569 ms   (1.554 ms .. 1.604 ms)
+                     0.997 R²   (0.991 R² .. 1.000 R²)
+mean                 1.550 ms   (1.542 ms .. 1.572 ms)
+std dev              46.62 μs   (11.57 μs .. 87.93 μs)
+variance introduced by outliers: 17% (moderately inflated)
 
 * parsing and formatting times excluded
 
diff --git a/reflections/2024/day24.md b/reflections/2024/day24.md
new file mode 100644
index 0000000..587c5ce
--- /dev/null
+++ b/reflections/2024/day24.md
@@ -0,0 +1,145 @@
+Let's make a nice flexible `Gate` Functor/Traversable that will guide us along
+our journey.
+
+```haskell
+data Op = OAnd | OOr | OXor
+  deriving stock (Eq, Ord, Show, Generic)
+
+data Gate a = Gate {gOp :: Op, gX :: a, gY :: a}
+  deriving stock (Show, Generic, Functor, Traversable, Foldable)
+
+applyGate :: Gate Bool -> Bool
+applyGate Gate{..} = case gOp of
+  OAnd -> gX && gY
+  OOr -> gX || gY
+  OXor -> gX /= gY
+```
+
+Part 1 we can use the typical knot-tying trick: from a `Map String (Gate
+String)`, generate a `Map String Bool` of labels to their results, by referring
+to that same result.  We use the `Functor` instance of `Gate` to get `fmap (M.!
+result) :: Gate String -> Gate Bool`.
+
+```haskell
+part1 :: Map String Bool -> Map String (Gate String) -> Int
+part1 inputs gates = sum [ 2 ^ read n | ('z':n, True) <- M.toList result ]
+  where
+    result :: Map String Bool
+    result = inputs <> fmap (applyGate . fmap (M.! result)) gates
+```
+
+Now part 2, the fun part. One thing we can do is generate a full adder, by
+creating a _tree_ of `Gate`s. We can use `Free` to create a tree of nested
+Gates, since `Free f a = Pure a | Free (f (Free f a))`.
+
+```haskell
+type GateTree = Free Gate
+
+halfAdder :: GateTree a -> GateTree a -> (GateTree a, GateTree a)
+halfAdder x y = (wrap $ Gate OAnd x y, wrap $ Gate OXor x y)
+
+-- | returns carry bit and output bit
+fullAdder :: GateTree a -> GateTree a -> GateTree a -> (GateTree a, GateTree a)
+fullAdder x y carry0 = (wrap $ Gate OOr carry1 carry2, o)
+  where
+    (carry1, z) = halfAdder x y
+    (carry2, o) = halfAdder z carry0
+
+-- | returns final carry bit and all n output bits
+adderTree :: Int -> (GateTree String, NonEmpty (GateTree String))
+adderTree n
+  | n == 0 = (:| []) `second` halfAdder (pure "x00") (pure "y00")
+  | otherwise =
+      let (carryIn, rest) = adderTree (n - 1)
+          (carryOut, new) = fullAdder (pure (printf "x%02d" n)) (pure (printf "y%02d" n)) carryIn
+       in (carryOut, new `NE.cons` rest)
+```
+
+Now for the magic of `Free`: We can collapse it all into a flattened free
+structure using `iterA`, which "folds" each layer of the free structure. We
+built up a map of known gates and assign unknown gates to a new unique ID,
+creating a `Map (Gate (Either Int String)) Int`. `Left` means that the gate
+points to a known `Int` id and `Right` means it was an input `xNN`/`yNN`
+variable.
+
+```haskell
+unrollGates ::
+  forall a. Ord a => GateTree a -> State (Int, Map (Gate (Either Int a)) Int) (Either Int a)
+unrollGates = iterA go . fmap Right
+  where
+    go g0 = do
+      gate <- sequenceA g0
+      (currIx, currMp) <- get
+      case M.lookup gate currMp of
+        Nothing -> do
+          put (currIx + 1, M.insert gate currIx currMp)
+          pure $ Left currIx
+        Just i -> pure $ Left i
+
+unrollAdderTree :: Int -> ([Int], IntMap (Gate (Either Int String)))
+unrollAdderTree n = (lefts $ toList outs, IM.fromList $ swap <$> M.toList mp)
+  where
+    (carry, adder) = adderTree n
+    full = NE.reverse $ carry `NE.cons` adder
+    (outs, (_, mp)) = runState (traverse unrollGates full) (0, M.empty)
+```
+
+We wrapped it all up with `unrollAdderTree`, which returns the map of gate Int
+id's and also all of the top-level output id's. This works because all of the
+adders in `carry`/`adder`/`full` are the top-level outputs, so `traverse` pulls
+out those `Int`s as its final result.
+
+Finally we can wrap it all up in the list monad for a search. The whole thing
+is composing `NameState -> [NameState]` branches using `>=>`, where dead-ends
+are indicated by an empty list returned.
+
+```haskell
+data NameState = NS
+  { nsRenames :: Map String String
+  , nsNames :: IntMap String
+  , nsFound :: Bool
+  }
+
+nameGate :: Map (Gate String) String -> Int -> Gate (Either Int String) -> NameState -> [NameState]
+nameGate avail ng g0 NS{..} =
+  case applySwaps nsRenames <$> M.lookup gate avail of
+    Nothing -> []
+    Just here ->
+      -- the all-goes-well branch
+      NS{nsNames = IM.insert ng here nsNames, ..}
+      -- all possible substitutions/switches
+        : [ NS renames (IM.insert ng there nsNames) True
+          | not nsFound
+          , there <- toList avail
+          , here /= there
+          , let renames = M.fromList [(here, there), (there, here)] <> nsRenames
+          ]
+  where
+    gate = either (nsNames IM.!) id <$> g0
+    applySwaps mp x = M.findWithDefault x x mp
+
+nameTree :: Map (Gate String) String -> [Map String String]
+nameTree avail = nsRenames <$> foldr (\o -> (go o >=>)) pure outGates s0
+  where
+    s0 = NS M.empty IM.empty False
+    (outGates, gates) = unrollAdderTree 44
+    go outGate ns0
+      | M.size (nsRenames ns0) == 8 = [ns0]
+      | otherwise =
+          IM.foldrWithKey
+            (\k g -> (nameGate avail k g >=>))
+            pure
+            (IM.takeWhileAntitone (<= outGate) gates)
+            (ns0{nsFound = False})
+```
+
+The search is meant layer-by-layer: do all of the `z00` inputs first, then the
+`z01` inputs, etc.  There is also a major optimization that makes this all
+feasible: we only expect one swap per layer.
+
+Anyway that's it:
+
+```haskell
+part2 :: Map (Gate String) String -> [String]
+part2 = fmap M.keys . listToMaybe . nameTree
+```