Add new files

src/Geometry/ConvexPoly.hs

@@ -0,0 +1,77 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE BangPatterns #-}
+module Geometry.ConvexPoly
+    ( ConvexPoly (..)
+    , cpPoints
+    , cpCen
+    , cpRad
+    , centroid
+    , pointsToPoly
+    , convexPolysOverlap
+    ) where
+import Geometry.Data
+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
+    , _cpRad    :: Float
+    }
+pointsToPoly :: [Point2] -> ConvexPoly
+pointsToPoly xs = ConvexPoly
+    { _cpPoints = xs
+    , _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
+    && polyPointsOverlap (_cpPoints cp1) (_cpPoints cp2)
+
+--pointInConvexPoly :: Point2 -> ConvexPoly -> Bool
+--pointInConvexPoly p cp = dist p (_cpCen cp) < _cpRad cp
+--    && pointInPolyPoints p (_cpPoints cp)
+
+-- | Test whether two polygons intersect or if one is contained in the other.
+polyPointsOverlap :: [Point2] -> [Point2] -> Bool
+polyPointsOverlap (p:ps) (q:qs) = pointInPolyPoints p (q:qs)
+    || pointInPolyPoints q (p:ps)
+    || polyPointsIntersect (p:ps) (q:qs) 
+polyPointsOverlap _ _ = False
+
+-- | Test whether a point is strictly inside a polygon.
+-- Supposes the points in the polygon are listed in anticlockwise order.
+pointInPolyPoints :: Point2 -> [Point2] -> Bool
+pointInPolyPoints !p (x:xs) = all (\l -> uncurry isLHS l p) $ zip (x:xs) (xs ++ [x])
+pointInPolyPoints _ [] = False
+
+polyPointsIntersect :: [Point2] -> [Point2] -> Bool
+polyPointsIntersect (a:b:xs) ps = go a (a:b:xs) ps
+  where
+    go x' (a':b':xs') ps' = pairPolyPointsIntersect a' b' ps' || go x' (b':xs') ps'
+    go b' (a':[]) ps' = pairPolyPointsIntersect a' b' ps'
+    go _ _ _ = False
+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 _ _ _ _ = False
+pairPolyPointsIntersect _ _ _ = False
+
+centroid :: Foldable t => t Point2 -> Point2
+centroid = L.fold $ (/) <$> L.Fold (+.+) (V2 0 0) id <*> L.genericLength
+
+makeLenses ''ConvexPoly