From 75e93dfcd513e66cd7e0f2a6f09f228f05c9177b Mon Sep 17 00:00:00 2001 From: justin Date: Sat, 11 Oct 2025 11:46:39 +0100 Subject: [PATCH] Cleanup --- src/Geometry/Intersect.hs | 66 +++++++++++++++++++++++---------------- src/Geometry/Vector.hs | 6 ---- 2 files changed, 39 insertions(+), 33 deletions(-) diff --git a/src/Geometry/Intersect.hs b/src/Geometry/Intersect.hs index f775178d8..b87c06f90 100644 --- a/src/Geometry/Intersect.hs +++ b/src/Geometry/Intersect.hs @@ -17,12 +17,20 @@ import Linear -- | If two lines intersect, return 'Just' that point. intersectLineLine :: Point2 -> Point2 -> Point2 -> Point2 -> Maybe Point2 {-# INLINE intersectLineLine #-} -intersectLineLine (V2 x1 y1) (V2 x2 y2) (V2 x3 y3) (V2 x4 y4) - | den == 0 = Nothing - | otherwise = Just $ V2 (x1 + (x2 - x1) * t' / den) (y1 + (y2 - y1) * t' / den) - where - den = (x1 - x2) * (y3 - y4) - (y1 - y2) * (x3 - x4) - t' = (x1 - x3) * (y3 - y4) - (y1 - y3) * (x3 - x4) +--intersectLineLine a@(V2 x1 y1) b@(V2 x2 y2) c@(V2 x3 y3) d@(V2 x4 y4) +intersectLineLine a b c d = do + let den = detV (a-b) (c-d) + guard $ den /= 0 + let t = detV (a-c) (c-d) + return $ a + (t/den) *^ (b-a) +-- | den == 0 = Nothing +-- | otherwise = Just $ a + (t/den) *^ (b - a) +---- | otherwise = Just $ V2 (x1 + (x2 - x1) * t / den) (y1 + (y2 - y1) * t / den) +-- where +-- den = detV (a-b) (c-d) +---- den = (x1 - x2) * (y3 - y4) - (y1 - y2) * (x3 - x4) +-- t = detV (a-c) (c-d) --x1 - x3) * (y3 - y4) - (y1 - y3) * (x3 - x4) +---- t = (x1 - x3) * (y3 - y4) - (y1 - y3) * (x3 - x4) ---- note that the second argument is a vector, not the second point of the line --intersectLinePlane :: Point3 -> Point3 -> Point3 -> Point3 -> Maybe Point3 @@ -38,13 +46,17 @@ intersectLinePlaneAlong x y p n = do -- this needs to be checked intersectSegPlane :: Point3 -> Point3 -> Point3 -> Point3 -> Maybe Point3 -intersectSegPlane sp ep p n = case dot v n of - 0 -> Nothing - x -> case dot (p - sp) n / x of - d | d >= 0 && d <= 1 -> Just $ sp + d *.*.* v - _ -> Nothing - where - v = ep - sp +intersectSegPlane x y p n = do + d <- intersectLinePlaneAlong x y p n + guard $ d >= 0 && d < 1 + return $ x + d *^ (y - x) +--case dot v n of +-- 0 -> Nothing +-- x -> case dot (p - sp) n / x of +-- d | d >= 0 && d <= 1 -> Just $ sp + d *.*.* v +-- _ -> Nothing +-- where +-- v = ep - sp intersectSegSurface :: Point3 -> @@ -112,20 +124,20 @@ intersectSegRay (V2 x1 y1) (V2 x2 y2) (V2 x3 y3) (V2 x4 y4) t' = (x1 - x3) * (y3 - y4) - (y1 - y3) * (x3 - x4) u' = (y1 - y2) * (x1 - x3) - (x1 - x2) * (y1 - y3) --- | Similar to 'intersectSegLineFrom'', but this version is probably not correct... -intersectSegLineext :: Point2 -> Point2 -> Point2 -> Point2 -> Maybe Point2 -{-# INLINE intersectSegLineext #-} -intersectSegLineext (V2 x1 y1) (V2 x2 y2) (V2 x3 y3) (V2 x4 y4) - | den == 0 = Nothing - | den > 0 && (t' < 0 || u' < den || t' > den) = - Nothing - | den < 0 && (t' > 0 || u' > - den || t' < den) = - Nothing - | otherwise = Just $ V2 (x1 + (x2 - x1) * t' / den) (y1 + (y2 - y1) * t' / den) - where - den = (x1 - x2) * (y3 - y4) - (y1 - y2) * (x3 - x4) - t' = (x1 - x3) * (y3 - y4) - (y1 - y3) * (x3 - x4) - u' = (y1 - y2) * (x1 - x3) - (x1 - x2) * (y1 - y3) +---- | Similar to 'intersectSegLineFrom'', but this version is probably not correct... +--intersectSegLineext :: Point2 -> Point2 -> Point2 -> Point2 -> Maybe Point2 +--{-# INLINE intersectSegLineext #-} +--intersectSegLineext (V2 x1 y1) (V2 x2 y2) (V2 x3 y3) (V2 x4 y4) +-- | den == 0 = Nothing +-- | den > 0 && (t' < 0 || u' < den || t' > den) = +-- Nothing +-- | den < 0 && (t' > 0 || u' > - den || t' < den) = +-- Nothing +-- | otherwise = Just $ V2 (x1 + (x2 - x1) * t' / den) (y1 + (y2 - y1) * t' / den) +-- where +-- den = (x1 - x2) * (y3 - y4) - (y1 - y2) * (x3 - x4) +-- t' = (x1 - x3) * (y3 - y4) - (y1 - y3) * (x3 - x4) +-- u' = (y1 - y2) * (x1 - x3) - (x1 - x2) * (y1 - y3) {- | Intersect a segment with a line. the line intersects with the first endpoint of the segment diff --git a/src/Geometry/Vector.hs b/src/Geometry/Vector.hs index 31b7da691..7fd288a14 100644 --- a/src/Geometry/Vector.hs +++ b/src/Geometry/Vector.hs @@ -173,12 +173,6 @@ magV :: Point2 -> Float {-# INLINE magV #-} magV (V2 x y) = sqrt $ x ^ (2 :: Int) + y ^ (2 :: Int) -{- | Magnitude of the cross product of two vectors. -Identical to detV. --} -crossV :: Point2 -> Point2 -> Float -crossV (V2 ax ay) (V2 bx by) = ax * by - ay * bx - -- | TO CHECK Orthographic projection of one vector onto another. projV :: Point2 -> Point2 -> Point2 projV fromv onv