module Data.Geometry.Polygon.Core( PolygonType(..)
, Polygon(..)
, _SimplePolygon, _MultiPolygon
, SimplePolygon, MultiPolygon, SomePolygon
, fromPoints
, polygonVertices, listEdges
, outerBoundary, outerBoundaryEdges
, outerVertex, outerBoundaryEdge
, polygonHoles, polygonHoles'
, holeList
, inPolygon, insidePolygon, onBoundary
, area, signedArea
, centroid
, pickPoint
, isTriangle
, isCounterClockwise
, toCounterClockWiseOrder, toCounterClockWiseOrder'
, toClockwiseOrder, toClockwiseOrder'
, reverseOuterBoundary
, findDiagonal
, withIncidentEdges, numberVertices
, asSimplePolygon
) where
import Control.DeepSeq
import Control.Lens hiding (Simple)
import Data.Bifoldable
import Data.Bifunctor
import Data.Bitraversable
import qualified Data.CircularSeq as C
import Data.Ext
import qualified Data.Foldable as F
import Data.Geometry.Boundary
import Data.Geometry.Box
import Data.Geometry.Line
import Data.Geometry.LineSegment
import Data.Geometry.Point
import Data.Geometry.Properties
import Data.Geometry.Transformation
import Data.Geometry.Triangle (Triangle(..), inTriangle)
import Data.Geometry.Vector
import qualified Data.List as List
import Data.List.NonEmpty (NonEmpty(..))
import qualified Data.List.NonEmpty as NonEmpty
import Data.Maybe (mapMaybe, catMaybes)
import Data.Ord (comparing)
import Data.Semigroup (sconcat)
import Data.Semigroup.Foldable
import qualified Data.Sequence as Seq
import Data.Util
import Data.Vinyl.CoRec (asA)
data PolygonType = Simple | Multi
data Polygon (t :: PolygonType) p r where
SimplePolygon :: C.CSeq (Point 2 r :+ p) -> Polygon Simple p r
MultiPolygon :: C.CSeq (Point 2 r :+ p) -> [Polygon Simple p r] -> Polygon Multi p r
_SimplePolygon :: Prism' (Polygon Simple p r) (C.CSeq (Point 2 r :+ p))
_SimplePolygon = prism' SimplePolygon (\(SimplePolygon vs) -> Just vs)
_MultiPolygon :: Prism' (Polygon Multi p r) (C.CSeq (Point 2 r :+ p), [Polygon Simple p r])
_MultiPolygon = prism' (uncurry MultiPolygon) (\(MultiPolygon vs hs) -> Just (vs,hs))
instance Bifunctor (Polygon t) where
bimap = bimapDefault
instance Bifoldable (Polygon t) where
bifoldMap = bifoldMapDefault
instance Bitraversable (Polygon t) where
bitraverse f g p = case p of
SimplePolygon vs -> SimplePolygon <$> bitraverseVertices f g vs
MultiPolygon vs hs -> MultiPolygon <$> bitraverseVertices f g vs
<*> traverse (bitraverse f g) hs
instance (NFData p, NFData r) => NFData (Polygon t p r) where
rnf (SimplePolygon vs) = rnf vs
rnf (MultiPolygon vs hs) = rnf (vs,hs)
bitraverseVertices :: (Applicative f, Traversable t) => (p -> f q) -> (r -> f s)
-> t (Point 2 r :+ p) -> f (t (Point 2 s :+ q))
bitraverseVertices f g = traverse (bitraverse (traverse g) f)
type SimplePolygon = Polygon Simple
type MultiPolygon = Polygon Multi
type SomePolygon p r = Either (Polygon Simple p r) (Polygon Multi p r)
type instance Dimension (SomePolygon p r) = 2
type instance NumType (SomePolygon p r) = r
type instance Dimension (Polygon t p r) = 2
type instance NumType (Polygon t p r) = r
instance (Show p, Show r) => Show (Polygon t p r) where
show (SimplePolygon vs) = "SimplePolygon (" <> show vs <> ")"
show (MultiPolygon vs hs) = "MultiPolygon (" <> show vs <> ") (" <> show hs <> ")"
instance (Eq p, Eq r) => Eq (Polygon t p r) where
(SimplePolygon vs) == (SimplePolygon vs') = vs == vs'
(MultiPolygon vs hs) == (MultiPolygon vs' hs') = vs == vs' && hs == hs'
instance PointFunctor (Polygon t p) where
pmap f (SimplePolygon vs) = SimplePolygon (fmap (first f) vs)
pmap f (MultiPolygon vs hs) = MultiPolygon (fmap (first f) vs) (map (pmap f) hs)
instance Fractional r => IsTransformable (Polygon t p r) where
transformBy = transformPointFunctor
instance IsBoxable (Polygon t p r) where
boundingBox = boundingBoxList' . toListOf (outerBoundary.traverse.core)
type instance IntersectionOf (Line 2 r) (Boundary (Polygon t p r)) =
'[Seq.Seq (Either (Point 2 r) (LineSegment 2 () r))]
type instance IntersectionOf (Point 2 r) (Polygon t p r) = [NoIntersection, Point 2 r]
instance (Fractional r, Ord r) => (Point 2 r) `IsIntersectableWith` (Polygon t p r) where
nonEmptyIntersection = defaultNonEmptyIntersection
q `intersects` pg = q `inPolygon` pg /= Outside
q `intersect` pg | q `intersects` pg = coRec q
| otherwise = coRec NoIntersection
outerBoundary :: forall t p r. Lens' (Polygon t p r) (C.CSeq (Point 2 r :+ p))
outerBoundary = lens g s
where
g :: Polygon t p r -> C.CSeq (Point 2 r :+ p)
g (SimplePolygon vs) = vs
g (MultiPolygon vs _) = vs
s :: Polygon t p r -> C.CSeq (Point 2 r :+ p)
-> Polygon t p r
s (SimplePolygon _) vs = SimplePolygon vs
s (MultiPolygon _ hs) vs = MultiPolygon vs hs
polygonHoles :: forall p r. Lens' (Polygon Multi p r) [Polygon Simple p r]
polygonHoles = lens g s
where
g :: Polygon Multi p r -> [Polygon Simple p r]
g (MultiPolygon _ hs) = hs
s :: Polygon Multi p r -> [Polygon Simple p r]
-> Polygon Multi p r
s (MultiPolygon vs _) = MultiPolygon vs
polygonHoles' :: Traversal' (Polygon t p r) [Polygon Simple p r]
polygonHoles' = \f -> \case
p@(SimplePolygon _) -> pure p
(MultiPolygon vs hs) -> MultiPolygon vs <$> f hs
outerVertex :: Int -> Lens' (Polygon t p r) (Point 2 r :+ p)
outerVertex i = outerBoundary.C.item i
outerBoundaryEdge :: Int -> Polygon t p r -> LineSegment 2 p r
outerBoundaryEdge i p = let u = p^.outerVertex i
v = p^.outerVertex (i+1)
in LineSegment (Closed u) (Open v)
holeList :: Polygon t p r -> [Polygon Simple p r]
holeList (SimplePolygon _) = []
holeList (MultiPolygon _ hs) = hs
polygonVertices :: Polygon t p r
-> NonEmpty.NonEmpty (Point 2 r :+ p)
polygonVertices (SimplePolygon vs) = toNonEmpty vs
polygonVertices (MultiPolygon vs hs) =
sconcat $ toNonEmpty vs NonEmpty.:| map polygonVertices hs
fromPoints :: [Point 2 r :+ p] -> SimplePolygon p r
fromPoints = SimplePolygon . C.fromList
outerBoundaryEdges :: Polygon t p r -> C.CSeq (LineSegment 2 p r)
outerBoundaryEdges = toEdges . (^.outerBoundary)
listEdges :: Polygon t p r -> [LineSegment 2 p r]
listEdges pg = let f = F.toList . outerBoundaryEdges
in f pg <> concatMap f (holeList pg)
withIncidentEdges :: Polygon t p r
-> Polygon t (Two (LineSegment 2 p r)) r
withIncidentEdges (SimplePolygon vs) =
SimplePolygon $ C.zip3LWith f (C.rotateL vs) vs (C.rotateR vs)
where
f p c n = c&extra .~ SP (ClosedLineSegment p c) (ClosedLineSegment c n)
withIncidentEdges (MultiPolygon vs hs) = MultiPolygon vs' hs'
where
(SimplePolygon vs') = withIncidentEdges $ SimplePolygon vs
hs' = map withIncidentEdges hs
toEdges :: C.CSeq (Point 2 r :+ p) -> C.CSeq (LineSegment 2 p r)
toEdges vs = C.zipLWith (\p q -> LineSegment (Closed p) (Open q)) vs (C.rotateR vs)
onBoundary :: (Fractional r, Ord r) => Point 2 r -> Polygon t p r -> Bool
q `onBoundary` pg = any (q `onSegment`) es
where
out = SimplePolygon $ pg^.outerBoundary
es = concatMap (F.toList . outerBoundaryEdges) $ out : holeList pg
inPolygon :: forall t p r. (Fractional r, Ord r)
=> Point 2 r -> Polygon t p r
-> PointLocationResult
q `inPolygon` pg
| q `onBoundary` pg = OnBoundary
| odd kl && odd kr && not (any (q `inHole`) hs) = Inside
| otherwise = Outside
where
l = horizontalLine $ q^.yCoord
intersectionPoint = asA @(Point 2 r) . (`intersect` l)
SP kl kr = count (\p -> (p^.xCoord) `compare` (q^.xCoord))
. mapMaybe intersectionPoint . F.toList . outerBoundaryEdges $ pg
inHole = insidePolygon
hs = holeList pg
count :: (a -> Ordering) -> [a] -> SP Int Int
count f = foldr (\x (SP lts gts) -> case f x of
LT -> SP (lts + 1) gts
EQ -> SP lts gts
GT -> SP lts (gts + 1)) (SP 0 0)
insidePolygon :: (Fractional r, Ord r) => Point 2 r -> Polygon t p r -> Bool
q `insidePolygon` pg = q `inPolygon` pg == Inside
area :: Fractional r => Polygon t p r -> r
area poly@(SimplePolygon _) = abs $ signedArea poly
area (MultiPolygon vs hs) = area (SimplePolygon vs) - sum [area h | h <- hs]
signedArea :: Fractional r => SimplePolygon p r -> r
signedArea poly = x / 2
where
x = sum [ p^.core.xCoord * q^.core.yCoord - q^.core.xCoord * p^.core.yCoord
| LineSegment' p q <- F.toList $ outerBoundaryEdges poly ]
centroid :: Fractional r => SimplePolygon p r -> Point 2 r
centroid poly = Point $ sum' xs ^/ (6 * signedArea poly)
where
xs = [ (toVec p ^+^ toVec q) ^* (p^.xCoord * q^.yCoord - q^.xCoord * p^.yCoord)
| LineSegment' (p :+ _) (q :+ _) <- F.toList $ outerBoundaryEdges poly ]
sum' = F.foldl' (^+^) zero
pickPoint :: (Ord r, Fractional r) => Polygon p t r -> Point 2 r
pickPoint pg | isTriangle pg = centroid . SimplePolygon $ pg^.outerBoundary
| otherwise = let LineSegment' (p :+ _) (q :+ _) = findDiagonal pg
in p .+^ (0.5 *^ (q .-. p))
isTriangle :: Polygon p t r -> Bool
isTriangle = \case
SimplePolygon vs -> go vs
MultiPolygon vs [] -> go vs
MultiPolygon _ _ -> False
where
go vs = case toNonEmpty vs of
(_ :| [_,_]) -> True
_ -> False
findDiagonal :: (Ord r, Fractional r) => Polygon t p r -> LineSegment 2 p r
findDiagonal pg = List.head . catMaybes . F.toList $ diags
where
vs = pg^.outerBoundary
diags = C.zip3LWith f (C.rotateL vs) vs (C.rotateR vs)
f u v w = case ccw (u^.core) (v^.core) (w^.core) of
CCW -> Just $ findDiag u v w
CW -> Nothing
CoLinear -> Nothing
findDiag u v w = let t = Triangle u v w
uw = ClosedLineSegment u w
in maybe uw (ClosedLineSegment v)
. safeMaximumOn (distTo $ supportingLine uw)
. filter (\(z :+ _) -> z `inTriangle` t == Inside)
. F.toList . polygonVertices
$ pg
distTo l (z :+ _) = sqDistanceTo z l
safeMaximumOn :: Ord b => (a -> b) -> [a] -> Maybe a
safeMaximumOn f = \case
[] -> Nothing
xs -> Just $ List.maximumBy (comparing f) xs
isCounterClockwise :: (Eq r, Fractional r) => Polygon t p r -> Bool
isCounterClockwise = (\x -> x == abs x) . signedArea
. fromPoints . F.toList . (^.outerBoundary)
toClockwiseOrder :: (Eq r, Fractional r) => Polygon t p r -> Polygon t p r
toClockwiseOrder p = (toClockwiseOrder' p)&polygonHoles'.traverse %~ toCounterClockWiseOrder'
toClockwiseOrder' :: (Eq r, Fractional r) => Polygon t p r -> Polygon t p r
toClockwiseOrder' pg
| isCounterClockwise pg = reverseOuterBoundary pg
| otherwise = pg
toCounterClockWiseOrder :: (Eq r, Fractional r) => Polygon t p r -> Polygon t p r
toCounterClockWiseOrder p =
(toCounterClockWiseOrder' p)&polygonHoles'.traverse %~ toClockwiseOrder'
toCounterClockWiseOrder' :: (Eq r, Fractional r) => Polygon t p r -> Polygon t p r
toCounterClockWiseOrder' p
| not $ isCounterClockwise p = reverseOuterBoundary p
| otherwise = p
reverseOuterBoundary :: Polygon t p r -> Polygon t p r
reverseOuterBoundary p = p&outerBoundary %~ C.reverseDirection
asSimplePolygon :: Polygon t p r -> SimplePolygon p r
asSimplePolygon poly@(SimplePolygon _) = poly
asSimplePolygon (MultiPolygon vs _) = SimplePolygon vs
numberVertices :: Polygon t p r -> Polygon t (SP Int p) r
numberVertices = snd . bimapAccumL (\a p -> (a+1,SP a p)) (\a r -> (a,r)) 0