Created
December 15, 2022 17:11
-
-
Save WJWH/0b9daf9450426158dc7ea24a203bdf24 to your computer and use it in GitHub Desktop.
Haskell solution progression for AOC 2022 day 15 part 2
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
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 |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment