Day 15

src/Days/D15.hs

@@ -0,0 +1,170 @@
+{-# LANGUAGE ImportQualifiedPost #-}
+{-# LANGUAGE NumericUnderscores #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+
+module Days.D15 where
+
+import Common
+import Data.Bifunctor (first)
+import Data.List (nub, sort)
+import Parse
+import Text.Megaparsec.Char (space)
+import Text.Megaparsec.Char.Lexer qualified as L
+
+data V2 = V2 !Int !Int deriving (Eq, Ord, Show)
+
+instance Num V2 where
+  (+) (V2 a b) (V2 c d) = V2 (a + c) (b + d)
+  (*) (V2 a b) (V2 c d) = V2 (a * c) (b * d)
+  abs (V2 a b) = V2 (abs a) (abs b)
+  signum (V2 a b) = V2 (signum a) (signum b)
+  fromInteger = undefined
+  negate (V2 a b) = V2 (negate a) (negate b)
+
+data Report = Report {sensor :: V2, beacon :: V2}
+  deriving (Show)
+
+dist :: V2 -> V2 -> Int
+dist (V2 a b) (V2 c d) = abs (c - a) + abs (d - b)
+
+parser :: Parser [Report]
+parser = someLines report
+  where
+    report =
+      ( \sensor beacon ->
+          (Report {sensor = sensor, beacon = beacon})
+      )
+        <$ symbol "Sensor at"
+        <*> point
+        <* symbol ": closest beacon is at"
+        <*> point
+    point =
+      V2
+        <$ symbol "x="
+        <*> int
+        <* symbol ", y="
+        <*> int
+    symbol = L.symbol space
+
+spanAt :: Int -> Report -> (Int, Int)
+spanAt lineY (Report {..}) =
+  case sensor of
+    (V2 x y) ->
+      let yDiff = abs (y - lineY)
+          range = dist beacon sensor
+          lineRange = range - yDiff
+       in (x - lineRange, x + lineRange)
+
+mergeOverlap :: [(Int, Int)] -> [(Int, Int)]
+mergeOverlap [] = []
+mergeOverlap [x] = [x]
+mergeOverlap ((a, b) : xs@((c, d) : rest)) =
+  if b < c
+    then (a, b) : mergeOverlap xs
+    else mergeOverlap ((min a c, max b d) : rest)
+
+part1 :: [Report] -> Int
+part1 reports =
+  let row = 2_000_000
+      coveredCount =
+        sum
+          . map (\(a, b) -> b - a + 1)
+          . mergeOverlap
+          . sort
+          . filter (uncurry (<=))
+          $ map (spanAt row) reports
+
+      beaconCount =
+        length
+          . nub
+          . filter (\(V2 _ b) -> b == row)
+          $ map beacon reports
+   in coveredCount - beaconCount
+
+transform :: V2 -> V2
+transform (V2 x y) = V2 (x + y) (x - y)
+
+untransform :: V2 -> V2
+untransform (V2 x y) = V2 ((x + y) `div` 2) ((x - y) `div` 2)
+
+type Square = (V2, Int)
+
+data Line = L V2 V2 deriving (Show)
+
+squareEdges :: Square -> [Line]
+squareEdges (V2 x y, r) =
+  [ L (min p1 p2) (max p1 p2)
+    | p1 <- [V2 (x + r) (y + r), V2 (x - r) (y - r)],
+      p2 <- [V2 (x + r) (y - r), V2 (x - r) (y + r)]
+  ]
+
+unit :: Line -> V2
+unit (L p1 p2) = signum (p2 - p1)
+
+base :: Line -> V2
+base l = V2 1 1 - unit l
+
+len :: V2 -> Int
+len (V2 x y) = x + y
+
+on :: V2 -> Line -> Bool
+on p l@(L p1 p2) =
+  let commonDim = base l
+      diffDim = unit l
+   in (commonDim * p == commonDim * p1)
+        && diffDim * p1 <= diffDim * p
+        && diffDim * p <= diffDim * p2
+
+intersect :: Line -> Line -> [V2]
+intersect l@(L p1 p2) l'@(L p1' p2')
+  | unit l == unit l' =
+      [p1 | p1 `on` l']
+        ++ [p2 | p2 `on` l']
+        ++ [p1' | p1' `on` l]
+        ++ [p2' | p2' `on` l]
+  | otherwise =
+      let p = base l * p1 + base l' * p1'
+       in ([p | p `on` l, p `on` l'])
+
+-- Too lazy to clean this up :P
+part2 :: [Report] -> Int
+part2 reports =
+  let squares = map (\(Report {..}) -> (sensor, dist sensor beacon)) reports
+
+      tSquares = map (first transform) squares
+      tEdgeIntersections =
+        nub $
+          concat
+            [ concat
+                [ e `intersect` e'
+                  | e <- squareEdges sq,
+                    e' <- squareEdges sq'
+                ]
+              | sq <- tSquares,
+                sq' <- tSquares,
+                sq < sq'
+            ]
+
+      edgeIntersections = map untransform tEdgeIntersections
+
+      covered p = any (\(sensor, r) -> dist sensor p <= r) squares
+      inside p = any (\(sensor, r) -> dist sensor p < r) squares
+   in (\(V2 x y) -> x * 4_000_000 + y)
+        . head
+        . filter (all covered . neigh4)
+        . filter (<= V2 4_000_000 4_000_000)
+        . filter (V2 0 0 <=)
+        . concat
+        . filter ((1 ==) . length)
+        . map (filter (not . covered) . neigh4)
+        . filter (not . inside)
+        $ edgeIntersections
+  where
+    neigh4 p =
+      map
+        (p +)
+        [V2 (-1) 0, V2 0 (-1), V2 0 1, V2 1 0]
+
+day :: Day
+day = parsecDay parser (definitive . part1, definitive . part2)