advent24/Main.hs

   1 -- Writeup at https://work.njae.me.uk/2024/01/04/advent-of-code-2023-day-24/
   2
   3
   4 import AoC
   5
   6 import Data.Text (Text)
   7 import qualified Data.Text.IO as TIO
   8 import Data.Attoparsec.Text hiding (take)
   9 -- import Control.Applicative
  10 import Control.Lens
  11 import Linear
  12 import Data.Maybe
  13 import Data.Ratio
  14 -- import Data.List.Split (chunksOf)
  15
  16 type Position2 = V2 Rational
  17 type Position3 = V3 Rational
  18
  19 type Segment = (Position2, Position2)
  20
  21 data Hailstone = Hailstone { _pos :: V3 Rational, _vel :: V3 Rational }
  22   deriving (Show, Eq, Ord)
  23 makeLenses ''Hailstone
  24
  25 main :: IO ()
  26 main =
  27   do  dataFileName <- getDataFileName
  28       text <- TIO.readFile dataFileName
  29       let stones = successfulParse text
  30       print $ part1 stones
  31       print $ part2 stones
  32
  33 part1, part2 :: [Hailstone] -> Int
  34 part1 stones = length $ filter (uncurry intersects) (pairs bps)
  35   where boundary = (V2 2e14 2e14 , V2 4e14 4e14) -- ((V2 7 7), (V2 27 27))
  36         bps = catMaybes $ fmap (boundaryPoints boundary) stones
  37
  38 part2 stones = fromIntegral $ numerator solution `div` denominator solution
  39   where rock = Hailstone (pure 0) (pure 0) -- Hailstone (V3 0 0 0) (V3 0 0 0)
  40         (ay, by) = buildMatrix stones _y
  41         (az, bz) = buildMatrix stones _z
  42         solY = luSolveFinite ay by
  43         solZ = luSolveFinite az bz
  44         rock' = rock & pos . _x .~ (solY ^. _x)
  45                      & pos . _y .~ (solY ^. _y)
  46                      & pos . _z .~ (solZ ^. _y)
  47                      & vel . _x .~ (solY ^. _z)
  48                      & vel . _y .~ (solY ^. _w)
  49                      & vel . _z .~ (solZ ^. _w)
  50         solution = (rock' ^. pos . _x) + (rock' ^. pos . _y) + (rock' ^. pos . _z)
  51
  52 intersects :: Segment -> Segment -> Bool
  53 intersects ((V2 x1 y1), (V2 x2 y2)) ((V2 x3 y3), (V2 x4 y4)) = ad && pd
  54   where a = (x1 - x3) * (y3 - y4) - (y1 - y3) * (x3 - x4)
  55         p = (x1 - x3) * (y1 - y2) - (y1 - y3) * (x1 - x2)
  56         d = (x1 - x2) * (y3 - y4) - (y1 - y2) * (x3 - x4)
  57         ad = if d < 0 then 0 >= a && a >= d
  58               else 0 <= a && a <= d
  59         pd = if d < 0 then 0 >= p && p >= d
  60               else 0 <= p && p <= d
  61
  62 boundaryPoints :: (Position2, Position2) -> Hailstone -> Maybe Segment
  63 boundaryPoints b@((V2 minX minY), (V2 maxX maxY)) h
  64   | null ts = Nothing
  65   | tMax < 0 = Nothing
  66   | otherwise = Just (V2 xMin yMin, V2 xMax yMax)
  67   where V2  x  y = h ^. pos . _xy
  68         V2 vx vy = h ^. vel . _xy
  69         tMinX = (minX - x) / vx
  70         tMaxX = (maxX - x) / vx
  71         tMinY = (minY - y) / vy
  72         tMaxY = (maxY - y) / vy
  73         ts = filter withinT $ filter (>= 0) [tMinX, tMinY, tMaxX, tMaxY, 0]
  74         tMin = minimum ts
  75         tMax = maximum ts
  76         xMin = x + tMin * vx
  77         xMax = x + tMax * vx
  78         yMin = y + tMin * vy
  79         yMax = y + tMax * vy
  80         withinT t = within b (V2 (x + t * vx) (y + t * vy))
  81
  82 within :: (Position2, Position2) -> Position2 -> Bool
  83 within ((V2 minX minY), (V2 maxX maxY)) (V2 x y) =
  84   x >= minX && x <= maxX && y >= minY && y <= maxY
  85
  86 pairs :: Ord a => [a] -> [(a,a)]
  87 pairs xs = [(x,y) | x <- xs, y <- xs, x < y]
  88
  89 chunks2 :: [a] -> [(a, a)]
  90 chunks2 [] = []
  91 chunks2 [_] = []
  92 chunks2 (x:y:xs) = (x,y) : chunks2 xs
  93
  94 buildMatrix :: [Hailstone] -> Lens' Position3 Rational -> (M44 Rational, V4 Rational)
  95 buildMatrix hs l = (V4 a1 a2 a3 a4, V4 b1 b2 b3 b4)
  96   where ps = take 4 $ chunks2 hs
  97         [(a1, b1), (a2, b2), (a3, b3), (a4, b4)] = [coeffs p l | p <- ps]
  98
  99 coeffs :: (Hailstone, Hailstone) -> Lens' Position3 Rational -> (V4 Rational, Rational)
 100 coeffs (h1, h2) l =
 101   (V4 (h2 ^. vel .  l - h1 ^. vel .  l)
 102       (h1 ^. vel . _x - h2 ^. vel . _x)
 103       (h2 ^. pos .  l - h1 ^. pos .  l)
 104       (h2 ^. pos . _x - h1 ^. pos . _x)
 105   , h1 ^. pos .  l * h1 ^. vel . _x -
 106     h2 ^. pos .  l * h2 ^. vel . _x +
 107     h2 ^. pos . _x * h2 ^. vel .  l -
 108     h1 ^. pos . _x * h1 ^. vel .  l
 109   )
 110
 111 -- Parse the input file
 112
 113 stonesP :: Parser [Hailstone]
 114 stoneP :: Parser Hailstone
 115 vertexP :: Parser (V3 Rational)
 116
 117 stonesP = stoneP `sepBy` endOfLine
 118 stoneP = Hailstone <$> (vertexP <* symbolP "@") <*> vertexP
 119 vertexP = vecify <$> signed decimal <*> (symbolP "," *> signed decimal) <*> (symbolP "," *> signed decimal)
 120   where vecify x y z = V3 (x % 1) (y % 1) (z % 1)
 121
 122 symbolP :: Text -> Parser Text
 123 symbolP s = (skipSpace *> string s) <* skipSpace
 124
 125 successfulParse :: Text -> [Hailstone]
 126 successfulParse input =
 127   case parseOnly stonesP input of
 128     Left  _err -> [] -- TIO.putStr $ T.pack $ parseErrorPretty err
 129     Right matches -> matches