module Data.Geometry.Polygon where
import Control.Lens hiding (Simple)
import Data.Bifunctor
import qualified Data.CircularSeq as C
import Data.Ext
import qualified Data.List.NonEmpty as NonEmpty
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.Vector
import Data.Maybe (mapMaybe)
import Data.Proxy
import Data.Semigroup
import Data.Util
import Frames.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
type SimplePolygon = Polygon Simple
type MultiPolygon = Polygon Multi
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 Num r => IsTransformable (Polygon t p r) where
transformBy = transformPointFunctor
instance IsBoxable (Polygon t p r) where
boundingBox = boundingBoxList' . toListOf (outerBoundary.traverse.core)
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
holes :: forall p r. Lens' (Polygon Multi p r) [Polygon Simple p r]
holes = 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
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) = C.toNonEmpty vs
polygonVertices (MultiPolygon vs hs) =
sconcat $ C.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)
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 (Proxy :: Proxy (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
isCounterClockwise :: (Eq r, Fractional r) => Polygon t p r -> Bool
isCounterClockwise = (\x -> x == abs x) . signedArea
. fromPoints . take 3 . F.toList . (^.outerBoundary)
toClockwiseOrder :: (Eq r, Fractional r) => Polygon t p r -> Polygon t p r
toClockwiseOrder p
| isCounterClockwise p = p&outerBoundary %~ C.reverseDirection
| otherwise = p
toCounterClockWiseOrder :: (Eq r, Fractional r) => Polygon t p r -> Polygon t p r
toCounterClockWiseOrder p
| not $ isCounterClockwise p = p&outerBoundary %~ C.reverseDirection
| otherwise = p
asSimplePolygon :: Polygon t p r -> SimplePolygon p r
asSimplePolygon poly@(SimplePolygon _) = poly
asSimplePolygon (MultiPolygon vs _) = SimplePolygon vs
cmpExtreme :: (Num r, Ord r)
=> Vector 2 r -> Point 2 r :+ p -> Point 2 r :+ q -> Ordering
cmpExtreme u p q = u `dot` (p^.core .-. q^.core) `compare` 0
extremesLinear :: (Ord r, Num r) => Vector 2 r -> Polygon t p r
-> (Point 2 r :+ p, Point 2 r :+ p)
extremesLinear u p = let vs = p^.outerBoundary
f = cmpExtreme u
in (F.minimumBy f vs, F.maximumBy f vs)