Improve intersection test--fails sometimes

src/Geometry/ConvexPoly.hs

@@ -14,23 +14,21 @@ import Geometry.Vector
 import Geometry.LHS
 import Geometry.Intersect
 
-import Data.Maybe
 import Control.Lens
 import qualified Control.Foldl as L
 data ConvexPoly = ConvexPoly
     { _cpPoints :: [Point2]
-    , _cpCen :: Point2
+    , _cpCen    :: Point2
     , _cpRad    :: Float
     }
 pointsToPoly :: [Point2] -> ConvexPoly
 pointsToPoly xs = ConvexPoly
     { _cpPoints = xs
-    , _cpCen = cen
+    , _cpCen    = cen
     , _cpRad    = minimum $ map (dist cen) xs
     }
   where
     cen = centroid xs
-
 -- | Test whether two polygons intersect or if one is contained in the other.
 convexPolysOverlap :: ConvexPoly -> ConvexPoly -> Bool
 convexPolysOverlap cp1 cp2 = dist (_cpCen cp1) (_cpCen cp2) < _cpRad cp1 + _cpRad cp2
@@ -64,10 +62,8 @@ polyPointsIntersect _ _ = False
 pairPolyPointsIntersect :: Point2 -> Point2 -> [Point2] -> Bool
 pairPolyPointsIntersect a' b' (c':d':xs') = go c' a' b' (c':d':xs')
   where
-    go x a b (c:d:xs) 
-        | isJust $ myIntersectSegSeg a b c d = True
-        | otherwise = go x a b (d:xs)
-    go d a b [c] = isJust $ myIntersectSegSeg a b c d
+    go x a b (c:d:xs) = intersectSegSegTest a b c d || go x a b (d:xs)
+    go d a b [c] = intersectSegSegTest a b c d
     go _ _ _ _ = False
 pairPolyPointsIntersect _ _ _ = False
 

src/Geometry/Intersect.hs

@@ -5,6 +5,7 @@ Testing for and finding intersection points.
 module Geometry.Intersect
     where
 import Geometry.Data
+import Geometry.LHS
 import Control.Applicative
 
 import Data.Maybe (isNothing)
@@ -74,6 +75,30 @@ intersectSegLine' (V2 x1 y1) (V2 x2 y2) (V2 x3 y3) (V2 x4 y4)
     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)
+-- | It is not always necessary to find a point of intersection, sometimes a
+-- test may suffice.
+intersectSegSegTest
+    :: Point2
+    -> Point2
+    -> Point2
+    -> Point2
+    -> Bool
+{-# INLINE intersectSegSegTest #-}
+intersectSegSegTest a' b' c' d' 
+    = f a' b' c' d' && f c' d' a' b'
+  where
+    f a b c d =  (      isLHS a b c  && not (isLHS a b d) ) 
+              || ( not (isLHS a b c) &&      isLHS a b d  )
+intersectSegSegPreTest
+    :: Point2
+    -> Point2
+    -> Point2
+    -> Point2
+    -> Maybe Point2
+{-# INLINE intersectSegSegPreTest #-}
+intersectSegSegPreTest a b c d
+    | intersectSegSegTest a b c d = myIntersectSegSeg a b c d
+    | otherwise = Nothing
 -- | Due to floating point issues, 'intersectSegSeg'' is not always 
 -- accurate---'myIntersectSegSeg'
 -- fixes at least some of