diff --git a/advent-of-code-2023.cabal b/advent-of-code-2023.cabal index 2277b87..3c80df5 100644 --- a/advent-of-code-2023.cabal +++ b/advent-of-code-2023.cabal @@ -167,3 +167,10 @@ executable day23 hs-source-dirs: day23 default-language: Haskell2010 default-extensions: LambdaCase + +executable day24 + main-is: Main.hs + other-modules: Commons Part1 Part2 + build-depends: base ^>=4.15.1.0, MissingH, mfsolve + hs-source-dirs: day24 + default-language: Haskell2010 diff --git a/day24/Commons.hs b/day24/Commons.hs new file mode 100644 index 0000000..06d2beb --- /dev/null +++ b/day24/Commons.hs @@ -0,0 +1,24 @@ +module Commons where + +import GHC.IO.Handle (isEOF) +import Data.List.Utils (split) + + +data Hailstone = Hailstone { x :: Int, y :: Int, z :: Int, vx :: Int, vy :: Int, vz :: Int } deriving Show + + +parseHail :: String -> String -> Hailstone +parseHail pos speed = let (rX: rY: rZ: _) = split ", " pos + (rVx: rVy: rVz: _) = split ", " speed + in Hailstone { x = read rX, y = read rY, z = read rZ, + vx = read rVx, vy = read rVy, vz = read rVz } + +parse :: IO [Hailstone] +parse = do done <- isEOF + if done + then return [] + else do line <- getLine + let (rawPos: rawSpeed: _) = split " @ " line + let hail = parseHail rawPos rawSpeed + otherHail <- parse + return $ hail: otherHail diff --git a/day24/Main.hs b/day24/Main.hs new file mode 100644 index 0000000..1fb8765 --- /dev/null +++ b/day24/Main.hs @@ -0,0 +1,12 @@ +module Main where + +import Commons +import qualified Part1 +import qualified Part2 + + +main = do hail <- parse + let part1Res = Part1.findIntersections (200000000000000, 400000000000000) hail + print $ length part1Res + let part2Res = Part2.getCoords hail + print $ sum part2Res diff --git a/day24/Part1.hs b/day24/Part1.hs new file mode 100644 index 0000000..ec37b2f --- /dev/null +++ b/day24/Part1.hs @@ -0,0 +1,52 @@ +module Part1 where + +import Commons + + +getCoords :: (Int, Int) -> Hailstone -> ((Double, Double), (Double, Double)) +getCoords (minP, maxP) h = + let xSteps = if vx h > 0 then fromIntegral (abs (maxP - x h)) / fromIntegral (vx h) + else fromIntegral (abs (minP - x h)) / fromIntegral (-1 * vx h) + ySteps = if vy h > 0 then fromIntegral (abs (maxP - y h)) / fromIntegral (vy h) + else fromIntegral (abs (minP - y h)) / fromIntegral (-1 * vy h) + ((x1, y1), (x2, y2)) = if xSteps < ySteps + then ((fromIntegral $ x h, fromIntegral $ y h), + (fromIntegral (x h) + xSteps * fromIntegral (vx h), + fromIntegral (y h) + xSteps * fromIntegral (vy h))) + else ((fromIntegral $ x h, fromIntegral $ y h), + (fromIntegral (x h) + ySteps * fromIntegral (vx h), + fromIntegral (y h) + ySteps * fromIntegral (vy h))) + in ((x1, y1), (x2, y2)) + +getIntersection :: ((Double, Double), (Double, Double)) -> ((Double, Double), (Double, Double)) -> + Maybe (Double, Double) +getIntersection ((x1, y1), (x2, y2)) ((x3, y3), (x4, y4)) = + let c = (x1 - x2) * (y3 - y4) - (y1 - y2) * (x3 - x4) + in if abs c < 0.01 then Nothing + else let a = x1 * y2 - y1 * x2 + b = x3 * y4 - y3 * x4 + x = (a * (x3 - x4) - b * (x1 - x2)) / c + y = (a * (y3 - y4) - b * (y1 - y2)) / c + in Just (x, y) + +checkIntersect :: (Int, Int) -> Hailstone -> Hailstone -> Maybe (Double, Double) +checkIntersect (minP, maxP) h1 h2 = + let ((x1, y1), (x2, y2)) = getCoords (minP, maxP) h1 + ((x3, y3), (x4, y4)) = getCoords (minP, maxP) h2 + dMinP = fromIntegral minP + dMaxP = fromIntegral maxP + in case getIntersection ((x1, y1), (x2, y2)) ((x3, y3), (x4, y4)) of + Nothing -> Nothing + Just (x, y) -> if x >= min x1 x2 && x <= max x1 x2 && x >= min x3 x4 && x <= max x3 x4 + && x >= dMinP && x <= dMaxP && y >= dMinP && y <= dMaxP + then Just (x, y) else Nothing + +getIntersections :: (Int, Int) -> [Hailstone] -> [Hailstone] -> [(Double, Double)] +getIntersections _ [_] _ = [] +getIntersections p (_: h: t) [] = getIntersections p (h: t) t +getIntersections p (h1: t1) (h2: t2) = case checkIntersect p h1 h2 of + Just (x, y) -> (x, y): getIntersections p (h1: t1) t2 + Nothing -> getIntersections p (h1: t1) t2 + +findIntersections :: (Int, Int) -> [Hailstone] -> [(Double, Double)] +findIntersections p (h: t) = getIntersections p (h: t) t diff --git a/day24/Part2.hs b/day24/Part2.hs new file mode 100644 index 0000000..0e0191c --- /dev/null +++ b/day24/Part2.hs @@ -0,0 +1,26 @@ +module Part2 where + +import Commons +import Math.MFSolve +import Data.Foldable (find) + + +solve :: [Hailstone] -> Either (DepError SimpleVar Double) (Dependencies SimpleVar Double) +solve [h1, h2, h3, h4, h5, h6] = + let [x0, y0, z0, vx0, vy0, vz0] = map (makeVariable . SimpleVar) ["x0", "y0", "z0", "vx0", "vy0", "vz0"] + in flip execSolver noDeps $ + do x0 * fromIntegral (vy h2 - vy h1) + y0 * fromIntegral (vx h1 - vx h2) + vx0 * fromIntegral (y h1 - y h2) + vy0 * fromIntegral (x h2 - x h1) === fromIntegral (y h1 * vx h1 - x h1 * vy h1 + x h2 * vy h2 - y h2 * vx h2) + x0 * fromIntegral (vy h4 - vy h3) + y0 * fromIntegral (vx h3 - vx h4) + vx0 * fromIntegral (y h3 - y h4) + vy0 * fromIntegral (x h4 - x h3) === fromIntegral (y h3 * vx h3 - x h3 * vy h3 + x h4 * vy h4 - y h4 * vx h4) + x0 * fromIntegral (vy h6 - vy h5) + y0 * fromIntegral (vx h5 - vx h6) + vx0 * fromIntegral (y h5 - y h6) + vy0 * fromIntegral (x h6 - x h5) === fromIntegral (y h5 * vx h5 - x h5 * vy h5 + x h6 * vy h6 - y h6 * vx h6) + x0 * fromIntegral (vz h2 - vz h1) + z0 * fromIntegral (vx h1 - vx h2) + vx0 * fromIntegral (z h1 - z h2) + vz0 * fromIntegral (x h2 - x h1) === fromIntegral (z h1 * vx h1 - x h1 * vz h1 + x h2 * vz h2 - z h2 * vx h2) + x0 * fromIntegral (vz h4 - vz h3) + z0 * fromIntegral (vx h3 - vx h4) + vx0 * fromIntegral (z h3 - z h4) + vz0 * fromIntegral (x h4 - x h3) === fromIntegral (z h3 * vx h3 - x h3 * vz h3 + x h4 * vz h4 - z h4 * vx h4) + x0 * fromIntegral (vz h6 - vz h5) + z0 * fromIntegral (vx h5 - vx h6) + vx0 * fromIntegral (z h5 - z h6) + vz0 * fromIntegral (x h6 - x h5) === fromIntegral (z h5 * vx h5 - x h5 * vz h5 + x h6 * vz h6 - z h6 * vx h6) + +getCoords :: [Hailstone] -> [Int] +getCoords h = let (h1: h2: h3: h4: h5: h6: _) = h + (Right d) = solve [h1, h2, h3, h4, h5, h6] + vars = knownVars d + (Just x) = find (\ (v, _) -> v == SimpleVar "x0") vars + (Just y) = find (\ (v, _) -> v == SimpleVar "y0") vars + (Just z) = find (\ (v, _) -> v == SimpleVar "z0") vars + in [floor $ snd x, floor $ snd y, floor $ snd z]