module Geom2d.Shape.Internal
( Circle (..)
, mkCircleInt
, radius
, center
, Polygon (..)
, convexHull'
, rectangleInt
, Shape (..)
, Spatial (..)
, Box (..)
, spatialBox
)
where
import Data.Function
import Data.List hiding (intersect)
import Data.Maybe
import Geom2d.Distance
import Geom2d.Intersect
import Geom2d.Line.Internal
import Geom2d.Point
import Geom2d.Point.Internal
import Geom2d.Rotation
import Geom2d.Translate
import Test.QuickCheck
data Circle p a = Circle (p a) a deriving (Show,Read,Eq)
instance (Point p, Distance p p) => Distance (Circle p) p where
distance (Circle m r) p =
max (distance m p r) 0
instance (Point p, Distance p p) => Distance p (Circle p) where
distance = flip distance
instance (Floating a, Ord a, Distance p p) =>
Intersect (Circle p a) (p a) where
intersect (Circle m r) p
| distance m p <= r = True
| otherwise = False
instance (Floating a, Ord a, Distance p p) =>
Intersect (p a) (Circle p a) where
intersect = flip intersect
instance (Floating a, Ord a, Distance p p) =>
Intersect (Circle p a) (Circle p a) where
intersect (Circle m1 r1) (Circle m2 r2) =
distance m1 m2 <= r1 + r2
instance (Distance p (FinLine p), Floating a, Ord a) =>
Intersect (Circle p a) (FinLine p a) where
intersect (Circle m r) l =
distance m l <= r
instance (Distance p (FinLine p), Floating a, Ord a) =>
Intersect (FinLine p a) (Circle p a) where
intersect = flip intersect
instance (Arbitrary a, Arbitrary (p a), Ord a, Num a) =>
Arbitrary (Circle p a) where
arbitrary = Circle <$> arbitrary <*>
(arbitrary `suchThat`(>0))
instance (Rotation p, Point p) => Rotation (Circle p) where
angle (Circle m _) = angle m
rotate ang (Circle m r) = Circle (rotate ang m) r
instance Translate p => Translate (Circle p) where
translate v (Circle m r) = Circle (translate v m) r
mkCircleInt :: (Num a) => p a -> a -> Circle p a
mkCircleInt m r' = Circle m (abs r')
radius :: Circle p a -> a
radius (Circle _ r) = r
center :: Circle p a -> p a
center (Circle m _) = m
data Polygon p a =
Polygon (p a) [p a]
deriving (Show,Read,Eq)
instance (Point p, Ord a, Eq (p a), Floating a) =>
Intersect (p a) (Polygon p a) where
intersect p (Polygon m vs) =
any (`pointInTriangle` p) triangles
where triangles = map (\(a,b) -> (m,a,b))
( zip verteces (tail verteces ++ [head verteces]))
verteces = map (+ m) vs
instance (Point p, Floating a, Num (p a), Eq (p a), Ord a) =>
Intersect (Polygon p a) (p a) where
intersect = flip intersect
instance ( Arbitrary (p a), Num (p a), RealFloat a, Point p, Scale p
, Eq (p a)) =>
Arbitrary (Polygon p a) where
arbitrary = do
vs' <- listOf1 (arbitrary `suchThat` (\a -> magnitude a > 0)) `suchThat`
((>= 4).length)
(return.fromJust.convexHull') vs'
instance (Eq (p a), Floating a, Num (p a), Ord a, Point p) =>
Intersect (Polygon p a) (Circle p a) where
intersect poly@(Polygon p vs') (Circle m r)
| m `intersect` poly = True
| otherwise =
any ((r >=). distance m)
verteces
where verteces = zipWith FinLine
vs
(tail vs ++ [head vs])
vs = map (p+) vs'
instance (Eq (p a), Num (p a), RealFloat a, Point p) =>
Intersect (Polygon p a) (Polygon p a) where
intersect poly1@(Polygon p1 vs1) poly2@(Polygon p2 vs2) =
let verts1 = map (p1+) vs1
verts2 = map (p2+) vs2
edges1 = zipWith FinLine verts1 (tail verts1 ++ [head verts1])
edges2 = zipWith FinLine verts2 (tail verts2 ++ [head verts2])
in any (uncurry intersect)
[ (v1,v2) | v1 <- edges1, v2 <- edges2 ] ||
any (intersect poly2) verts1 ||
any (intersect poly1) verts2
instance (Eq (p a), Floating a, Num (p a), Ord a, Point p) =>
Intersect (Circle p a) (Polygon p a) where
intersect = flip intersect
instance (RealFloat a, Eq a, Eq (p a), Point p) =>
Intersect (Polygon p a) (FinLine p a) where
intersect poly@(Polygon m vs) line@(FinLine a b) =
a `intersect` poly ||
b `intersect` poly ||
any (intersect line) edges
where edges = zipWith FinLine verts (tail verts ++ [head verts])
verts = map (+m) vs
instance (RealFloat a, Eq a, Eq (p a), Point p) =>
Intersect (FinLine p a) (Polygon p a) where
intersect = flip intersect
instance (Rotation p) => Rotation (Polygon p) where
rotate r (Polygon m vs) = Polygon (rotate r m) (map (rotate r) vs)
angle (Polygon m _) = angle m
instance Translate p => Translate (Polygon p) where
translate v (Polygon m vs) = Polygon (translate v m) vs
convexHull' :: forall p a.
(Num (p a), Fractional a, Ord a, Scale p, Point p) =>
[p a] -> Maybe (Polygon p a)
convexHull' [] = Nothing
convexHull' [_] = Nothing
convexHull' [_,_] = Nothing
convexHull' ps = Just $
Polygon middle (map (subtract middle) hull)
where middle :: p a
middle = (1 / (fromIntegral.length) hull) `scale`
sum hull
hull :: [p a]
hull = chain sortedPs
chain :: [p a] -> [p a]
chain xs = lower ++ upper
where lower = go [] xs
upper = go [] (reverse xs)
go :: [p a] -> [p a] -> [p a]
go acc@(r1:r2:rs) (x:xs)
| clockwise r2 r1 x = go (r2:rs) (x:xs)
| otherwise = go (x:acc) xs
go acc (x:xs) = go (x:acc) xs
go acc [] = reverse $ tail acc
sortedPs :: [p a]
sortedPs = sortBy
(\p q ->
case compare (x p) (x q) of
EQ -> compare (y p) (y q)
c -> c
) ps
clockwise :: p a -> p a -> p a -> Bool
clockwise o a b = (a o) `cross` (b o) <= 0
rectangleInt :: forall p a. (Point p, RealFloat a, Eq a, Translate p
, Rotation p) =>
p a
-> a
-> a
-> Maybe (Polygon p a)
rectangleInt m a b
| a == 0 || b == 0 = Nothing
| otherwise =
Just $
Polygon
m
( sortBy
(compare `on` angle)
[ fromCoords (negate a/2) (negate b/2) :: p a
, fromCoords (a/2) (negate b/2) :: p a
, fromCoords (a/2) (b/2) :: p a
, fromCoords (negate a/2) (b/2) :: p a
]
)
data Shape p a = ShapeCircle (Circle p a)
| ShapePolygon (Polygon p a)
deriving (Show,Read,Eq)
instance ( Ord a, Distance p p, Eq (p a)
, Num (p a), Point p, RealFloat a) =>
Intersect (Shape p a) (Shape p a) where
intersect (ShapeCircle c) (ShapePolygon p)
| not (spatialBox c `intersect` spatialBox p) = False
| otherwise = c `intersect` p
intersect (ShapePolygon p) (ShapeCircle c)
| not (spatialBox c `intersect` spatialBox p) = False
| otherwise = c `intersect` p
intersect (ShapeCircle a) (ShapeCircle b)
| not (spatialBox a `intersect` spatialBox b) = False
| otherwise = a `intersect` b
intersect (ShapePolygon a) (ShapePolygon b)
| not (spatialBox a `intersect` spatialBox b) = False
| otherwise = a `intersect` b
instance ( Floating a, Eq (p a), Num (p a), Ord a, Point p, Distance p p ) =>
Intersect (Shape p a) (p a) where
intersect (ShapeCircle c) p = c `intersect` p
intersect (ShapePolygon c) p = c `intersect` p
instance ( Floating a, Eq (p a), Num (p a), Ord a, Point p, Distance p p ) =>
Intersect (p a) (Shape p a) where
intersect = flip intersect
instance (Point p, RealFloat a, Ord a, Eq (p a)) =>
Intersect (Shape p a) (FinLine p a) where
intersect (ShapeCircle c) = intersect c
intersect (ShapePolygon p) = intersect p
instance (Point p, RealFloat a, Ord a, Eq (p a)) =>
Intersect (FinLine p a) (Shape p a) where
intersect = flip intersect
instance (Rotation p, Point p) => Rotation (Shape p) where
rotate a (ShapeCircle s) = ShapeCircle (rotate a s)
rotate a (ShapePolygon s) = ShapePolygon (rotate a s)
angle (ShapeCircle s) = angle s
angle (ShapePolygon s) = angle s
instance ( Eq (p a), RealFloat a, Num (p a), Point p, Arbitrary a
, Arbitrary (p a), Scale p) =>
Arbitrary (Shape p a) where
arbitrary = oneof [ ShapeCircle <$> arbitrary
, ShapePolygon <$> arbitrary
]
instance Translate p => Translate (Shape p) where
translate v (ShapeCircle c) = ShapeCircle (translate v c)
translate v (ShapePolygon c) = ShapePolygon (translate v c)
class Spatial s where
area :: (Floating a, Ord a) => s a -> a
minX :: (Floating a, Ord a) => s a -> a
maxX :: (Floating a, Ord a) => s a -> a
minY :: (Floating a, Ord a) => s a -> a
maxY :: (Floating a, Ord a) => s a -> a
instance (Point p) => Spatial (Circle p) where
area (Circle _ r) = r^(2::Int) * pi
minX (Circle m r) = x m r
maxX (Circle m r) = x m + r
minY (Circle m r) = y m r
maxY (Circle m r) = y m + r
instance (Point p) => Spatial (Polygon p) where
area (Polygon _ vs) =
(sum.map (triArea.(\(a,b) -> (a,b,fromCoords 0 0)))) edges
where edges = zip vs (tail vs ++ [head vs])
minX (Polygon m vs) = x m + (minimum.map x) vs
maxX (Polygon m vs) = x m + (maximum.map x) vs
minY (Polygon m vs) = y m + (minimum.map y) vs
maxY (Polygon m vs) = y m + (maximum.map y) vs
instance (Point p) => Spatial (Shape p) where
area (ShapeCircle c) = area c
area (ShapePolygon p) = area p
minX (ShapeCircle c) = minX c
minX (ShapePolygon p) = minX p
maxX (ShapeCircle c) = maxX c
maxX (ShapePolygon p) = maxX p
minY (ShapeCircle c) = minY c
minY (ShapePolygon p) = minY p
maxY (ShapeCircle c) = maxY c
maxY (ShapePolygon p) = maxY p
data Box a = Box (a,a) (a,a)
instance (Ord a) => Intersect (Box a) (Box a) where
intersect (Box (a1x,a1y) (a2x,a2y)) (Box (b1x,b1y) (b2x,b2y)) =
max a1x b1x <= min a2x b2x && max a1y b1y <= min a2y b2y
spatialBox :: (Floating a, Ord a, Spatial s) => s a -> Box a
spatialBox o = Box (minX o, minY o) (maxX o, maxY o)