Day 24

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

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

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

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

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]