diff --git a/src/Geometry/Intersect.hs b/src/Geometry/Intersect.hs index 44277a725..e43b1fdcf 100644 --- a/src/Geometry/Intersect.hs +++ b/src/Geometry/Intersect.hs @@ -1,12 +1,9 @@ module Geometry.Intersect where import Geometry.Data - import Control.Applicative -intersectSegBezquad :: Point2 -> Point2 -> Point2 -> Point2 -> Point2 -> [Point2] -intersectSegBezquad = undefined - +-- | If two lines intersect, return 'Just' that point. intersectLineLine' :: Point2 -> Point2 -> Point2 -> Point2 -> Maybe Point2 {-# INLINE intersectLineLine' #-} intersectLineLine' (x1,y1) (x2,y2) (x3,y3) (x4,y4) @@ -16,6 +13,7 @@ intersectLineLine' (x1,y1) (x2,y2) (x3,y3) (x4,y4) den = (x1-x2)*(y3-y4) - (y1-y2)*(x3-x4) t' = (x1-x3)*(y3-y4) - (y1-y3)*(x3-x4) +-- | If two segments intersect, return 'Just' that point. intersectSegSeg' :: Point2 -> Point2 -> Point2 -> Point2 -> Maybe Point2 {-# INLINE intersectSegSeg' #-} intersectSegSeg' (x1,y1) (x2,y2) (x3,y3) (x4,y4) @@ -30,6 +28,8 @@ intersectSegSeg' (x1,y1) (x2,y2) (x3,y3) (x4,y4) t' = (x1-x3)*(y3-y4) - (y1-y3)*(x3-x4) u' = (y1-y2)*(x1-x3) - (x1-x2)*(y1-y3) +-- | Intended to intersect a segment with a half-line-segment, ie a segment +-- extending infinitely in one direction. intersectSegLineFrom' :: Point2 -> Point2 -> Point2 -> Point2 -> Maybe Point2 {-# INLINE intersectSegLineFrom' #-} intersectSegLineFrom' (x1,y1) (x2,y2) (x3,y3) (x4,y4) @@ -44,7 +44,7 @@ intersectSegLineFrom' (x1,y1) (x2,y2) (x3,y3) (x4,y4) t' = (x1-x3)*(y3-y4) - (y1-y3)*(x3-x4) u' = (y1-y2)*(x1-x3) - (x1-x2)*(y1-y3) --- this is probably not correct... +-- | Similar to 'intersectSegLineFrom'', but this version is probably not correct... intersectSegLineext :: Point2 -> Point2 -> Point2 -> Point2 -> Maybe Point2 {-# INLINE intersectSegLineext #-} intersectSegLineext (x1,y1) (x2,y2) (x3,y3) (x4,y4) @@ -59,6 +59,7 @@ intersectSegLineext (x1,y1) (x2,y2) (x3,y3) (x4,y4) t' = (x1-x3)*(y3-y4) - (y1-y3)*(x3-x4) u' = (y1-y2)*(x1-x3) - (x1-x2)*(y1-y3) +-- | Intersect a segment with a line. intersectSegLine' :: Point2 -> Point2 -> Point2 -> Point2 -> Maybe Point2 {-# INLINE intersectSegLine' #-} intersectSegLine' (x1,y1) (x2,y2) (x3,y3) (x4,y4) @@ -73,9 +74,13 @@ intersectSegLine' (x1,y1) (x2,y2) (x3,y3) (x4,y4) t' = (x1-x3)*(y3-y4) - (y1-y3)*(x3-x4) u' = (y1-y2)*(x1-x3) - (x1-x2)*(y1-y3) --- intersectSegSeg is sometimes broken-- the following fixes at least some of --- the cases --- it is, however, slow +-- | Due to floating point issues, 'intersectSegSeg'' is not always +-- accurate---'myIntersectSegSeg' +-- fixes at least some of +-- the problem cases by transforming the points into rationals and then doing the +-- intersection. +-- This version is, probably, slower---both testing and benchmarking should be +-- done. myIntersectSegSeg a@(ax,ay) b@(bx,by) c@(cx,cy) d@(dx,dy) = case ratIntersectLineLine a b c d of Nothing -> Nothing Just (x,y) -> if inbetween x && inbetween' y @@ -86,6 +91,7 @@ myIntersectSegSeg a@(ax,ay) b@(bx,by) c@(cx,cy) d@(dx,dy) = case ratIntersectLin inbetween' y = ((ay <= y && y <= by) || (by <= y && y <= ay)) && ((cy <= y && y <= dy) || (dy <= y && y <= cy)) +-- | Polymorphic intersection of fractional line points. myIntersectLineLine :: (Eq a,Fractional a) => (a,a) -> (a,a) -> (a,a) -> (a,a) -> Maybe (a,a) myIntersectLineLine a@(ax,ay) b c@(cx,cy) d | linGrad a b == Nothing = fmap ((,) ax) $ axisInt (c *-* (ax,0)) (d *-* (ax,0)) @@ -102,24 +108,43 @@ myIntersectLineLine a@(ax,ay) b c@(cx,cy) d newx = (axisInt c d ^-^ axisInt a b) ^/^ (linGrad a b ^-^ linGrad c d) (*-*) (ax,ay) (bx,by) = (ax-bx,ay-by) +-- | Transforms floating points to rationals then performs line intersection. ratIntersectLineLine :: Point2 -> Point2 -> Point2 -> Point2 -> Maybe Point2 ratIntersectLineLine a b c d = fmap toNumPoint2 $ myIntersectLineLine (toRatPoint2 a) (toRatPoint2 b) (toRatPoint2 c) (toRatPoint2 d) where toRatPoint2 (x,y) = (toRational x, toRational y) toNumPoint2 (x,y) = (fromRational x, fromRational y) f = toRatPoint2 . roundPoint2 +-- | Round the floats within a 'Point2' to the nearest integer. +-- Rounding jumps after intervals of .5: +-- +-- >>> roundPoint (0.5,0.5001) +-- (0.0,1.0) +-- +-- but is symmetric around 0: +-- +-- >>> roundPoint2 (0.5,-0.5) +-- (0.0,0.0) +-- roundPoint2 :: Point2 -> Point2 roundPoint2 (x,y) = (fromIntegral $ round x,fromIntegral $ round y) +-- | Given two points, finds the linear gradient if it is non-infinite. linGrad :: (Eq a,Fractional a) => (a,a) -> (a,a) -> Maybe a linGrad (x,y) (a,b) | x-a == 0 = Nothing | otherwise = Just $ (y-b)/(x-a) +-- | Given two points, finds the intersection with the y axis if it exists. axisInt :: (Eq a,Fractional a) => (a,a) -> (a,a) -> Maybe a axisInt p (a,b) = pure b ^-^ (pure a ^*^ linGrad p (a,b)) where (^-^) = liftA2 (-) (^*^) = liftA2 (*) - +-- | Placeholder, undefined. intersectSegsSeg :: [Point2] -> Point2 -> Point2 -> Maybe Point2 intersectSegsSeg = undefined + +-- | Placeholder: should intersect a segment with a bezier curve. +intersectSegBezquad :: Point2 -> Point2 -> Point2 -> Point2 -> Point2 -> [Point2] +intersectSegBezquad = undefined +