Haskell solution progression for AOC 2022 day 15 part 2

day15.hs

module Main where

import Utils

import Control.Concurrent
import Control.Concurrent.Chan
import Data.List
import qualified Data.Map.Strict as M
import qualified Data.Set as S
import Data.Range as Range
import Debug.Trace

type Point = (Int,Int)
type LineSegment = (Point,Point)
type Grid = M.Map Point Char
data Sensor = Sensor Point Point Int deriving (Show,Eq)
type RangeMap = M.Map Int [Range Int]

instance Ord Sensor where
  compare (Sensor s1 _ _) (Sensor s2 _ _) = compare s1 s2

point :: Parser Point
point = do
  string "x="
  x <- integer
  string ", y="
  y <- integer
  return (x,y)

sensor :: Parser Sensor
sensor = do
  string "Sensor at "
  sensorpos <- point
  string ": closest beacon is at "
  beaconpos <- point
  return $ Sensor sensorpos beaconpos (taxicabDistance sensorpos beaconpos)

taxicabDistance :: Point -> Point -> Int
taxicabDistance (x1,y1) (x2,y2) = abs (x1-x2) + abs (y1-y2)

distanceToBeacon :: Sensor -> Int
distanceToBeacon (Sensor s b d) = d

placesInRange :: Int -> Sensor -> [Point]
placesInRange targetRow (Sensor s@(sx,sy) b d) = pointsOnTargetRow
  where dtb = d
        dtr = abs $ targetRow - sy
        dx = (dtb - dtr) -- number of points left and right of sx on the target row
        pointsOnTargetRow = [(x,targetRow) | x <- [(sx-dx)..(sx+dx)]] -- using that [5..3] == []

-- M.insertWith (flip const) will insert the new value only if the key is not taken yet.
fillTargetRow :: Int -> Grid -> Sensor -> Grid
fillTargetRow target grid sensor = foldl' (\g c -> M.insertWith (flip const) c '#' g) grid placesOnTargetRow
  where placesOnTargetRow = placesInRange target sensor

-- Not super fast but it works. Unlike part2 I didn't bother rewriting this.
part1 = do
  Right sensors <- parseFileLines sensor "day15_input.txt"
  let initialGrid = foldl' (\g (Sensor s b _) -> M.insert b 'B' $ M.insert s 'S' g) M.empty sensors
  let target = 2000000
  let targetRowFilled = foldl' (fillTargetRow target) initialGrid sensors
  print . M.size $ M.filterWithKey (\(x,y) a -> y == target && a == '#') targetRowFilled

rangesOnRows :: Sensor -> [(Int,Range Int)]
rangesOnRows (Sensor s@(sx,sy) b d) = traceShow dtb $ map (\row -> (row, (sx-(dx row)) +=+ (sx+(dx row)))) rowsInRange
  where dtb = d
        dtr targetRow = abs $ targetRow - sy
        dx targetRow = (dtb - (dtr targetRow)) -- number of points left and right of sx on the target row
        rowsInRange = [(max 0 (sy - dtb))..(min 4000000 (sy + dtb))]

addRanges :: RangeMap -> [(Int,Range Int)] -> RangeMap
addRanges rangemap ranges = foldl' (\rm (row,range) -> M.insertWith (\a b -> joinRanges (a++b)) row [range] rm) rangemap ranges

-- works, but is slow, takes about 184 seconds, 62 seconds when compiled, 51 seconds door minder rijen te bekijken
part2 = do
  Right sensors <- parseFileLines sensor "day15_input.txt"
  let target = 4000000
  let targetRowFilled = foldl' (\m s -> addRanges m $ rangesOnRows s) M.empty sensors
  let result = head . M.assocs $ M.filter (\a -> length a == 2) targetRowFilled
  print $ ((fst result) + ((* 4000000) . head . fromRanges $ difference [0 +=+ target] $ snd result))

-- Idea taken from the reddit: there is exactly 1 point where it could be. That means that the
-- surrounding points must be inside range of at least one of the sensors and therefore the distress
-- beacon must be on the perimeter of one of the squares (actually on the perimeter of several squares) but
-- not inside any squares. So, generate all the points one outside sensor range for all sensors, concat those
-- then for all the generated points check whether they're inside range of one of the sensors. All but one
-- will be inside the range, the last one is the sensor location.

