115 lines
3.9 KiB
Haskell
115 lines
3.9 KiB
Haskell
{-# LANGUAGE BangPatterns #-}
|
|
{-# LANGUAGE TemplateHaskell #-}
|
|
|
|
module Geometry.ConvexPoly (
|
|
ConvexPoly (..),
|
|
cpPoints,
|
|
cpCen,
|
|
cpRad,
|
|
-- , centroid
|
|
pointsToPoly,
|
|
convexPolysOverlap,
|
|
convexPolysOverlapWitness,
|
|
) where
|
|
|
|
import Control.Lens
|
|
import Data.Aeson
|
|
import Data.Aeson.TH
|
|
import Geometry.Data
|
|
import Geometry.Intersect
|
|
import Geometry.Polygon
|
|
import Geometry.Vector
|
|
import Control.Applicative
|
|
|
|
--import qualified Control.Foldl as L
|
|
data ConvexPoly = ConvexPoly
|
|
{ _cpPoints :: [Point2]
|
|
, _cpCen :: Point2
|
|
, _cpRad :: Float
|
|
}
|
|
deriving (Eq, Ord, Show, Read)--, Generic) --Generic, Flat)
|
|
|
|
--instance ToJSON ConvexPoly where
|
|
-- toEncoding = genericToEncoding defaultOptions
|
|
--
|
|
--instance FromJSON ConvexPoly
|
|
|
|
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)
|
|
|
|
-- | Test whether two polygons intersect or if one is contained in the other,
|
|
-- with witness.
|
|
convexPolysOverlapWitness :: ConvexPoly -> ConvexPoly -> Maybe (ConvexPoly, ConvexPoly,String)
|
|
convexPolysOverlapWitness cp1 cp2
|
|
| Just s <- polyPointsOverlapWitness (_cpPoints cp1) (_cpPoints cp2) = Just (cp1,cp2,s)
|
|
| otherwise = Nothing
|
|
|
|
|
|
-- | Test whether two polygons intersect or if one is contained in the other.
|
|
polyPointsOverlap :: [Point2] -> [Point2] -> Bool
|
|
polyPointsOverlap (p : ps) (q : qs) =
|
|
pointInPoly p (q : qs)
|
|
|| pointInPoly q (p : ps)
|
|
|| polyPointsIntersect (p : ps) (q : qs)
|
|
polyPointsOverlap _ _ = False
|
|
|
|
-- | Test whether two polygons intersect or if one is contained in the other.
|
|
polyPointsOverlapWitness :: [Point2] -> [Point2] -> Maybe String
|
|
polyPointsOverlapWitness (p : ps) (q : qs)
|
|
| pointInPoly p (q : qs) = Just $ "Contained: "<> show p <> " in " <> show (q:qs)
|
|
| pointInPoly q (p : ps) = Just $ "Contained: "<> show p <> " in " <> show (q:qs)
|
|
| otherwise = polyPointsIntersectWitness (p : ps) (q : qs)
|
|
polyPointsOverlapWitness _ _ = Nothing
|
|
|
|
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
|
|
|
|
polyPointsIntersectWitness :: [Point2] -> [Point2] -> Maybe String
|
|
polyPointsIntersectWitness (a : b : xs) ps = go a (a : b : xs) ps
|
|
where
|
|
go x' (a' : b' : xs') ps' = pairPolyPointsIntersectWitness a' b' ps' <|> go x' (b' : xs') ps'
|
|
go b' [a'] ps' = pairPolyPointsIntersectWitness a' b' ps'
|
|
go _ _ _ = Nothing
|
|
polyPointsIntersectWitness _ _ = Nothing
|
|
|
|
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
|
|
|
|
pairPolyPointsIntersectWitness :: Point2 -> Point2 -> [Point2] -> Maybe String
|
|
pairPolyPointsIntersectWitness 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 = Just $ show a <> " " <> show b <> " " <> show c <> " " <> show d
|
|
| otherwise = go x a b (d : xs)
|
|
go d a b [c]
|
|
| intersectSegSegTest a b c d = Just $ show a <> " " <> show b <> " " <> show c <> " " <> show d
|
|
| otherwise = Nothing
|
|
go _ _ _ _ = Nothing
|
|
pairPolyPointsIntersectWitness _ _ _ = Nothing
|
|
|
|
makeLenses ''ConvexPoly
|
|
deriveJSON defaultOptions ''ConvexPoly
|