74 lines
2.3 KiB
Haskell
74 lines
2.3 KiB
Haskell
{-# LANGUAGE TemplateHaskell #-}
|
|
{-# LANGUAGE BangPatterns #-}
|
|
module Geometry.ConvexPoly
|
|
( ConvexPoly (..)
|
|
, cpPoints
|
|
, cpCen
|
|
, cpRad
|
|
-- , centroid
|
|
, pointsToPoly
|
|
, convexPolysOverlap
|
|
, pointInPolyPoints
|
|
) where
|
|
import Geometry.Data
|
|
import Geometry.Vector
|
|
import Geometry.LHS
|
|
import Geometry.Intersect
|
|
import Geometry.Polygon
|
|
|
|
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 = maximum $ 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) = 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
|
|
|
|
|
|
makeLenses ''ConvexPoly
|