AoC 2021 Day 05: Hydrothermal Venture

Problem Statement

Part One

You come across a field of hydrothermal vents on the ocean floor! These vents constantly produce large, opaque clouds, so it would be best to avoid them if possible.

They tend to form in lines; the submarine hopefully produces a list of nearby lines of vents (your puzzle input) for you to review.

Each line of vents is given as a line segment in the format (x1, y1 -> x2, y2), where x1,y1 are the coordinates of one end of the line segment, and x2,y2 are the coordinates of the other end. These line segments include the points at both ends. In other words:

An entry like 1,2 -> 1,3 covers points 1,1, 1,2, and 1,3.
An entry like 9,7 -> 7,7 covers points 9,7, 8,7, and 7,7.

For now, only consider horizontal and vertical lines: lines where either x1 == x2 or y1 == y2.

To avoid the most dangerous areas, you need to determine the number of points where at least two lines overlap. At how many points do at least two lines overlap?

Part Two

Unfortunately, considering only horizontal and vertical lines doesn’t give you the full picture; you need to also consider diagonal lines.

Because of the limits of the hydrothermal vent mapping system, the lines in your list will only ever be horizontal, vertical, or a diagonal line at exactly 45 degrees. In other words:

An entry like 1,1 -> 3,3 covers points 1,1, 2,2, and 3,3.
An entry like 9,7 -> 7.9 covers points 9,7, 8,8, and 7,9.

Consider all of the lines. At how many points do at least two lines overlap?

My Solution

{-# OPTIONS_GHC -Wall #-}

module HydrothermalVenture.HydrothermalVenture
  ( pointsWithAtLeastTwoRightSegmentOverlaps,
    pointsWithAtLeastTwoSegmentOverlaps,
    LineSegment (..),
    Point (..),
  )
where

import Data.List (group, sort)

-- The input text is of the form:
--
-- 0,9 -> 5,9
-- 8,0 -> 0,8
--
-- The points don't make sense individually, so grouping them together as a line
-- segment makes sense.
--
-- Kinda wild that deriving `Eq` and `Ord` simply works!
data Point = Point {x :: Int, y :: Int} deriving (Eq, Ord, Show)

data LineSegment = LineSegment {p1 :: Point, p2 :: Point}

type LineSegmentDiscretizer = LineSegment -> [Point]

discretizeRightLineSegment :: LineSegmentDiscretizer
discretizeRightLineSegment LineSegment {p1 = Point {x = x1, y = y1}, p2 = Point {x = x2, y = y2}}
  | x1 == x2 || y1 == y2 =
    let steps :: Int -> Int -> [Int]
        steps i1 i2 = if i2 > i1 then [i1 .. i2] else [i2 .. i1]
        xs = steps x1 x2
        ys = steps y1 y2
     in map (\p -> Point {x = head p, y = p !! 1}) (sequence [xs, ys])
  | otherwise = []

groupSegmentOverlaps :: LineSegmentDiscretizer -> [LineSegment] -> [[Point]]
groupSegmentOverlaps discretizer lineSegments =
  -- In an imperative language with mutable data, I'd have had a mapping from
  -- points to counts, and then looped over the map to get those w/ counts >=
  -- 2. But we don't have mutability...
  --
  -- Suppose we had a list of points with a vent, e.g. [(x1, y1), (x2, y2),
  -- (x3, y3), (x1, y1), (x4, y4)]. How do I get counts without mutability?
  --
  -- Seems like some version of folding, where the accumulator is of the form
  -- [(x1, x2, 2), (x2, y2, 1), (x3, y3, 1), (x4, y4, 1)]. Feels pretty
  -- inefficient. Or we can sort the list, and then keeping count doesn't need
  -- take quadratic(?) time.
  let expandSegmentsToPoints :: [LineSegment] -> [Point]
      expandSegmentsToPoints [] = []
      expandSegmentsToPoints (seg : segs) =
        discretizer seg ++ expandSegmentsToPoints segs
   in group (sort (expandSegmentsToPoints lineSegments))

pointsWithAtLeastTwoRightSegmentOverlaps :: [LineSegment] -> Int
pointsWithAtLeastTwoRightSegmentOverlaps segs =
  length
    ( filter
        (\ps -> length ps > 1)
        ( groupSegmentOverlaps
            discretizeRightLineSegment
            segs
        )
    )

discretizeDiagonalLineSegment :: LineSegmentDiscretizer
discretizeDiagonalLineSegment LineSegment {p1 = Point {x = x1, y = y1}, p2 = Point {x = x2, y = y2}}
  | abs (x1 - x2) == abs (y1 - y2) =
    let absDiff = abs (x1 - x2)
        xs = [x1, x1 + step .. x2]
          where
            step = (x2 - x1) `div` absDiff
        ys = [y1, y1 + step .. y2]
          where
            step = (y2 - y1) `div` absDiff
     in zipWith (\x' y' -> Point {x = x', y = y'}) xs ys
  | otherwise = []

discretizeLineSegments :: LineSegmentDiscretizer
discretizeLineSegments lineSeg@LineSegment {p1 = Point {x = x1, y = y1}, p2 = Point {x = x2, y = y2}}
  | x1 == x2 || y1 == y2 = discretizeRightLineSegment lineSeg
  | abs (x1 - x2) == abs (y1 - y2) = discretizeDiagonalLineSegment lineSeg
  | otherwise = []

pointsWithAtLeastTwoSegmentOverlaps :: [LineSegment] -> Int
pointsWithAtLeastTwoSegmentOverlaps segs =
  length
    ( filter
        (\ps -> length ps > 1)
        ( groupSegmentOverlaps
            discretizeLineSegments
            segs
        )
    )