Split UseItem module

2021-03-16 11:54:41 +01:00
parent 97fd7f5576
commit ca5ff88522
19 changed files with 609 additions and 96 deletions
@@ -0,0 +1,110 @@
+module Geometry.Intersect
+    where
+import Geometry.Data
+
+import Control.Applicative
+
+intersectSegBezquad :: Point2 -> Point2 -> Point2 -> Point2 -> Point2 -> [Point2]
+intersectSegBezquad = undefined
+
+intersectLineLine' :: Point2 -> Point2 -> Point2 -> Point2 -> Maybe Point2
+{-# INLINE intersectLineLine' #-}
+intersectLineLine' (x1,y1) (x2,y2) (x3,y3) (x4,y4)
+    | den == 0 = Nothing
+    | otherwise = Just (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)
+
+intersectSegSeg' :: Point2 -> Point2 -> Point2 -> Point2 -> Maybe Point2
+{-# INLINE intersectSegSeg' #-}
+intersectSegSeg' (x1,y1) (x2,y2) (x3,y3) (x4,y4)
+    | den == 0 = Nothing
+    | den > 0 && (t' < 0 || u' < 0 || t' > den || u' > den)
+        = Nothing
+    | den < 0 && (t' > 0 || u' > 0 || t' < den || u' < den)
+        = Nothing
+    | otherwise = Just (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)
+
+intersectSegLineFrom' :: Point2 -> Point2 -> Point2 -> Point2 -> Maybe Point2
+{-# INLINE intersectSegLineFrom' #-}
+intersectSegLineFrom' (x1,y1) (x2,y2) (x3,y3) (x4,y4)
+    | den == 0 = Nothing
+    | den > 0 && ( t' < 0 || u' < 0 || t' > den )
+        = Nothing
+    | den < 0 && ( t' > 0 || u' > 0 || t' < den )
+        = Nothing
+    | otherwise = Just (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)
+
+intersectSegLine' :: Point2 -> Point2 -> Point2 -> Point2 -> Maybe Point2
+{-# INLINE intersectSegLine' #-}
+intersectSegLine' (x1,y1) (x2,y2) (x3,y3) (x4,y4)
+    | den == 0 = Nothing
+    | den > 0 && (t' < 0 || t' > den)
+        = Nothing
+    | den < 0 && (t' > 0 || t' < den)
+        = Nothing
+    | otherwise = Just (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)
+
+-- intersectSegSeg is sometimes broken-- the following fixes at least some of
+-- the cases
+-- it is, however, slow
+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 
+                        then Just (x,y)
+                        else Nothing
+    where inbetween  x = ((ax <= x && x <= bx) || (bx <= x && x <= ax)) &&
+                         ((cx <= x && x <= dx) || (dx <= x && x <= cx))
+          inbetween' y = ((ay <= y && y <= by) || (by <= y && y <= ay)) &&
+                         ((cy <= y && y <= dy) || (dy <= y && y <= cy))
+
+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))
+    | linGrad c d == Nothing = fmap ((,) cx) $ axisInt (a *-* (cx,0)) (b *-* (cx,0))
+    | otherwise              
+        = case linGrad a b ^-^ linGrad c d of
+            Just 0 -> Nothing
+            _      -> liftA2 (,) newx
+                                 ((linGrad a b ^*^ newx) ^+^ axisInt a b)
+    where (^-^) = liftA2 (-)
+          (^+^) = liftA2 (+)
+          (^/^) = liftA2 (/)
+          (^*^) = liftA2 (*)
+          newx  = (axisInt c d ^-^ axisInt a b) ^/^ (linGrad a b ^-^ linGrad c d)
+          (*-*) (ax,ay) (bx,by) = (ax-bx,ay-by)
+
+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
+
+roundPoint2 :: Point2 -> Point2
+roundPoint2 (x,y) = (fromIntegral $ round x,fromIntegral $ round y)
+
+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)
+
+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 (*)
+
+
+intersectSegsSeg :: [Point2] -> Point2 -> Point2 -> Maybe Point2
+intersectSegsSeg = undefined