From 28624575291bca1c5a145eccd8af570cc857b0cd Mon Sep 17 00:00:00 2001
From: George Thomas <georgefsthomas@gmail.com>
Date: Tue, 9 Dec 2025 13:37:39 +0000
Subject: [PATCH] Solve day 9 part 2

---
 haskell/Pre.hs          | 12 +++++++++
 haskell/Puzzles/Day9.hs | 55 +++++++++++++++++++++++++++++++++++++++--
 outputs/real/9/2        |  1 +
 3 files changed, 66 insertions(+), 2 deletions(-)
 create mode 100644 outputs/real/9/2

diff --git a/haskell/Pre.hs b/haskell/Pre.hs
index 7e6a5c5..89157ed 100644
--- a/haskell/Pre.hs
+++ b/haskell/Pre.hs
@@ -23,6 +23,7 @@ module Pre (
     module Data.Text,
     module Data.Text.Encoding,
     module Data.Traversable,
+    module Data.Tuple.Extra,
     module Data.Void,
     module Data.Word,
     module Linear,
@@ -38,6 +39,8 @@ module Pre (
     digitsToInt,
     listIndex,
     allUnorderedPairs,
+    adjacentPairs,
+    sortPair,
 )
 where
 
@@ -76,6 +79,7 @@ import Data.Text (Text)
 import Data.Text.Encoding (encodeUtf8)
 import Data.Text.Lazy qualified as TL
 import Data.Traversable
+import Data.Tuple.Extra ((&&&))
 import Data.Void
 import Data.Word
 import Linear (V2 (..))
@@ -110,3 +114,11 @@ listIndex n =
 
 allUnorderedPairs :: Bool -> [a] -> [(a, a)]
 allUnorderedPairs diagonals = concat . join (zipWith (flip $ map . (,)) . (bool tail toList diagonals) . tails)
+
+adjacentPairs :: [b] -> [(b, b)]
+adjacentPairs = \case
+    [] -> []
+    x : xs -> zip (x : xs) xs
+
+sortPair :: (Ord a) => (a, a) -> (a, a)
+sortPair (a, b) = if a <= b then (a, b) else (b, a)
diff --git a/haskell/Puzzles/Day9.hs b/haskell/Puzzles/Day9.hs
index a6b8aeb..c224fa8 100644
--- a/haskell/Puzzles/Day9.hs
+++ b/haskell/Puzzles/Day9.hs
@@ -8,14 +8,65 @@ puzzle :: Puzzle
 puzzle =
     Puzzle
         { number = 9
-        , parser = const $ (V2 @Int <$> decimal <* single ',' <*> decimal) `sepEndBy1` newline
+        , parser = const $ (V2 <$> decimal <* single ',' <*> decimal) `sepEndBy1` newline
         , parts =
             [ TL.show
                 . maximum
-                . fmap ((\(V2 x y) -> x * y) . (+ 1) . fmap abs . uncurry (-))
+                . fmap (squareSize . uncurry Square)
                 . fromMaybe (error "input too small")
                 . nonEmpty
                 . allUnorderedPairs False
+            , \points ->
+                let path =
+                        fromMaybe (error "malformed line")
+                            . traverse mkLine
+                            $ (last points', head points') :| adjacentPairs points
+                      where
+                        points' = fromMaybe (error "empty input") $ nonEmpty points
+                 in TL.show
+                        . snd
+                        . fromMaybe (error "no solutions")
+                        . find (not . flip any path . lineIntersectsSquare . fst)
+                        . sortOn (Down . snd)
+                        . fmap ((id &&& squareSize) . uncurry Square)
+                        $ allUnorderedPairs False points
             ]
         , extraTests = mempty
         }
+
+data Square = Square
+    { corner1 :: V2 Int
+    , corner2 :: V2 Int
+    }
+    deriving (Show)
+squareSize :: Square -> Int
+squareSize Square{corner1, corner2} = (\(V2 x y) -> x * y) . (+ 1) . fmap abs $ corner1 - corner2
+
+data Line
+    = LineHorizontal {y :: Int, x1 :: Int, x2 :: Int}
+    | LineVertical {x :: Int, y1 :: Int, y2 :: Int}
+    deriving (Show)
+mkLine :: (V2 Int, V2 Int) -> Maybe Line
+mkLine (V2 x1 y1, V2 x2 y2)
+    | y1 == y2 = Just $ LineHorizontal{y = y1, x1, x2}
+    | x1 == x2 = Just $ LineVertical{x = x1, y1, y2}
+    | otherwise = Nothing
+
+data Interval = Interval Int Int deriving (Show)
+compareToInterval :: Int -> Interval -> Ordering
+compareToInterval n (Interval l u)
+    | n <= l = LT
+    | n >= u = GT
+    | otherwise = EQ
+
+squareIntervals :: Square -> V2 Interval
+squareIntervals Square{corner1, corner2} = uncurry Interval . sortPair <$> liftA2 (,) corner1 corner2
+
+lineIntersectsSquare :: Square -> Line -> Bool
+lineIntersectsSquare (squareIntervals -> V2 intervalX intervalY) = \case
+    LineHorizontal{y, x1, x2} ->
+        compareToInterval y intervalY == EQ
+            && compareToInterval x1 intervalX /= compareToInterval x2 intervalX
+    LineVertical{x, y1, y2} ->
+        compareToInterval x intervalX == EQ
+            && compareToInterval y1 intervalY /= compareToInterval y2 intervalY
diff --git a/outputs/real/9/2 b/outputs/real/9/2
new file mode 100644
index 0000000..8882cd2
--- /dev/null
+++ b/outputs/real/9/2
@@ -0,0 +1 @@
+1474699155
\ No newline at end of file