diff --git a/2024/AOC2024/Day13.hs b/2024/AOC2024/Day13.hs
index 8da37e2..acd6e34 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,57 @@
 -- 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
+      V2 a b = (`div` det) <$> resDet
+  guard $ all ((== 0) . (`mod` det)) resDet
+  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/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/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/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/2024/AOC2024/Day17.hs b/2024/AOC2024/Day17.hs
index 7264683..a8b97ae 100644
--- a/2024/AOC2024/Day17.hs
+++ b/2024/AOC2024/Day17.hs
@@ -1,6 +1,3 @@
-{-# OPTIONS_GHC -Wno-unused-imports #-}
-{-# OPTIONS_GHC -Wno-unused-top-binds #-}
-
 -- |
 -- Module      : AOC2024.Day17
 -- License     : BSD3
@@ -9,218 +6,159 @@
 -- 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 (
   day17a,
   day17b,
 )
 where
 
-import AOC.Prelude
-import Data.Bits
-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 Linear as L
-import qualified Numeric.Lens as L
-import qualified Text.Megaparsec as P
+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.Monoid (Alt (..))
+import Data.Semigroup (Endo (Endo, appEndo))
+import qualified Data.Vector.Sized as SV
 import qualified Text.Megaparsec.Char as P
-import qualified Text.Megaparsec.Char.Lexer as PP
 
-day17a :: _ :~> _
+data Combo
+  = CLiteral (Finite 4)
+  | CReg (Finite 3)
+  deriving stock (Show, Eq, Ord)
+
+data Instr
+  = ADV Combo
+  | BXL (Finite 8)
+  | BST Combo
+  | JNZ (Finite 4)
+  | BXC
+  | OUT Combo
+  | BDV Combo
+  | CDV Combo
+  deriving stock (Show, Eq, Ord)
+
+comboParser :: Finite 7 -> Combo
+comboParser = either CLiteral CReg . separateSum
+
+instrParser :: Finite 8 -> Finite 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` 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))
+
+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
+        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)
-    , sShow = intercalate "," . map show
-    , sSolve =
-        noFail $ \(a, b, c, p :: [Int]) ->
-          go 0 (V3 a b c) (Seq.fromList p)
+        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 . (:)) a0 b0 c0) []
     }
 
-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
-
--- 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
-
--- 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 :: _ :~> _
+stepWith ::
+  Monoid a =>
+  SV.Vector 8 Instr ->
+  -- | out
+  (Finite 8 -> a) ->
+  -- | Starting a
+  Word ->
+  -- | Starting b
+  Word ->
+  -- | Starting c
+  Word ->
+  a
+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
+      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
+  JNZ 0 <- pure $ tp `SV.index` maxBound
+  [CReg _] <- pure [r | OUT r <- toList tp]
+  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) 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
+
+day17b :: (Word, Word, Word, SV.Vector 8 Instr, [Finite 8]) :~> Word
 day17b =
   MkSol
     { sParse = sParse day17a
     , sShow = show
-    , sSolve =
-        \(_, _, _, p :: [Int]) -> listToMaybe do
-          option <- stepBackwards (reverse p)
-          guard $ go 0 (V3 option 0 0) (Seq.fromList p) == p
-          pure option
+    , sSolve = \(_, _, _, instrs, o) -> listToMaybe $ searchStep instrs o
     }
-
--- [ (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
diff --git a/2024/AOC2024/Day19.hs b/2024/AOC2024/Day19.hs
index 95eadd3..531511a 100644
--- a/2024/AOC2024/Day19.hs
+++ b/2024/AOC2024/Day19.hs
@@ -13,59 +13,68 @@ module AOC2024.Day19 (
 where
 
 import AOC.Common.Parser (pAlphaNumWord, parseMaybe')
-import AOC.Solver (type (:~>) (..))
+import AOC.Solver (noFail, type (:~>) (..))
 import Control.DeepSeq (NFData)
-import Control.Monad (guard)
-import Data.Finite (Finite)
-import Data.Foldable (fold)
-import Data.Functor.Foldable (Corecursive (ana), Recursive (cata))
+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 (Sum (getSum))
-import qualified Data.Vector.Sized as SV
+import Data.Semigroup
+import Data.Set (Set)
+import qualified Data.Set as S
 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 (Maybe (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
 
-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)
-
-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')
-
-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
+fromMapCoalg ::
+  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 -> IM.unionWith (M.unionWith (<>)) (M.fromSet (const y) <$> initialSplit)
+   in CTF x $ reAdd (splitTrie ks)
   where
-    go CTF{..} = \case
-      [] -> ctHereF
-      c : cs -> ($ cs) =<< ctThereF `SV.index` c
+    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
+          ]
 
-foreverTrie :: (KnownNat n, Semigroup w) => [[Finite n]] -> w -> NTrie n w
-foreverTrie strs x = infiniTrie
-  where
-    tr = foldMap (`singletonTrie` x) strs
-    infiniTrie = singletonTrie [] x <> (tr `bindTrie` const infiniTrie)
+lookupAlg :: CharTrieF a ([Int] -> Maybe a) -> [Int] -> Maybe a
+lookupAlg CTF{..} = \case
+  [] -> ctHereF
+  c : cs -> ($ cs) =<< IM.lookup c ctThereF
+
+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
 day19 x agg =
@@ -78,13 +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 (`lookupTrie` (foreverTrie @5) ws' x) ls'
+    , sSolve = noFail \(ws, ls) ->
+        agg $
+          mapMaybe (buildable x (S.fromList (map ord <$> ws)) . map ord) ls
     }
-  where
-    toFinites = traverse $ flip M.lookup (M.fromList $ zip "wubrg" [0 ..])
 
 day19a :: ([String], [String]) :~> Int
 day19a = day19 () length
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)
diff --git a/2024/AOC2024/Day21.hs b/2024/AOC2024/Day21.hs
index ad33371..0f93d00 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,389 +6,124 @@
 -- 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 AOC.Common (digitToIntSafe, (!!!))
+import AOC.Common.Point (Dir (..), Point, V2 (V2), dirPoint)
+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 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 Data.Map (Map)
 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
---
+import Data.Maybe (mapMaybe, maybeToList)
+import Data.Tuple (swap)
 
 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]
-
-class Ord a => Pushable a where
+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, Show a) => Pushable a where
   allPushable :: [a]
-  applyPush :: DirPad -> Maybe a -> Maybe (Maybe a, Maybe (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)
+
 instance Pushable Dir where
-  allPushable = [West, North, South, East]
-  applyPush = applyPushDir
+  allPushable = [North ..]
+  pushMap = pushMapFromLayout dirPad
 
 instance Pushable (Finite 10) where
   allPushable = finites
-  applyPush = applyPushNum
+  pushMap = pushMapFromLayout numPad
 
--- | Best way to get from button to button. penalize motion
+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 = (++ [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
-        step (Left (b, d)) =
-          reverse
-            [ ( push
-              , case bout of
-                  Nothing -> Left (b', d')
-                  Just o -> Right o
-              )
-            | push <- toList allDirPad
-            , (d', dout) <- maybeToList $ applyPush push d
-            , (b', bout) <- case dout of
-                Nothing -> pure (b, Nothing)
-                Just push' -> maybeToList $ applyPush push' b
-            ]
-        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
+    (bg, st, en) = buttonGraph
 
--- 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 +131,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 +138,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,203 +145,33 @@ 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
-    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
-  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)
+dirPathChain :: Int -> Map DirPad (Map DirPad Int)
+dirPathChain n = iterate (`composeDirPathLengths` dirPath @Dir) (dirPathCosts @Dir) !!! n
 
-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'
+solveCode :: Int -> [NumPad] -> Int
+solveCode n = spellDirPathLengths mp . (Nothing :)
   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
+    mp = dirPathChain (n - 1) `composeDirPathLengths` dirPath @(Finite 10)
 
--- 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"
+pc :: Char -> Maybe (Finite 10)
+pc = fmap fromIntegral . digitToIntSafe <=< mfilter isDigit . Just
 
-day21b :: _ :~> _
-day21b =
+day21 :: Int -> [[NumPad]] :~> Int
+day21 n =
   MkSol
-    { sParse = sParse day21a
+    { sParse = Just . map (map pc) . lines
     , sShow = show
     , sSolve =
         noFail $
-          sum
-            . map
-              ( \p ->
-                  let num :: Int
-                      num = read (map intToDigit (mapMaybe (fmap fromIntegral) p :: [Int]))
-                   in num * altP1 25 p
-              )
+          sum . map solve
     }
-
-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
-  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 $ 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)
-
--- | 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))
-  }
-
--- | 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
+    solve p = num * solveCode 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/2024/AOC2024/Day22.hs b/2024/AOC2024/Day22.hs
index de0da61..3b45a12 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,68 @@
 -- 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 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 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 (for_)
+import qualified Data.Vector.Storable as VS
+import qualified Data.Vector.Storable.Mutable as MVS
+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 = \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) . toList
+    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 _ = []
diff --git a/2024/AOC2024/Day24.hs b/2024/AOC2024/Day24.hs
index b3c801e..e9eb59c 100644
--- a/2024/AOC2024/Day24.hs
+++ b/2024/AOC2024/Day24.hs
@@ -12,25 +12,24 @@ module AOC2024.Day24 (
 )
 where
 
-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.Monad ((>=>))
 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.State (MonadState (get, put), State, runState)
 import Data.Bifunctor (Bifunctor (second))
+import Data.Either (lefts)
 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)
 import qualified Data.Map as M
+import Data.Maybe (listToMaybe)
 import Data.Tuple (swap)
 import GHC.Generics (Generic)
 import qualified Text.Megaparsec as P
@@ -71,7 +70,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
@@ -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,69 +129,55 @@ 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 String)))
+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)
 
-nameGate ::
-  Map (Gate String) String ->
-  Int ->
-  Int ->
-  Gate (Either Int VarBit) ->
-  LogicT (StateT NameState Maybe) String
-nameGate avail renameLimit 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
-      ]
+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 ->
+      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.!) id <$> g0
     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 :: Map (Gate String) String -> [Map String String]
+nameTree avail = nsRenames <$> foldr (\o -> (go o >=>)) pure outGates s0
   where
-    s0 = NS renames0 IM.empty
+    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})
 
 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 . listToMaybe . nameTree . M.fromList
     }
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/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/bench-results/2024/day19.txt b/bench-results/2024/day19.txt
index 0fb1f97..ca09d6c 100644
--- a/bench-results/2024/day19.txt
+++ b/bench-results/2024/day19.txt
@@ -1,19 +1,19 @@
 >> 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)
+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                 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)
+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
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/bench-results/2024/day21.txt b/bench-results/2024/day21.txt
new file mode 100644
index 0000000..8db2ed0
--- /dev/null
+++ b/bench-results/2024/day21.txt
@@ -0,0 +1,19 @@
+>> Day 21a
+benchmarking...
+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.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/bench-results/2024/day22.txt b/bench-results/2024/day22.txt
index 8a4aee6..a04580d 100644
--- a/bench-results/2024/day22.txt
+++ b/bench-results/2024/day22.txt
@@ -1,19 +1,19 @@
 >> 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                 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                 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                 776.3 ms   (767.0 ms .. 784.6 ms)
+                     1.000 R²   (1.000 R² .. 1.000 R²)
+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/bench-results/2024/day24.txt b/bench-results/2024/day24.txt
new file mode 100644
index 0000000..1a2cbc3
--- /dev/null
+++ b/bench-results/2024/day24.txt
@@ -0,0 +1,20 @@
+>> Day 24a
+benchmarking...
+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.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/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/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
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/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/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 `+`.
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)
+```
diff --git a/reflections/2024/day15.md b/reflections/2024/day15.md
new file mode 100644
index 0000000..ea71c76
--- /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. This is essentially a recursion-based DFS.
+
+```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 
+```
+
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).
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
+```
diff --git a/reflections/2024/day18.md b/reflections/2024/day18.md
new file mode 100644
index 0000000..c77f35f
--- /dev/null
+++ b/reflections/2024/day18.md
@@ -0,0 +1,90 @@
+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 => (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]
+    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.
diff --git a/reflections/2024/day19.md b/reflections/2024/day19.md
new file mode 100644
index 0000000..99f3696
--- /dev/null
+++ b/reflections/2024/day19.md
@@ -0,0 +1,82 @@
+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, 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 ::
+  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)
+```
+
+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.
diff --git a/reflections/2024/day20.md b/reflections/2024/day20.md
new file mode 100644
index 0000000..7a92b02
--- /dev/null
+++ b/reflections/2024/day20.md
@@ -0,0 +1,54 @@
+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 -> let d = mannDist x y in d <= len && i - j - d >= thresh) xs
+      )
+```
+
+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.
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.
diff --git a/reflections/2024/day22.md b/reflections/2024/day22.md
new file mode 100644
index 0000000..cd81a4c
--- /dev/null
+++ b/reflections/2024/day22.md
@@ -0,0 +1,51 @@
+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). 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.
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
+```
diff --git a/reflections/2024/day25.md b/reflections/2024/day25.md
new file mode 100644
index 0000000..34bcca1
--- /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 (+) . map (\(x, y) -> (x, 1)) . toList
+
+marginY :: Set (Int, Int) -> Map Int Int
+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:
+
+```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)
+```
diff --git a/site/default.nix b/site/default.nix
index 0093ccb..3e1351b 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,10 +38,10 @@ 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
+                    [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
@@ -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)}
       ''
 
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