Commit before attempting to allow for non-convex chasm shapes

src/Geometry/Intersect.hs

@@ -83,14 +83,17 @@ intersectSegSeg (V2 x1 y1) (V2 x2 y2) (V2 x3 y3) (V2 x4 y4)
 
 {- | Intended to intersect a segment with a half-line-segment, ie a segment
  extending infinitely in one direction.
+Will intersect with the first endpoint of the segment, but NOT the second.
+This is to allow sensible intersections with polygons described as lists of points.
+It will also intersect with the point of the ray.
 -}
-intersectSegLineFrom :: Point2 -> Point2 -> Point2 -> Point2 -> Maybe Point2
-{-# INLINE intersectSegLineFrom #-}
-intersectSegLineFrom (V2 x1 y1) (V2 x2 y2) (V2 x3 y3) (V2 x4 y4)
+intersectSegRay :: Point2 -> Point2 -> Point2 -> Point2 -> Maybe Point2
+{-# INLINE intersectSegRay #-}
+intersectSegRay (V2 x1 y1) (V2 x2 y2) (V2 x3 y3) (V2 x4 y4)
     | den == 0 = Nothing
-    | den > 0 && (t' < 0 || u' < 0 || t' > den) =
+    | den > 0 && (t' < 0 || u' < 0 || t' >= den) =
         Nothing
-    | den < 0 && (t' > 0 || u' > 0 || t' < den) =
+    | den < 0 && (t' > 0 || u' > 0 || t' <= den) =
         Nothing
     | otherwise = Just $ V2 (x1 + (x2 - x1) * t' / den) (y1 + (y2 - y1) * t' / den)
   where
@@ -114,18 +117,20 @@ intersectSegLineext (V2 x1 y1) (V2 x2 y2) (V2 x3 y3) (V2 x4 y4)
     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
+-- but NOT the second
 intersectSegLine :: Point2 -> Point2 -> Point2 -> Point2 -> Maybe Point2
 {-# INLINE intersectSegLine #-}
 intersectSegLine (V2 x1 y1) (V2 x2 y2) (V2 x3 y3) (V2 x4 y4)
     | den == 0 = Nothing
-    | den > 0 && (t' < 0 || t' > den) =
+    | den > 0 && (t < 0 || t >= den) =
         Nothing
-    | den < 0 && (t' > 0 || t' < den) =
+    | den < 0 && (t > 0 || t <= den) =
         Nothing
-    | otherwise = Just $ V2 (x1 + (x2 - x1) * t' / den) (y1 + (y2 - y1) * t' / den)
+    | 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)
+    t = (x1 - x3) * (y3 - y4) - (y1 - y3) * (x3 - x4)
 
 --u'  = (y1-y2)*(x1-x3) - (x1-x2)*(y1-y3)
 

src/Geometry/LHS.hs

@@ -1,40 +1,51 @@
-module Geometry.LHS
-    ( isLHS
-    , isRHS
-    ) where
+module Geometry.LHS (
+    isLHS,
+    isRHS,
+) where
+
 import Geometry.Data
--- | Test whether a point is stricly on the LHS of a line.
--- Returns False if the line is of zero length.
-isLHS 
-    :: Point2  -- ^ First line point. 
-    -> Point2  -- ^ Second line point.
-    -> Point2  -- ^ Point not on line.
-    -> Bool
+
+{- | Test whether a point is stricly on the LHS of a line.
+ Returns False if the line is of zero length.
+-}
+isLHS ::
+    -- | First line point.
+    Point2 ->
+    -- | Second line point.
+    Point2 ->
+    -- | Point not on line.
+    Point2 ->
+    Bool
 {-# INLINE isLHS #-}
-isLHS (V2 x y)      (V2 x' y')   (V2 x'' y'') 
-    | (x,y) == (x',y')  = False
+isLHS (V2 x y) (V2 x' y') (V2 x'' y'')
+    | (x, y) == (x', y') = False
     | otherwise = a1 * b2 - a2 * b1 > 0
   where
     a1 = x' - x
     a2 = y' - y
     b1 = x'' - x
     b2 = y'' - y
--- | Test whether a point is on the RHS of a line.
--- Returns False if the line is of zero length.
-isRHS 
-    :: Point2 -- ^ First line point. 
-    -> Point2 -- ^ Second line point.
-    -> Point2 -- ^ Point not on line.
-    -> Bool
+
+{- | Test whether a point is on the RHS of a line.
+ Returns False if the line is of zero length.
+-}
+isRHS ::
+    -- | First line point.
+    Point2 ->
+    -- | Second line point.
+    Point2 ->
+    -- | Point not on line.
+    Point2 ->
+    Bool
 {-# INLINE isRHS #-}
-isRHS 
-    (V2 x y)       
-    (V2 x' y')    
-    (V2 x'' y'')  
-    | (x,y) == (x',y')  = False
-    | otherwise = a1 * b2 - a2 * b1 < 0
-  where 
-    a1 = x' - x
-    a2 = y' - y
-    b1 = x'' - x
-    b2 = y'' - y
+isRHS
+    (V2 x y)
+    (V2 x' y')
+    (V2 x'' y'')
+        | (x, y) == (x', y') = False
+        | otherwise = a1 * b2 - a2 * b1 < 0
+      where
+        a1 = x' - x
+        a2 = y' - y
+        b1 = x'' - x
+        b2 = y'' - y

src/Geometry/Polygon.hs

@@ -80,11 +80,24 @@ pointInOrOnPolygon _ _ = undefined
 
 {- | Test whether a point is strictly inside a polygon.
  Supposes the points in the polygon are listed in anticlockwise order.
+Requires that the polygon is convex.
 -}
 pointInPoly :: Point2 -> [Point2] -> Bool
 pointInPoly !p (x : xs) = all (\l -> uncurry isLHS l p) $ zip (x : xs) (xs ++ [x])
 pointInPoly _ [] = False
 
+inSimplePoly :: Point2 -> [Point2] -> Bool
+inSimplePoly p (x:xs) = foldl' (flip f) True $ zip (x:xs) (xs ++ [x])
+  where
+    f (a,b) = case intersectSegRay a b p (p + V2 1 0) of
+        Nothing -> id
+        Just {} -> not
+inSimplePoly _ [] = False
+
+---- implement Dan Sunday point in polygon algorithm?
+--wnPointPoly :: Point2 -> Point2 -> Point2 -> Int
+--wnPointPoly p x y = 0
+
 circInPolygon :: Point2 -> Float -> [Point2] -> Bool
 circInPolygon !p !r (x : xs) = all f $ zip (x : xs) (xs ++ [x])
   where