Stop intersectSegSegTest returning True for collinear line pairs

src/Geometry/ConvexPoly.hs

@@ -9,6 +9,7 @@ module Geometry.ConvexPoly (
     --    , centroid
     pointsToPoly,
     convexPolysOverlap,
+    convexPolysOverlapWitness,
 ) where
 
 import Control.Lens
@@ -18,6 +19,7 @@ import Geometry.Data
 import Geometry.Intersect
 import Geometry.Polygon
 import Geometry.Vector
+import Control.Applicative
 
 --import qualified Control.Foldl as L
 data ConvexPoly = ConvexPoly
@@ -48,6 +50,13 @@ convexPolysOverlap cp1 cp2 =
     dist (_cpCen cp1) (_cpCen cp2) < _cpRad cp1 + _cpRad cp2
         && polyPointsOverlap (_cpPoints cp1) (_cpPoints cp2)
 
+-- | Test whether two polygons intersect or if one is contained in the other,
+-- with witness.
+convexPolysOverlapWitness :: ConvexPoly -> ConvexPoly -> Maybe (ConvexPoly, ConvexPoly,String)
+convexPolysOverlapWitness cp1 cp2 
+    | Just s <- polyPointsOverlapWitness (_cpPoints cp1) (_cpPoints cp2) = Just (cp1,cp2,s)
+    | otherwise = Nothing
+
 
 -- | Test whether two polygons intersect or if one is contained in the other.
 polyPointsOverlap :: [Point2] -> [Point2] -> Bool
@@ -57,6 +66,14 @@ polyPointsOverlap (p : ps) (q : qs) =
         || polyPointsIntersect (p : ps) (q : qs)
 polyPointsOverlap _ _ = False
 
+-- | Test whether two polygons intersect or if one is contained in the other.
+polyPointsOverlapWitness :: [Point2] -> [Point2] -> Maybe String
+polyPointsOverlapWitness (p : ps) (q : qs)
+    | pointInPoly p (q : qs) = Just $ "Contained: "<> show p <> " in " <> show (q:qs)
+    | pointInPoly q (p : ps) = Just $ "Contained: "<> show p <> " in " <> show (q:qs)
+    | otherwise = polyPointsIntersectWitness (p : ps) (q : qs)
+polyPointsOverlapWitness _ _ = Nothing
+
 polyPointsIntersect :: [Point2] -> [Point2] -> Bool
 polyPointsIntersect (a : b : xs) ps = go a (a : b : xs) ps
   where
@@ -65,6 +82,14 @@ polyPointsIntersect (a : b : xs) ps = go a (a : b : xs) ps
     go _ _ _ = False
 polyPointsIntersect _ _ = False
 
+polyPointsIntersectWitness :: [Point2] -> [Point2] -> Maybe String
+polyPointsIntersectWitness (a : b : xs) ps = go a (a : b : xs) ps
+  where
+    go x' (a' : b' : xs') ps' = pairPolyPointsIntersectWitness a' b' ps' <|> go x' (b' : xs') ps'
+    go b' [a'] ps' = pairPolyPointsIntersectWitness a' b' ps'
+    go _ _ _ = Nothing
+polyPointsIntersectWitness _ _ = Nothing
+
 pairPolyPointsIntersect :: Point2 -> Point2 -> [Point2] -> Bool
 pairPolyPointsIntersect a' b' (c' : d' : xs') = go c' a' b' (c' : d' : xs')
   where
@@ -73,5 +98,17 @@ pairPolyPointsIntersect a' b' (c' : d' : xs') = go c' a' b' (c' : d' : xs')
     go _ _ _ _ = False
 pairPolyPointsIntersect _ _ _ = False
 
+pairPolyPointsIntersectWitness :: Point2 -> Point2 -> [Point2] -> Maybe String
+pairPolyPointsIntersectWitness a' b' (c' : d' : xs') = go c' a' b' (c' : d' : xs')
+  where
+    go x a b (c : d : xs) 
+        | intersectSegSegTest a b c d = Just $ show a <> " " <> show b <> " " <> show c <> " " <> show d
+        | otherwise = go x a b (d : xs)
+    go d a b [c] 
+        | intersectSegSegTest a b c d = Just $ show a <> " " <> show b <> " " <> show c <> " " <> show d
+        | otherwise = Nothing
+    go _ _ _ _ = Nothing
+pairPolyPointsIntersectWitness _ _ _ = Nothing
+
 makeLenses ''ConvexPoly
 deriveJSON defaultOptions ''ConvexPoly

src/Geometry/Intersect.hs

@@ -151,8 +151,10 @@ intersectSegSegTest x y z w =
     f x y z w && f z w x y && x /= y && z /= w
   where
     f a b c d =
-        (not (isRHS a b c) && not (isLHS a b d))
-            || (not (isLHS a b c) && not (isRHS a b d))
+--        (not (isRHS a b c) && not (isLHS a b d))
+--            || (not (isLHS a b c) && not (isRHS a b d))
+        (isRHS a b c && isLHS a b d)
+            || (isLHS a b c && isRHS a b d)
 
 intersectSegSegPreTest ::
     Point2 ->