perimeterPoints :: Chan Point -> [Sensor] -> Int -> Sensor -> IO () --[Point]
perimeterPoints chan allSensors target (Sensor s@(sx,sy) b d) = writeList2Chan chan $ filter (\c -> not $ any (isInRange c) allSensors) $ concat [points, topRightEdge, bottomLeftEdge, topLeftEdge, bottomRightEdge]
  where dtb = d + 1
        topRightEdge = filter (\(x,y) -> x >= 0 && x <= target && y >= 0 && y <= target) $ takeWhile (/= pointRight) $ iterate (\(x,y) -> (x+1,y+1)) pointAbove
        bottomLeftEdge = filter (\(x,y) -> x >= 0 && x <= target && y >= 0 && y <= target) $ takeWhile (/= pointBelow) $ iterate (\(x,y) -> (x+1,y+1)) pointLeft
        topLeftEdge = filter (\(x,y) -> x >= 0 && x <= target && y >= 0 && y <= target) $ takeWhile (/= pointLeft) $ iterate (\(x,y) -> (x-1,y+1)) pointAbove
        bottomRightEdge = filter (\(x,y) -> x >= 0 && x <= target && y >= 0 && y <= target) $ takeWhile (/= pointBelow) $ iterate (\(x,y) -> (x-1,y+1)) pointRight
        pointBelow = (sx,sy+dtb)
        pointAbove = (sx,sy-dtb)
        pointLeft  = (sx-dtb,sy)
        pointRight = (sx+dtb,sy)
        points = filter (\(x,y) -> x >= 0 && x <= target && y >= 0 && y <= target) $ [pointBelow, pointAbove, pointLeft, pointRight]

isInRange :: Point -> Sensor -> Bool
isInRange c (Sensor s b d) = taxicabDistance c s <= d

-- runs in ~733 ms now when compiled with -O2 -threaded
part2fast = do
  Right sensors <- parseFileLines sensor "day15_input.txt"
  let target = 4000000
  -- dirty trick to paralellize: the first valid point we find will be pulled from the channel and printed,
  -- then when the main thread exits any remaining worker threads will be killed automatically
  chan <- newChan
  forM_ sensors $ \s -> forkIO $ perimeterPoints chan sensors target s
  result <- readChan chan
  print $ ((snd result) + ((* 4000000) $ fst result))

-- after some consideration on the codeklets slack, we discovered that the distress beacon MUST
-- lie on the intersection of two "edge+1" lines, so we can just compare all pairs of two sensors,
-- see if any of their edges intersect and then pull all those intersections points through the isInRange check
-- That should only generate about 30^2 points to check?

allPairs :: Ord a => [a] -> [(a,a)]
allPairs xs = [(a,b) | a <- xs, b <- xs, a < b]

canonicalLineForm :: (Point,Point) -> (Int,Int,Int)
canonicalLineForm ((x1,y1),(x2,y2)) = (a,b,c)
  where a = y2 - y1
        b = x1 - x2
        c = a*x1 + b*y1

pointOnLine :: LineSegment -> Point -> Bool
pointOnLine ((x1,y1),(x2,y2)) (x,y) = xgood && ygood
  where xgood = min x1 x2 <= x && x <= max x1 x2
        ygood = min y1 y2 <= y && y <= max y1 y2

-- taken from https://www.topcoder.com/thrive/articles/Geometry%20Concepts%20part%202:%20%20Line%20Intersection%20and%20its%20Applications
lineIntersection :: (LineSegment,LineSegment) -> Maybe Point
lineIntersection (l1,l2) = if det == 0 || not isOnFirstLine || not isOnSecondLine then Nothing else Just (x,y)
  where det = a1 * b2 - a2 * b1
        (a1,b1,c1) = canonicalLineForm l1
        (a2,b2,c2) = canonicalLineForm l2
        x = (b2 * c1 - b1 * c2) `div` det
        y = (a1 * c2 - a2 * c1) `div` det
        isOnFirstLine = pointOnLine l1 (x,y)
        isOnSecondLine = pointOnLine l2 (x,y)

intersectingPoints :: (Sensor,Sensor) -> [Point]
intersectingPoints (Sensor (s1x,s1y) _ d1, Sensor (s2x,s2y) _ d2) = catMaybes $ map lineIntersection [
    (tl1,tr2),
    (tl1,bl2),
    (tr1,tl2),
    (tr1,br2),
    (br1,bl2),
    (br1,tr2),
    (bl1,tl2),
    (bl1,br2)]
  where d1' = d1 + 1
        d2' = d2 + 1
        s1top = (s1x,s1y-d1')
        s1bottom = (s1x,s1y+d1')
        s1left = (s1x-d1',s1y)
        s1right = (s1x+d1',s1y)
        s2top = (s2x,s2y-d2')
        s2bottom = (s2x,s2y+d2')
        s2left = (s2x-d2',s2y)
        s2right = (s2x+d2',s2y)
        tl1 = (s1left,s1top)
        tr1 = (s1top,s1right)
        bl1 = (s1left,s1bottom)
        br1 = (s1bottom,s1right)
        tl2 = (s2left,s2top)
        tr2 = (s2top,s2right)
        bl2 = (s2left,s2bottom)
        br2 = (s2bottom,s2right)

-- When compiled with -O2 this finishes in 11 ms, aka the startup time of the runtime, since
-- "hello world" also takes 11 ms to run in compiled form
part2faster = do
  Right sensors <- parseFileLines sensor "day15_input.txt"
  let sensorPairs = allPairs sensors
  let intersections = concatMap intersectingPoints sensorPairs
  let target = 4000000
  let inrangeIntersections = filter (\(x,y) -> x >= 0 && x <= target && y >= 0 && y <= target) intersections
  let result = head $ filter (\c -> not $ any (isInRange c) sensors) inrangeIntersections
  print $ ((snd result) + ((* 4000000) $ fst result))

-- main = part2faster