diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,8 +1,9 @@ HGeometry ========= -[![Build Status](https://travis-ci.org/noinia/hgeometry.svg?branch=master)](https://travis-ci.org/noinia/hgeometry) -[![Hackage](https://img.shields.io/hackage/v/hgeometry.svg)](https://hackage.haskell.org/package/hgeometry) +![GitHub Workflow Status](https://img.shields.io/github/workflow/status/noinia/hgeometry/CI) +[![Hackage](https://img.shields.io/hackage/v/hgeometry.svg?color=success)](https://hackage.haskell.org/package/hgeometry) +[![API docs coverage](https://img.shields.io/endpoint?url=https%3A%2F%2Fnoinia.github.io%2Fhgeometry%2Fhaddock_badge.json)](https://noinia.github.io/hgeometry/doc/) HGeometry is a library for computing with geometric objects in Haskell. It defines basic geometric types and primitives, and it @@ -34,19 +35,23 @@ HGeometry is split into a few smaller packages. In particular: -- hgeometry-combinatorial : defines some non-geometric +- hgeometry : defines the actual geometric data types, data + structures, and algorithms, +- hgeometry-combinatorial : defines the non-geometric (i.e. combinatorial) data types, data structures, and algorithms. + - hgeometry-ipe : defines functions for working with [ipe](http://ipe.otfried.org) files. - hgeometry-svg : defines functions for working with svg files. -- hgeometry-interactive : defines functions for building an +- hgeometry-web : defines functions for building an interactive viewer using [miso](https://haskell-miso.org). -- hgeometry : defines the actual geometric data types, data - structures, and algorithms. +- hgeometry-interactive : defines functions for building an + interactive viewer using + [reflex-sdl2](https://hackage.haskell.org/package/reflex-sdl2). -In addition there is a [hgeometry-examples](hgeometry-examples) -package that defines some example applications, and a hgometry-test -package that contains all testcases. The latter is to work around a -bug in cabal. +In addition there are [hgeometry-examples](hgeometry-examples) and +[hgeometry-showcase](hgeometry-showcase) packages that define some +example applications, and a hgometry-test package that contains all +testcases. The latter is to work around a bug in cabal. Available Geometric Algorithms ------------------------------ @@ -56,25 +61,28 @@ implements some more advanced geometric algorithms. In particuar, the following algorithms are currently available: -* two \(O(n \log n)\) time algorithms for convex hull in - $\mathbb{R}^2$: the typical Graham scan, and a divide and conquer algorithm, -* an \(O(n)\) expected time algorithm for smallest enclosing disk in $\mathbb{R}^$2, +* two *O(n log n)* time algorithms for convex hull in + ℝ²: the typical Graham scan, and a divide and conquer algorithm, +* an *O(n)* expected time algorithm for smallest enclosing disk in ℝ², * the well-known Douglas Peucker polyline line simplification algorithm, -* an \(O(n \log n)\) time algorithm for computing the Delaunay triangulation -(using divide and conquer). -* an \(O(n \log n)\) time algorithm for computing the Euclidean Minimum Spanning -Tree (EMST), based on computing the Delaunay Triangulation. -* an \(O(\log^2 n)\) time algorithm to find extremal points and tangents on/to a - convex polygon. -* An optimal \(O(n+m)\) time algorithm to compute the Minkowski sum of two convex -polygons. -* An \(O(1/\varepsilon^dn\log n)\) time algorithm for constructing a Well-Separated pair - decomposition. -* The classic (optimal) \(O(n\log n)\) time divide and conquer algorithm to - compute the closest pair among a set of \(n\) points in \(\mathbb{R}^2\). -* An \(O(nm)\) time algorithm to compute the discrete Fr\'echet - distance of two sequences of points (curves) of length \(n\) and - \(m\), respectively. +* an *O(n log n)* time algorithm for computing the Delaunay triangulation +(using divide and conquer), +* an *O(n log n)* time algorithm for computing the Euclidean Minimum Spanning +Tree (EMST), based on computing the Delaunay Triangulation, +* an *O(log n)* time algorithm to find extremal points and tangents on/to a + convex polygon, +* an optimal *O(n+m)* time algorithm to compute the Minkowski sum of two convex +polygons, +* an *O(1/εᵈn log n)* time algorithm for constructing a Well-Separated pair + decomposition, +* the classic (optimal) *O(n log n)* time divide and conquer algorithm to + compute the closest pair among a set of *n* points in ℝ², +* an *O(nm)* time algorithm to compute the discrete Fréchet + distance of two sequences of points (curves) of length *n* and + *m*, respectively. +* an *O(n)* time single-source shortest path algorithm on triangulated polygons. +* an *O(n log n)* time algorithm for generating random convex polygons. +* an *O(n)* time algorithm for finding the convex hull of a simple polygon. Available Geometric Data Structures ----------------------------------- @@ -85,11 +93,13 @@ * A one dimensional Segment Tree. The base tree is static. * A one dimensional Interval Tree. The base tree is static. * A KD-Tree. The base tree is static. +* An *O(n log n)* size planar point location data structure supporting + *O(log n)* queries. There is also support for working with planar subdivisions. As a result, [hgeometry-combinatorial] also includes a data structure for working with planar graphs. In particular, it has an `EdgeOracle` data -structure, that can be built in \(O(n)\) time that can test if the +structure, that can be built in *O(n)* time that can test if the planar graph contains an edge in constant time. @@ -101,8 +111,8 @@ i.e. because of floating point errors one may get completely wrong results. Hence, I *strongly* advise against using `Double` or `Float` for these types. In several algorithms it is sufficient if the type `r` is -`Fractional`. Hence, you can use an exact number type such as `Rational`. - +`Fractional`. Hence, you can use an exact number type such as +`Data.RealNumber.Rational` or `Data.Ratio.Rational`. Working with additional data ---------------------------- @@ -119,14 +129,11 @@ To still allow for some extensibility our types will use the Ext (:+) type, as defined in the hgeometry-combinatorial package. For example, -our `Polygon` data type, has an extra type parameter `p` that allows -the vertices of the polygon to cary some extra information of type `p` -(for example a color, a size, or whatever). +our `LineSegment` data type, has an extra type parameter `p` that +allows the vertices of the line segment to carry some extra +information of type `p` (for example a color, a size, or +whatever). Polylines, Polylygons, Boxes, etc have similar such +parameters. -```haskell -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 -``` In all places this extra data is accessable by the (:+) type in Data.Ext, which is essentially just a pair. diff --git a/benchmark/Algorithms/Geometry/ClosestPair/Bench.hs b/benchmark/Algorithms/Geometry/ClosestPair/Bench.hs new file mode 100644 --- /dev/null +++ b/benchmark/Algorithms/Geometry/ClosestPair/Bench.hs @@ -0,0 +1,36 @@ +module Algorithms.Geometry.ClosestPair.Bench where + +import qualified Algorithms.Geometry.ClosestPair.DivideAndConquer as DivideAndConquer +import qualified Algorithms.Geometry.ClosestPair.Naive as Naive + +import Control.Monad.Random +import Data.Ext +import Data.Geometry.Point +import Data.Hashable +import Data.LSeq (LSeq) +import qualified Data.LSeq as LSeq +import Test.Tasty.Bench + +-------------------------------------------------------------------------------- + +genPts :: (Ord r, Random r, RandomGen g) + => Int -> Rand g (LSeq 2 (Point 2 r :+ ())) +genPts n | n >= 2 = LSeq.promise . LSeq.fromList <$> replicateM n (fmap ext getRandom) + | otherwise = error "genPts: Need at least 2 points" + +gen :: StdGen +gen = mkStdGen (hash "closest pair") + +-- | Benchmark computing the closest pair +benchmark :: Benchmark +benchmark = bgroup "ClosestPair" + [ bgroup (show n) (build $ evalRand (genPts @Int n) gen) + | n <- sizes' + ] + where + sizes' = [500] + + build pts = [ bench "sort" $ nf LSeq.unstableSort pts + , bench "Div&Conq" $ nf DivideAndConquer.closestPair pts + , bench "Naive" $ nf Naive.closestPair pts + ] diff --git a/benchmark/Algorithms/Geometry/ConvexHull/Bench.hs b/benchmark/Algorithms/Geometry/ConvexHull/Bench.hs new file mode 100644 --- /dev/null +++ b/benchmark/Algorithms/Geometry/ConvexHull/Bench.hs @@ -0,0 +1,65 @@ +module Algorithms.Geometry.ConvexHull.Bench (benchmark) where + +import qualified Algorithms.Geometry.ConvexHull.DivideAndConquer as DivideAndConquer +import qualified Algorithms.Geometry.ConvexHull.GrahamScan as GrahamScan +import qualified Algorithms.Geometry.ConvexHull.JarvisMarch as JarvisMarch +import qualified Algorithms.Geometry.ConvexHull.QuickHull as QuickHull + +import Control.Monad.Random +import Data.Double.Approximate +import Data.Ext +import Data.Geometry.Point +import Data.Hashable +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NonEmpty +import Data.RealNumber.Rational +import Test.Tasty.Bench + +type R = RealNumber 5 + +-------------------------------------------------------------------------------- + +genPts :: (Ord r, Random r, RandomGen g) + => Int -> Rand g (NonEmpty (Point 2 r :+ ())) +genPts n = NonEmpty.fromList <$> replicateM n (fmap ext getRandom) + +-- genPts' :: (Ord r, Random r, RandomGen g) => Int +-- -> Rand g ( NonEmpty (Point 2 r :+ ()) +-- , NonEmpty (Point 2 r Multi.:+ '[]) +-- ) +-- genPts' n = (\pts -> (pts, fmap (\ ~(c :+ _) -> Multi.ext c) pts) +-- ) <$> genPts n + +gen :: StdGen +gen = mkStdGen (hash "convex hull") + +-- | Benchmark building the convexHull +benchmark :: Benchmark +benchmark = bgroup "ConvexHull" $ + [ bgroup ("1e"++show i ++ "/RealNumber") (convexHullFractional $ evalRand (genPts @R n) gen) + | i <- [3, 4::Int] + , let n = 10^i + ] ++ + [ bgroup ("1e"++show i ++ "/Int") (convexHullNum $ evalRand (genPts @Int n) gen) + | i <- [4, 5::Int] + , let n = 10^i + ] ++ + [ bgroup ("1e"++show i ++ "/SafeDouble") (convexHullFractional $ evalRand (genPts @SafeDouble n) gen) + | i <- [4, 5::Int] + , let n = 10^i + ] ++ + [ bgroup ("1e"++show i ++ "/Double") (convexHullFractional $ evalRand (genPts @Double n) gen) + | i <- [4, 5::Int] + , let n = 10^i ] + where + convexHullFractional pts = + [ bench "GrahamScan" $ nf GrahamScan.convexHull pts + , bench "DivideAndConquer" $ nf DivideAndConquer.convexHull pts + , bench "QuickHull" $ nf QuickHull.convexHull pts + , bench "JarvisMarch" $ nf JarvisMarch.convexHull pts + ] + convexHullNum pts = + [ bench "GrahamScan" $ nf GrahamScan.convexHull pts + , bench "DivideAndConquer" $ nf DivideAndConquer.convexHull pts + , bench "JarvisMarch" $ nf JarvisMarch.convexHull pts + ] diff --git a/benchmark/Algorithms/Geometry/ConvexHull/GrahamFam.hs b/benchmark/Algorithms/Geometry/ConvexHull/GrahamFam.hs new file mode 100644 --- /dev/null +++ b/benchmark/Algorithms/Geometry/ConvexHull/GrahamFam.hs @@ -0,0 +1,103 @@ +{-# LANGUAGE UndecidableInstances #-} +module Algorithms.Geometry.ConvexHull.GrahamFam( convexHull + , upperHull + , lowerHull, fromP + ) where + +import Control.DeepSeq +import Control.Lens ((^.)) +import Data.Ext +import Data.Geometry.Point +import qualified Data.Geometry.Vector.VectorFamily as VF +import Data.List.NonEmpty (NonEmpty(..)) +import qualified Data.List.NonEmpty as NonEmpty +import Data.Monoid +import GHC.TypeLits + + +newtype MyPoint d r = MyPoint (VF.Vector d r) + +deriving instance (VF.Arity d, Eq r) => Eq (MyPoint d r) +deriving instance (VF.Arity d, Ord r) => Ord (MyPoint d r) +deriving instance (VF.Arity d, Show r) => Show (MyPoint d r) +deriving instance (NFData (VF.Vector d r)) => NFData (MyPoint d r) + +pattern MyPoint2 x y = MyPoint (VF.Vector2 x y) + + +-- instance (NFData r, Arity d) => NFData (MyPoint d r) where +-- rnf (MyPoint x y) = rnf (x,y) +-- rnf (MyP p) = rnf p + +toP :: MyPoint 2 r :+ e -> Point 2 r :+ e +toP (MyPoint2 x y :+ e) = Point2 x y :+ e + +fromP :: Point 2 r :+ e -> MyPoint 2 r :+ e +fromP (Point2 x y :+ e) = MyPoint2 x y :+ e + + +subt :: Num r => MyPoint 2 r -> MyPoint 2 r -> MyPoint 2 r +(MyPoint2 x y) `subt` (MyPoint2 a b) = MyPoint2 (x-a) (y-b) + +newtype ConvexPolygon p r = ConvexPolygon [Point 2 r :+ p] deriving (Show,Eq,NFData) + +-- | \(O(n \log n)\) time ConvexHull using Graham-Scan. The resulting polygon is +-- given in clockwise order. +convexHull :: (Ord r, Num r) + => NonEmpty (MyPoint 2 r :+ p) -> ConvexPolygon p r +convexHull (p :| []) = ConvexPolygon $ [toP p] +convexHull ps = let ps' = NonEmpty.toList . NonEmpty.sortBy incXdecY $ ps + uh = NonEmpty.tail . hull' $ ps' + lh = NonEmpty.tail . hull' $ reverse ps' + in ConvexPolygon . map toP . reverse $ lh ++ uh + +upperHull :: (Ord r, Num r) => NonEmpty (MyPoint 2 r :+ p) -> NonEmpty (MyPoint 2 r :+ p) +upperHull = hull id + + +lowerHull :: (Ord r, Num r) => NonEmpty (MyPoint 2 r :+ p) -> NonEmpty (MyPoint 2 r :+ p) +lowerHull = hull reverse + + +-- | Helper function so that that can compute both the upper or the lower hull, depending +-- on the function f +hull :: (Ord r, Num r) + => ([MyPoint 2 r :+ p] -> [MyPoint 2 r :+ p]) + -> NonEmpty (MyPoint 2 r :+ p) -> NonEmpty (MyPoint 2 r :+ p) +hull _ h@(_ :| []) = h +hull f pts = hull' . f + . NonEmpty.toList . NonEmpty.sortBy incXdecY $ pts + +incXdecY :: Ord r => (MyPoint 2 r) :+ p -> (MyPoint 2 r) :+ q -> Ordering +incXdecY (MyPoint2 px py :+ _) (MyPoint2 qx qy :+ _) = + compare px qx <> compare qy py + + +-- | Precondition: The list of input points is sorted +hull' :: (Ord r, Num r) => [MyPoint 2 r :+ p] -> NonEmpty (MyPoint 2 r :+ p) +hull' (a:b:ps) = NonEmpty.fromList $ hull'' [b,a] ps + where + hull'' h [] = h + hull'' h (p:ps') = hull'' (cleanMiddle (p:h)) ps' + + cleanMiddle h@[_,_] = h + cleanMiddle h@(z:y:x:rest) + | rightTurn (x^.core) (y^.core) (z^.core) = h + | otherwise = cleanMiddle (z:x:rest) + cleanMiddle _ = error "cleanMiddle: too few points" + +rightTurn :: (Ord r, Num r) => MyPoint 2 r -> MyPoint 2 r -> MyPoint 2 r -> Bool +rightTurn a b c = ccwP a b c == CW + + + +ccwP :: (Ord r, Num r) => MyPoint 2 r -> MyPoint 2 r -> MyPoint 2 r -> CCW +ccwP p q r = case z `compare` 0 of + LT -> CW + GT -> CCW + EQ -> CoLinear + where + + MyPoint2 ux uy = q `subt` p + MyPoint2 vx vy = r `subt` p + z = ux * vy - uy * vx diff --git a/benchmark/Algorithms/Geometry/ConvexHull/GrahamFam6.hs b/benchmark/Algorithms/Geometry/ConvexHull/GrahamFam6.hs new file mode 100644 --- /dev/null +++ b/benchmark/Algorithms/Geometry/ConvexHull/GrahamFam6.hs @@ -0,0 +1,103 @@ +{-# LANGUAGE UndecidableInstances #-} +module Algorithms.Geometry.ConvexHull.GrahamFam6( convexHull + , upperHull + , lowerHull, fromP + ) where + +import Control.DeepSeq +import Control.Lens ((^.)) +import Data.Ext +import Data.Geometry.Point +import qualified Data.Geometry.Vector.VectorFamily6 as VF +import Data.List.NonEmpty (NonEmpty(..)) +import qualified Data.List.NonEmpty as NonEmpty +import Data.Monoid +import GHC.TypeLits + + +newtype MyPoint d r = MyPoint (VF.Vector d r) + +deriving instance (VF.Arity d, Eq r) => Eq (MyPoint d r) +deriving instance (VF.Arity d, Ord r) => Ord (MyPoint d r) +deriving instance (VF.Arity d, Show r) => Show (MyPoint d r) +deriving instance (NFData (VF.Vector d r)) => NFData (MyPoint d r) + +pattern MyPoint2 x y = MyPoint (VF.Vector2 x y) + + +-- instance (NFData r, Arity d) => NFData (MyPoint d r) where +-- rnf (MyPoint x y) = rnf (x,y) +-- rnf (MyP p) = rnf p + +toP :: MyPoint 2 r :+ e -> Point 2 r :+ e +toP (MyPoint2 x y :+ e) = Point2 x y :+ e + +fromP :: Point 2 r :+ e -> MyPoint 2 r :+ e +fromP (Point2 x y :+ e) = MyPoint2 x y :+ e + + +subt :: Num r => MyPoint 2 r -> MyPoint 2 r -> MyPoint 2 r +(MyPoint2 x y) `subt` (MyPoint2 a b) = MyPoint2 (x-a) (y-b) + +newtype ConvexPolygon p r = ConvexPolygon [Point 2 r :+ p] deriving (Show,Eq,NFData) + +-- | \(O(n \log n)\) time ConvexHull using Graham-Scan. The resulting polygon is +-- given in clockwise order. +convexHull :: (Ord r, Num r) + => NonEmpty (MyPoint 2 r :+ p) -> ConvexPolygon p r +convexHull (p :| []) = ConvexPolygon $ [toP p] +convexHull ps = let ps' = NonEmpty.toList . NonEmpty.sortBy incXdecY $ ps + uh = NonEmpty.tail . hull' $ ps' + lh = NonEmpty.tail . hull' $ reverse ps' + in ConvexPolygon . map toP . reverse $ lh ++ uh + +upperHull :: (Ord r, Num r) => NonEmpty (MyPoint 2 r :+ p) -> NonEmpty (MyPoint 2 r :+ p) +upperHull = hull id + + +lowerHull :: (Ord r, Num r) => NonEmpty (MyPoint 2 r :+ p) -> NonEmpty (MyPoint 2 r :+ p) +lowerHull = hull reverse + + +-- | Helper function so that that can compute both the upper or the lower hull, depending +-- on the function f +hull :: (Ord r, Num r) + => ([MyPoint 2 r :+ p] -> [MyPoint 2 r :+ p]) + -> NonEmpty (MyPoint 2 r :+ p) -> NonEmpty (MyPoint 2 r :+ p) +hull _ h@(_ :| []) = h +hull f pts = hull' . f + . NonEmpty.toList . NonEmpty.sortBy incXdecY $ pts + +incXdecY :: Ord r => (MyPoint 2 r) :+ p -> (MyPoint 2 r) :+ q -> Ordering +incXdecY (MyPoint2 px py :+ _) (MyPoint2 qx qy :+ _) = + compare px qx <> compare qy py + + +-- | Precondition: The list of input points is sorted +hull' :: (Ord r, Num r) => [MyPoint 2 r :+ p] -> NonEmpty (MyPoint 2 r :+ p) +hull' (a:b:ps) = NonEmpty.fromList $ hull'' [b,a] ps + where + hull'' h [] = h + hull'' h (p:ps') = hull'' (cleanMiddle (p:h)) ps' + + cleanMiddle h@[_,_] = h + cleanMiddle h@(z:y:x:rest) + | rightTurn (x^.core) (y^.core) (z^.core) = h + | otherwise = cleanMiddle (z:x:rest) + cleanMiddle _ = error "cleanMiddle: too few points" + +rightTurn :: (Ord r, Num r) => MyPoint 2 r -> MyPoint 2 r -> MyPoint 2 r -> Bool +rightTurn a b c = ccwP a b c == CW + + + +ccwP :: (Ord r, Num r) => MyPoint 2 r -> MyPoint 2 r -> MyPoint 2 r -> CCW +ccwP p q r = case z `compare` 0 of + LT -> CW + GT -> CCW + EQ -> CoLinear + where + + MyPoint2 ux uy = q `subt` p + MyPoint2 vx vy = r `subt` p + z = ux * vy - uy * vx diff --git a/benchmark/Algorithms/Geometry/ConvexHull/GrahamFamPeano.hs b/benchmark/Algorithms/Geometry/ConvexHull/GrahamFamPeano.hs new file mode 100644 --- /dev/null +++ b/benchmark/Algorithms/Geometry/ConvexHull/GrahamFamPeano.hs @@ -0,0 +1,107 @@ +{-# LANGUAGE UndecidableInstances #-} +module Algorithms.Geometry.ConvexHull.GrahamFamPeano( convexHull + , upperHull + , lowerHull, fromP + ) where + +import Control.DeepSeq +import Control.Lens ((^.)) +import Data.Ext +import Data.Geometry.Point +import qualified Data.Vector.Fixed.Cont as V +import qualified Data.Geometry.Vector.VectorFamilyPeano as VF +import Data.List.NonEmpty (NonEmpty(..)) +import qualified Data.List.NonEmpty as NonEmpty +import Data.Monoid +import GHC.TypeLits +import qualified Linear.V2 as V2 + + +newtype MyPoint d r = MyPoint (VF.VectorFamily d r) + +deriving instance (VF.ImplicitArity d, Eq r) => Eq (MyPoint d r) +deriving instance (VF.ImplicitArity d, Ord r) => Ord (MyPoint d r) +deriving instance (VF.ImplicitArity d, Show r) => Show (MyPoint d r) +deriving instance (NFData (VF.VectorFamily d r)) => NFData (MyPoint d r) + +pattern Vector2 x y = VF.VectorFamily (V2.V2 x y) + +pattern MyPoint2 x y = MyPoint (Vector2 x y) + + +-- instance (NFData r, Arity d) => NFData (MyPoint d r) where +-- rnf (MyPoint x y) = rnf (x,y) +-- rnf (MyP p) = rnf p + +toP :: MyPoint VF.Two r :+ e -> Point 2 r :+ e +toP (MyPoint2 x y :+ e) = Point2 x y :+ e + +fromP :: Point 2 r :+ e -> MyPoint VF.Two r :+ e +fromP (Point2 x y :+ e) = MyPoint2 x y :+ e + + +subt :: Num r => MyPoint VF.Two r -> MyPoint VF.Two r -> MyPoint VF.Two r +(MyPoint2 x y) `subt` (MyPoint2 a b) = MyPoint2 (x-a) (y-b) + +newtype ConvexPolygon p r = ConvexPolygon [Point 2 r :+ p] deriving (Show,Eq,NFData) + +-- | \(O(n \log n)\) time ConvexHull using Graham-Scan. The resulting polygon is +-- given in clockwise order. +convexHull :: (Ord r, Num r) + => NonEmpty (MyPoint VF.Two r :+ p) -> ConvexPolygon p r +convexHull (p :| []) = ConvexPolygon $ [toP p] +convexHull ps = let ps' = NonEmpty.toList . NonEmpty.sortBy incXdecY $ ps + uh = NonEmpty.tail . hull' $ ps' + lh = NonEmpty.tail . hull' $ reverse ps' + in ConvexPolygon . map toP . reverse $ lh ++ uh + +upperHull :: (Ord r, Num r) => NonEmpty (MyPoint VF.Two r :+ p) -> NonEmpty (MyPoint VF.Two r :+ p) +upperHull = hull id + + +lowerHull :: (Ord r, Num r) => NonEmpty (MyPoint VF.Two r :+ p) -> NonEmpty (MyPoint VF.Two r :+ p) +lowerHull = hull reverse + + +-- | Helper function so that that can compute both the upper or the lower hull, depending +-- on the function f +hull :: (Ord r, Num r) + => ([MyPoint VF.Two r :+ p] -> [MyPoint VF.Two r :+ p]) + -> NonEmpty (MyPoint VF.Two r :+ p) -> NonEmpty (MyPoint VF.Two r :+ p) +hull _ h@(_ :| []) = h +hull f pts = hull' . f + . NonEmpty.toList . NonEmpty.sortBy incXdecY $ pts + +incXdecY :: Ord r => (MyPoint VF.Two r) :+ p -> (MyPoint VF.Two r) :+ q -> Ordering +incXdecY (MyPoint2 px py :+ _) (MyPoint2 qx qy :+ _) = + compare px qx <> compare qy py + + +-- | Precondition: The list of input points is sorted +hull' :: (Ord r, Num r) => [MyPoint VF.Two r :+ p] -> NonEmpty (MyPoint VF.Two r :+ p) +hull' (a:b:ps) = NonEmpty.fromList $ hull'' [b,a] ps + where + hull'' h [] = h + hull'' h (p:ps') = hull'' (cleanMiddle (p:h)) ps' + + cleanMiddle h@[_,_] = h + cleanMiddle h@(z:y:x:rest) + | rightTurn (x^.core) (y^.core) (z^.core) = h + | otherwise = cleanMiddle (z:x:rest) + cleanMiddle _ = error "cleanMiddle: too few points" + +rightTurn :: (Ord r, Num r) => MyPoint VF.Two r -> MyPoint VF.Two r -> MyPoint VF.Two r -> Bool +rightTurn a b c = ccwP a b c == CW + + + +ccwP :: (Ord r, Num r) => MyPoint VF.Two r -> MyPoint VF.Two r -> MyPoint VF.Two r -> CCW +ccwP p q r = case z `compare` 0 of + LT -> CW + GT -> CCW + EQ -> CoLinear + where + + MyPoint2 ux uy = q `subt` p + MyPoint2 vx vy = r `subt` p + z = ux * vy - uy * vx diff --git a/benchmark/Algorithms/Geometry/ConvexHull/GrahamFixed.hs b/benchmark/Algorithms/Geometry/ConvexHull/GrahamFixed.hs new file mode 100644 --- /dev/null +++ b/benchmark/Algorithms/Geometry/ConvexHull/GrahamFixed.hs @@ -0,0 +1,104 @@ +{-# LANGUAGE UndecidableInstances #-} +module Algorithms.Geometry.ConvexHull.GrahamFixed( convexHull + , upperHull + , lowerHull, fromP + ) where + +import Control.DeepSeq +import Control.Lens ((^.)) +import Data.Ext +import Data.Geometry.Point +import Data.Vector.Fixed (Arity) +import qualified Data.Geometry.Vector.VectorFixed as VF +import Data.List.NonEmpty (NonEmpty(..)) +import qualified Data.List.NonEmpty as NonEmpty +import Data.Monoid +import GHC.TypeLits + + +newtype MyPoint d r = MyPoint (VF.Vector d r) + +deriving instance (Arity d, Eq r) => Eq (MyPoint d r) +deriving instance (Arity d, Ord r) => Ord (MyPoint d r) +deriving instance (Arity d, Show r) => Show (MyPoint d r) +deriving instance (NFData (VF.Vector d r)) => NFData (MyPoint d r) + +pattern MyPoint2 x y = MyPoint (VF.Vector2 x y) + + +-- instance (NFData r, Arity d) => NFData (MyPoint d r) where +-- rnf (MyPoint x y) = rnf (x,y) +-- rnf (MyP p) = rnf p + +toP :: MyPoint 2 r :+ e -> Point 2 r :+ e +toP (MyPoint2 x y :+ e) = Point2 x y :+ e + +fromP :: Point 2 r :+ e -> MyPoint 2 r :+ e +fromP (Point2 x y :+ e) = MyPoint2 x y :+ e + + +subt :: Num r => MyPoint 2 r -> MyPoint 2 r -> MyPoint 2 r +(MyPoint2 x y) `subt` (MyPoint2 a b) = MyPoint2 (x-a) (y-b) + +newtype ConvexPolygon p r = ConvexPolygon [Point 2 r :+ p] deriving (Show,Eq,NFData) + +-- | \(O(n \log n)\) time ConvexHull using Graham-Scan. The resulting polygon is +-- given in clockwise order. +convexHull :: (Ord r, Num r) + => NonEmpty (MyPoint 2 r :+ p) -> ConvexPolygon p r +convexHull (p :| []) = ConvexPolygon $ [toP p] +convexHull ps = let ps' = NonEmpty.toList . NonEmpty.sortBy incXdecY $ ps + uh = NonEmpty.tail . hull' $ ps' + lh = NonEmpty.tail . hull' $ reverse ps' + in ConvexPolygon . map toP . reverse $ lh ++ uh + +upperHull :: (Ord r, Num r) => NonEmpty (MyPoint 2 r :+ p) -> NonEmpty (MyPoint 2 r :+ p) +upperHull = hull id + + +lowerHull :: (Ord r, Num r) => NonEmpty (MyPoint 2 r :+ p) -> NonEmpty (MyPoint 2 r :+ p) +lowerHull = hull reverse + + +-- | Helper function so that that can compute both the upper or the lower hull, depending +-- on the function f +hull :: (Ord r, Num r) + => ([MyPoint 2 r :+ p] -> [MyPoint 2 r :+ p]) + -> NonEmpty (MyPoint 2 r :+ p) -> NonEmpty (MyPoint 2 r :+ p) +hull _ h@(_ :| []) = h +hull f pts = hull' . f + . NonEmpty.toList . NonEmpty.sortBy incXdecY $ pts + +incXdecY :: Ord r => (MyPoint 2 r) :+ p -> (MyPoint 2 r) :+ q -> Ordering +incXdecY (MyPoint2 px py :+ _) (MyPoint2 qx qy :+ _) = + compare px qx <> compare qy py + + +-- | Precondition: The list of input points is sorted +hull' :: (Ord r, Num r) => [MyPoint 2 r :+ p] -> NonEmpty (MyPoint 2 r :+ p) +hull' (a:b:ps) = NonEmpty.fromList $ hull'' [b,a] ps + where + hull'' h [] = h + hull'' h (p:ps') = hull'' (cleanMiddle (p:h)) ps' + + cleanMiddle h@[_,_] = h + cleanMiddle h@(z:y:x:rest) + | rightTurn (x^.core) (y^.core) (z^.core) = h + | otherwise = cleanMiddle (z:x:rest) + cleanMiddle _ = error "cleanMiddle: too few points" + +rightTurn :: (Ord r, Num r) => MyPoint 2 r -> MyPoint 2 r -> MyPoint 2 r -> Bool +rightTurn a b c = ccwP a b c == CW + + + +ccwP :: (Ord r, Num r) => MyPoint 2 r -> MyPoint 2 r -> MyPoint 2 r -> CCW +ccwP p q r = case z `compare` 0 of + LT -> CW + GT -> CCW + EQ -> CoLinear + where + + MyPoint2 ux uy = q `subt` p + MyPoint2 vx vy = r `subt` p + z = ux * vy - uy * vx diff --git a/benchmark/Algorithms/Geometry/ConvexHull/GrahamV2.hs b/benchmark/Algorithms/Geometry/ConvexHull/GrahamV2.hs new file mode 100644 --- /dev/null +++ b/benchmark/Algorithms/Geometry/ConvexHull/GrahamV2.hs @@ -0,0 +1,95 @@ +{-# Language DeriveGeneric #-} +module Algorithms.Geometry.ConvexHull.GrahamV2( convexHull + , upperHull + , lowerHull, fromP + ) where + + +import Control.DeepSeq +import Control.Lens ((^.)) +import Data.Ext +import Data.Geometry.Point +import Data.List.NonEmpty (NonEmpty(..)) +import qualified Data.List.NonEmpty as NonEmpty +import Data.Monoid +import GHC.Generics +import qualified Linear.V2 as V2 + + + +newtype MyPoint r = MKPoint (V2.V2 r) deriving (Show,Eq,Ord,Generic) +-- data MyPoint r = MyPoint !r !r deriving (Show,Eq,Ord,Generic) + +pattern MyPoint x y = MKPoint (V2.V2 x y) + +instance NFData r => NFData (MyPoint r) + + +toP (MyPoint x y :+ e) = Point2 x y :+ e +fromP (Point2 x y :+ e) = MyPoint x y :+ e + +(MyPoint x y) `subt` (MyPoint a b) = MyPoint (x-a) (y-b) + + +newtype ConvexPolygon p r = ConvexPolygon [Point 2 r :+ p] deriving (Show,Eq,NFData) + +-- | \(O(n \log n)\) time ConvexHull using Graham-Scan. The resulting polygon is +-- given in clockwise order. +convexHull :: (Ord r, Num r) + => NonEmpty (MyPoint r :+ p) -> ConvexPolygon p r +convexHull (p :| []) = ConvexPolygon $ [toP p] +convexHull ps = let ps' = NonEmpty.toList . NonEmpty.sortBy incXdecY $ ps + uh = NonEmpty.tail . hull' $ ps' + lh = NonEmpty.tail . hull' $ reverse ps' + in ConvexPolygon . map toP . reverse $ lh ++ uh + +upperHull :: (Ord r, Num r) => NonEmpty (MyPoint r :+ p) -> NonEmpty (MyPoint r :+ p) +upperHull = hull id + + +lowerHull :: (Ord r, Num r) => NonEmpty (MyPoint r :+ p) -> NonEmpty (MyPoint r :+ p) +lowerHull = hull reverse + + +-- | Helper function so that that can compute both the upper or the lower hull, depending +-- on the function f +hull :: (Ord r, Num r) + => ([MyPoint r :+ p] -> [MyPoint r :+ p]) + -> NonEmpty (MyPoint r :+ p) -> NonEmpty (MyPoint r :+ p) +hull _ h@(_ :| []) = h +hull f pts = hull' . f + . NonEmpty.toList . NonEmpty.sortBy incXdecY $ pts + +incXdecY :: Ord r => (MyPoint r) :+ p -> (MyPoint r) :+ q -> Ordering +incXdecY (MyPoint px py :+ _) (MyPoint qx qy :+ _) = + compare px qx <> compare qy py + + +-- | Precondition: The list of input points is sorted +hull' :: (Ord r, Num r) => [MyPoint r :+ p] -> NonEmpty (MyPoint r :+ p) +hull' (a:b:ps) = NonEmpty.fromList $ hull'' [b,a] ps + where + hull'' h [] = h + hull'' h (p:ps') = hull'' (cleanMiddle (p:h)) ps' + + cleanMiddle h@[_,_] = h + cleanMiddle h@(z:y:x:rest) + | rightTurn (x^.core) (y^.core) (z^.core) = h + | otherwise = cleanMiddle (z:x:rest) + cleanMiddle _ = error "cleanMiddle: too few points" + +rightTurn :: (Ord r, Num r) => MyPoint r -> MyPoint r -> MyPoint r -> Bool +rightTurn a b c = ccwP a b c == CW + + + +ccwP :: (Ord r, Num r) => MyPoint r -> MyPoint r -> MyPoint r -> CCW +ccwP p q r = case z `compare` 0 of + LT -> CW + GT -> CCW + EQ -> CoLinear + where + + MyPoint ux uy = q `subt` p + MyPoint vx vy = r `subt` p + z = ux * vy - uy * vx diff --git a/benchmark/Algorithms/Geometry/LineSegmentIntersection/Bench.hs b/benchmark/Algorithms/Geometry/LineSegmentIntersection/Bench.hs new file mode 100644 --- /dev/null +++ b/benchmark/Algorithms/Geometry/LineSegmentIntersection/Bench.hs @@ -0,0 +1,50 @@ +module Algorithms.Geometry.LineSegmentIntersection.Bench (benchmark) where + +import qualified Algorithms.Geometry.LineSegmentIntersection.BentleyOttmann as BONew +import qualified Algorithms.Geometry.LineSegmentIntersection.BentleyOttmannOld as BOOld + +import Control.DeepSeq +import Control.Lens +import Control.Monad.Random +import Data.Ext +import Data.Geometry.LineSegment +import Data.Geometry.Point +import Data.Hashable +import qualified Data.List as List +import Data.RealNumber.Rational +import Test.Tasty.Bench + +-------------------------------------------------------------------------------- + +type R = RealNumber 5 + +benchmark :: Benchmark +benchmark = bgroup "LineSegmentIntersection" + [ benchBuild (evalRand (genPts @R 100) gen) + ] + +gen :: StdGen +gen = mkStdGen (hash "line segment intersection") + +-------------------------------------------------------------------------------- + +genPts :: (Ord r, Random r, RandomGen g) + => Int -> Rand g [LineSegment 2 () r] +genPts n = replicateM n sampleLineSegment + +-- | Benchmark computing the closest pair +benchBuild :: (Ord r, Fractional r, NFData r) => [LineSegment 2 () r] -> Benchmark +benchBuild ss = bgroup "LineSegs" [ bgroup (show n) (build $ take n ss) + | n <- sizes' ss + ] + where + sizes' xs = [length xs] + -- let n = length pts in [ n*i `div` 100 | i <- [10,20,25,50,75,100]] + + build segs = [ bench "sort" $ nf sort' segs + , bench "Old" $ nf BOOld.intersections segs + , bench "New" $ nf BONew.intersections segs + ] + +sort' :: Ord r => [LineSegment 2 () r] -> [Point 2 r] +sort' = List.sort . concatMap (\s -> s^..endPoints.core) diff --git a/benchmark/Algorithms/Geometry/LineSegmentIntersection/BentleyOttmannOld.hs b/benchmark/Algorithms/Geometry/LineSegmentIntersection/BentleyOttmannOld.hs new file mode 100644 --- /dev/null +++ b/benchmark/Algorithms/Geometry/LineSegmentIntersection/BentleyOttmannOld.hs @@ -0,0 +1,236 @@ +{-# LANGUAGE ScopedTypeVariables #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Algorithms.Geometry.LineSegmentIntersection.BentleyOttmann +-- Copyright : (C) Frank Staals +-- License : see the LICENSE file +-- Maintainer : Frank Staals +-- +-- The \(O((n+k)\log n)\) time line segment intersection algorithm by Bentley +-- and Ottmann. +-- +-------------------------------------------------------------------------------- +module Algorithms.Geometry.LineSegmentIntersection.BentleyOttmannOld where + +import Algorithms.Geometry.LineSegmentIntersection +import Control.Lens hiding (contains) +import Data.Ext +import qualified Data.Foldable as F +import Data.Geometry.Interval +import Data.Geometry.LineSegment +import Data.Geometry.Point +import Data.Geometry.Properties +import qualified Data.List as L +import Data.List.NonEmpty (NonEmpty(..)) +import qualified Data.List.NonEmpty as NonEmpty +import qualified Data.Map as M +import Data.Maybe +import Data.Ord (Down(..), comparing) +import qualified Data.OrdSeq as SS -- status struct +import qualified Data.Set as EQ -- event queue +import Data.Vinyl +import Data.Vinyl.CoRec + +-------------------------------------------------------------------------------- + +-- | Compute all intersections +-- +-- \(O((n+k)\log n)\), where \(k\) is the number of intersections. +intersections :: (Ord r, Fractional r) + => [LineSegment 2 p r] -> Intersections p r +intersections ss = merge $ sweep pts mempty + where + pts = EQ.fromAscList . groupStarts . L.sort . concatMap asEventPts $ ss + +-- | Computes all intersection points p s.t. p lies in the interior of at least +-- one of the segments. +-- +-- \(O((n+k)\log n)\), where \(k\) is the number of intersections. +interiorIntersections :: (Ord r, Fractional r) + => [LineSegment 2 p r] -> Intersections p r +interiorIntersections = M.filter (not . isEndPointIntersection) . intersections + +-- | Computes the event points for a given line segment +asEventPts :: Ord r => LineSegment 2 p r -> [Event p r] +asEventPts s = let [p,q] = L.sortBy ordPoints [s^.start.core,s^.end.core] + in [Event p (Start $ s :| []), Event q (End s)] + +-- | Group the segments with the intersection points +merge :: Ord r => [IntersectionPoint p r] -> Intersections p r +merge = foldr (\(IntersectionPoint p a) -> M.insertWith (<>) p a) M.empty + +-- | Group the startpoints such that segments with the same start point +-- correspond to one event. +groupStarts :: Eq r => [Event p r] -> [Event p r] +groupStarts [] = [] +groupStarts (Event p (Start s) : es) = Event p (Start ss) : groupStarts rest + where + (ss',rest) = L.span sameStart es + -- sort the segs on lower endpoint + ss = let (x:|xs) = s in x :| (xs ++ concatMap startSegs ss') + + sameStart (Event q (Start _)) = p == q + sameStart _ = False +groupStarts (e : es) = e : groupStarts es + +-------------------------------------------------------------------------------- +-- * Data type for Events + +-- | Type of segment +data EventType s = Start !(NonEmpty s)| Intersection | End !s deriving (Show) + +instance Eq (EventType s) where + a == b = a `compare` b == EQ + +instance Ord (EventType s) where + (Start _) `compare` (Start _) = EQ + (Start _) `compare` _ = LT + Intersection `compare` (Start _) = GT + Intersection `compare` Intersection = EQ + Intersection `compare` (End _) = LT + (End _) `compare` (End _) = EQ + (End _) `compare` _ = GT + +-- | The actual event consists of a point and its type +data Event p r = Event { eventPoint :: !(Point 2 r) + , eventType :: !(EventType (LineSegment 2 p r)) + } deriving (Show,Eq) + +instance Ord r => Ord (Event p r) where + -- decreasing on the y-coord, then increasing on x-coord, and increasing on event-type + (Event p s) `compare` (Event q t) = case ordPoints p q of + EQ -> s `compare` t + x -> x + +-- | An ordering that is decreasing on y, increasing on x +ordPoints :: Ord r => Point 2 r -> Point 2 r -> Ordering +ordPoints a b = let f p = (Down $ p^.yCoord, p^.xCoord) in comparing f a b + +-- | Get the segments that start at the given event point +startSegs :: Event p r -> [LineSegment 2 p r] +startSegs e = case eventType e of + Start ss -> NonEmpty.toList ss + _ -> [] + +-------------------------------------------------------------------------------- + +-- | Compare based on the x-coordinate of the intersection with the horizontal +-- line through y +ordAt :: (Fractional r, Ord r) => r -> Compare (LineSegment 2 p r) +ordAt y = comparing (xCoordAt y) + +-- | Given a y coord and a line segment that intersects the horizontal line +-- through y, compute the x-coordinate of this intersection point. +-- +-- note that we will pretend that the line segment is closed, even if it is not +xCoordAt :: (Fractional r, Ord r) => r -> LineSegment 2 p r -> r +xCoordAt y (LineSegment' (Point2 px py :+ _) (Point2 qx qy :+ _)) + | py == qy = px `max` qx -- s is horizontal, and since it by the + -- precondition it intersects the sweep + -- line, we return the x-coord of the + -- rightmost endpoint. + | otherwise = px + alpha * (qx - px) + where + alpha = (y - py) / (qy - py) + +-------------------------------------------------------------------------------- +-- * The Main Sweep + +type EventQueue p r = EQ.Set (Event p r) +type StatusStructure p r = SS.OrdSeq (LineSegment 2 p r) + +-- | Run the sweep handling all events +sweep :: (Ord r, Fractional r) + => EventQueue p r -> StatusStructure p r -> [IntersectionPoint p r] +sweep eq ss = case EQ.minView eq of + Nothing -> [] + Just (e,eq') -> handle e eq' ss + +isClosedStart :: Eq r => Point 2 r -> LineSegment 2 p r -> Bool +isClosedStart p (LineSegment s e) + | p == s^.unEndPoint.core = isClosed s + | otherwise = isClosed e + +-- | Handle an event point +handle :: forall r p. (Ord r, Fractional r) + => Event p r -> EventQueue p r -> StatusStructure p r + -> [IntersectionPoint p r] +handle e@(eventPoint -> p) eq ss = toReport <> sweep eq' ss' + where + starts = startSegs e + (before,contains',after) = extractContains p ss + (ends,contains) = L.partition (endsAt p) contains' + -- starting segments, exluding those that have an open starting point + starts' = filter (isClosedStart p) starts + toReport = case starts' ++ contains' of + (_:_:_) -> [IntersectionPoint p $ associated (starts' <> ends) contains] + _ -> [] + + -- new status structure + ss' = before <> newSegs <> after + newSegs = toStatusStruct p $ starts ++ contains + + -- the new eeventqueue + eq' = foldr EQ.insert eq es + -- the new events: + es | F.null newSegs = maybeToList $ app (findNewEvent p) sl sr + | otherwise = let s' = fst <$> SS.minView newSegs + s'' = fst <$> SS.maxView newSegs + in catMaybes [ app (findNewEvent p) sl s' + , app (findNewEvent p) s'' sr + ] + sl = fst <$> SS.maxView before + sr = fst <$> SS.minView after + + app f x y = do { x' <- x ; y' <- y ; f x' y'} + +-- | split the status structure, extracting the segments that contain p. +-- the result is (before,contains,after) +extractContains :: (Fractional r, Ord r) + => Point 2 r -> StatusStructure p r + -> (StatusStructure p r, [LineSegment 2 p r], StatusStructure p r) +extractContains p ss = (before, F.toList $ mid1 <> mid2, after) + where + (before, mid1, after') = SS.splitOn (xCoordAt $ p^.yCoord) (p^.xCoord) ss + -- Make sure to also select the horizontal segments containing p + (mid2, after) = SS.splitMonotonic (not . intersects p) after' + +-- | Given a point and the linesegements that contain it. Create a piece of +-- status structure for it. +toStatusStruct :: (Fractional r, Ord r) + => Point 2 r -> [LineSegment 2 p r] -> StatusStructure p r +toStatusStruct p xs = ss <> hors + -- ss { SS.nav = ordAtNav $ p^.yCoord } `SS.join` hors + where + (hors',rest) = L.partition isHorizontal xs + ss = SS.fromListBy (ordAt $ maxY xs) rest + hors = SS.fromListBy (comparing rightEndpoint) hors' + + isHorizontal s = s^.start.core.yCoord == s^.end.core.yCoord + + -- find the y coord of the first interesting thing below the sweep at y + maxY = maximum . filter (< p^.yCoord) + . concatMap (\s -> [s^.start.core.yCoord,s^.end.core.yCoord]) + +-- | Get the right endpoint of a segment +rightEndpoint :: Ord r => LineSegment 2 p r -> r +rightEndpoint s = (s^.start.core.xCoord) `max` (s^.end.core.xCoord) + +-- | Test if a segment ends at p +endsAt :: Ord r => Point 2 r -> LineSegment 2 p r -> Bool +endsAt p (LineSegment' a b) = all (\q -> ordPoints (q^.core) p /= GT) [a,b] + +-------------------------------------------------------------------------------- +-- * Finding New events + +-- | Find all events +findNewEvent :: (Ord r, Fractional r) + => Point 2 r -> LineSegment 2 p r -> LineSegment 2 p r + -> Maybe (Event p r) +findNewEvent p l r = match (l `intersect` r) $ + (H $ \NoIntersection -> Nothing) + :& (H $ \q -> if ordPoints q p == GT then Just (Event q Intersection) + else Nothing) + :& (H $ \_ -> Nothing) -- full segment intersectsions are handled + -- at insertion time + :& RNil diff --git a/benchmark/Algorithms/Geometry/PolygonTriangulation/Bench.hs b/benchmark/Algorithms/Geometry/PolygonTriangulation/Bench.hs new file mode 100644 --- /dev/null +++ b/benchmark/Algorithms/Geometry/PolygonTriangulation/Bench.hs @@ -0,0 +1,64 @@ +module Algorithms.Geometry.PolygonTriangulation.Bench where +{- +import Algorithms.Geometry.LineSegmentIntersection (hasSelfIntersections) +import qualified Algorithms.Geometry.PolygonTriangulation.MakeMonotone as New +import qualified Algorithms.Geometry.PolygonTriangulation.MakeMonotoneOld as Old +import Benchmark.Util +import Control.DeepSeq +import Control.Lens +import Data.Ext +import Test.Tasty.Bench +import qualified Data.Foldable as F +import Data.Geometry.Ipe +import Data.Geometry.LineSegment +import Data.Geometry.Polygon +import Data.Geometry.PlanarSubdivision +import Data.Geometry.Point +import qualified Data.LSeq as LSeq +import qualified Data.List as List +import Data.Proxy +import Test.QuickCheck + +-------------------------------------------------------------------------------- + +data PX = PX + +main :: IO () +main = do + polies <- getPolies "/home/frank/tmp/antarctica.ipe" + defaultMain [ benchBuild polies ] + +getPolies inFile = do + ePage <- readSinglePageFile inFile + case ePage of + Left err -> error $ show err + Right (page :: IpePage Rational) -> pure $ runPage page + where + runPage page = + let polies = page^..content.to flattenGroups.traverse._withAttrs _IpePath _asSimplePolygon + in filter (not . hasSelfIntersections . (^.core)) polies + + +process f polies = let subdivs = map (\(pg :+ _) -> f (Identity PX) pg) polies + in concatMap (\ps -> map (^._2.core) . F.toList . edgeSegments $ ps) subdivs + +-- benchmark :: Benchmark +-- benchmark = bgroup "MakeMonotoneBench" +-- [ env (genPts (Proxy :: Proxy Rational) 100) benchBuild +-- ] + +-------------------------------------------------------------------------------- + +-- | Benchmark computing the closest pair +benchBuild :: (Ord r, Fractional r, NFData r) => [Polygon t () r :+ p] -> Benchmark +benchBuild ss = bgroup "MakeMonotone" [ bgroup (show n) (build $ take n ss) + | n <- sizes' ss + ] + where + sizes' xs = [length xs] + -- let n = length pts in [ n*i `div` 100 | i <- [10,20,25,50,75,100]] + + build ps = [ bench "Old" $ nf (process Old.makeMonotone) ps + , bench "New" $ nf (process New.makeMonotone) ps + ] +-} diff --git a/benchmark/Algorithms/Geometry/PolygonTriangulation/MakeMonotoneOld.hs b/benchmark/Algorithms/Geometry/PolygonTriangulation/MakeMonotoneOld.hs new file mode 100644 --- /dev/null +++ b/benchmark/Algorithms/Geometry/PolygonTriangulation/MakeMonotoneOld.hs @@ -0,0 +1,312 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +module Algorithms.Geometry.PolygonTriangulation.MakeMonotoneOld where + +import Algorithms.Geometry.LineSegmentIntersection.BentleyOttmann (ordAt, xCoordAt) +import Algorithms.Geometry.PolygonTriangulation.Types + +import Control.Lens +import Control.Monad (forM_, when) +import Control.Monad.Reader +import Control.Monad.State.Strict +import Control.Monad.Writer (WriterT, execWriterT, tell) +import Data.Bifunctor +import Data.CircularSeq (rotateL, rotateR, zip3LWith) +import qualified Data.DList as DList +import Data.Ext +import qualified Data.Foldable as F +import Data.Geometry.LineSegment +import Data.Geometry.PlanarSubdivision.Basic +import Data.Geometry.Point +import Data.Geometry.Polygon +import qualified Data.IntMap as IntMap +import qualified Data.List.NonEmpty as NonEmpty +import Data.Ord (Down (..), comparing) +import Data.OrdSeq (OrdSeq) +import qualified Data.OrdSeq as SS +import Data.Util +import qualified Data.Vector as V +import qualified Data.Vector.Circular as CV +import qualified Data.Vector.Mutable as MV + + +---------------------------------------------------------------------------------- + +data VertexType = Start | Merge | Split | End | Regular deriving (Show,Read,Eq) + + +-- How about the hole vertices? + +-- | assigns a vertex type to each vertex +-- +-- pre: the polygon is given in CCW order +-- +-- running time: \(O(n)\). +classifyVertices :: (Num r, Ord r) + => Polygon t p r + -> Polygon t (p :+ VertexType) r +classifyVertices p@SimplePolygon{} = classifyVertices' p +classifyVertices (MultiPolygon vs h) = MultiPolygon vs' h' + where + vs' = classifyVertices' vs + h' = map (first (&extra %~ onHole) . classifyVertices') h + + -- the roles on hole vertices are slightly different + onHole Start = Split + onHole Merge = End + onHole Split = Start + onHole End = Merge + onHole Regular = Regular + +-- | assigns a vertex type to each vertex +-- +-- pre: the polygon is given in CCW order +-- +-- running time: \(O(n)\). +classifyVertices' :: (Num r, Ord r) + => SimplePolygon p r + -> SimplePolygon (p :+ VertexType) r +classifyVertices' poly = + -- SimplePolygon $ zip3LWith f (rotateL vs) vs (rotateR vs) + unsafeFromCircularVector $ CV.zipWith3 f (CV.rotateLeft 1 vs) vs (CV.rotateRight 1 vs) + where + vs = poly ^. outerBoundaryVector + -- is the angle larger than > 180 degrees + largeInteriorAngle p c n = case ccw (p^.core) (c^.core) (n^.core) of + CCW -> False + CW -> True + _ -> error "classifyVertices -> largeInteriorAngle: colinear points" + + f p c n = c&extra %~ (:+ vt) + where + vt = case (p `cmpSweep` c, n `cmpSweep` c, largeInteriorAngle p c n) of + (LT, LT, False) -> Start + (LT, LT, True) -> Split + (GT, GT, False) -> End + (GT, GT, True) -> Merge + _ -> Regular + + + +-- | p < q = p.y < q.y || p.y == q.y && p.x > q.y +cmpSweep :: Ord r => Point 2 r :+ e -> Point 2 r :+ e -> Ordering +p `cmpSweep` q = + comparing (^.core.yCoord) p q <> comparing (Down . (^.core.xCoord)) p q + + +-------------------------------------------------------------------------------- + +type Event r = Point 2 r :+ (Two (LineSegment 2 Int r)) + +data StatusStruct r = SS { _statusStruct :: !(SS.OrdSeq (LineSegment 2 Int r)) + , _helper :: !(IntMap.IntMap Int) + -- ^ for every e_i, the id of the helper vertex + } deriving (Show) +makeLenses ''StatusStruct + +ix' :: Int -> Lens' (V.Vector a) a +ix' i = singular (ix i) + +-- | Given a polygon, find a set of non-intersecting diagonals that partition +-- the polygon into y-monotone pieces. +-- +-- running time: \(O(n\log n)\) +computeDiagonals :: forall t r p. (Fractional r, Ord r) + => Polygon t p r -> [LineSegment 2 p r] +computeDiagonals p' = map f . sweep + . NonEmpty.sortBy (flip cmpSweep) + . polygonVertices . withIncidentEdges + . first (^._1) $ pg + where + -- remaps to get the p value rather than the vertexId + f = first (\i -> vertexInfo^.ix' i._2) + + pg :: Polygon t (SP Int (p :+ VertexType)) r + pg = numberVertices . classifyVertices . toCounterClockWiseOrder $ p' + vertexInfo :: V.Vector (STR (Point 2 r) p VertexType) + vertexInfo = let vs = polygonVertices pg + n = F.length vs + in V.create $ do + v <- MV.new n + forM_ vs $ \(pt :+ SP i (p :+ vt)) -> + MV.write v i (STR pt p vt) + return v + + initialSS = SS mempty mempty + + sweep es = flip runReader vertexInfo $ evalStateT (sweep' es) initialSS + sweep' es = DList.toList <$> execWriterT (sweep'' es) + + sweep'' :: NonEmpty.NonEmpty (Event r) -> Sweep p r () + sweep'' = mapM_ handle + +-- | Computes a set of diagionals that decompose the polygon into y-monotone +-- pieces. +-- +-- running time: \(O(n\log n)\) +makeMonotone :: (Fractional r, Ord r) + => proxy s -> Polygon t p r + -> PlanarSubdivision s p PolygonEdgeType PolygonFaceData r +makeMonotone px pg = let (e:es) = listEdges pg + in constructSubdivision px e es (computeDiagonals pg) + +type Sweep p r = WriterT (DList.DList (LineSegment 2 Int r)) + (StateT (StatusStruct r) + (Reader (V.Vector (VertexInfo p r)))) + +type VertexInfo p r = STR (Point 2 r) p VertexType + + +tell' :: LineSegment 2 Int r -> Sweep p r () +tell' = tell . DList.singleton + +getIdx :: Event r -> Int +getIdx = view (extra._1.end.extra) + +getVertexType :: Int -> Sweep p r VertexType +getVertexType v = asks (^.ix' v._3) + +getEventType :: Event r -> Sweep p r VertexType +getEventType = getVertexType . getIdx + +handle :: (Fractional r, Ord r) => Event r -> Sweep p r () +handle e = let i = getIdx e in getEventType e >>= \case + Start -> handleStart i e + End -> handleEnd i e + Split -> handleSplit i e + Merge -> handleMerge i e + Regular | isLeftVertex i e -> handleRegularL i e + | otherwise -> handleRegularR i e + + +insertAt :: (Ord r, Fractional r) => Point 2 r -> LineSegment 2 q r + -> OrdSeq (LineSegment 2 q r) -> OrdSeq (LineSegment 2 q r) +insertAt v = SS.insertBy (ordAt $ v^.yCoord) + +deleteAt :: (Fractional r, Ord r) => Point 2 r -> LineSegment 2 p r + -> OrdSeq (LineSegment 2 p r) -> OrdSeq (LineSegment 2 p r) +deleteAt v = SS.deleteAllBy (ordAt $ v^.yCoord) + + +handleStart :: (Fractional r, Ord r) + => Int -> Event r -> Sweep p r () +handleStart i (v :+ adj) = modify $ \(SS t h) -> + SS (insertAt v (adj^._2) t) + (IntMap.insert i i h) + +handleEnd :: (Fractional r, Ord r) + => Int -> Event r -> Sweep p r () +handleEnd i (v :+ adj) = do let iPred = adj^._1.start.extra -- i-1 + -- lookup p's helper; if it is a merge vertex + -- we insert a new segment + tellIfMerge i v iPred + -- delete e_{i-1} from the status struct + modify $ \ss -> + ss&statusStruct %~ deleteAt v (adj^._1) + +-- | Adds edge (i,j) if e_j's helper is a merge vertex +tellIfMerge :: Int -> Point 2 r -> Int -> Sweep p r () +tellIfMerge i v j = do SP u ut <- getHelper j + when (ut == Merge) (tell' $ ClosedLineSegment (v :+ i) u) + +-- | Get the helper of edge i, and its vertex type +getHelper :: Int -> Sweep p r (SP (Point 2 r :+ Int) VertexType) +getHelper i = do ui <- gets (^?!helper.ix i) + STR u _ ut <- asks (^.ix' ui) + pure $ SP (u :+ ui) ut + + +lookupLE :: (Ord r, Fractional r) + => Point 2 r -> OrdSeq (LineSegment 2 Int r) + -> Maybe (LineSegment 2 Int r) +lookupLE v s = let (l,m,_) = SS.splitOn (xCoordAt $ v^.yCoord) (v^.xCoord) s + in SS.lookupMax (l <> m) + + +handleSplit :: (Fractional r, Ord r) => Int -> Event r -> Sweep p r () +handleSplit i (v :+ adj) = do ej <- gets $ \ss -> ss^?!statusStruct.to (lookupLE v)._Just + let j = ej^.start.extra + SP u _ <- getHelper j + -- update the status struct: + -- insert the new edge into the status Struct and + -- set the helper of e_j to be v_i + modify $ \(SS t h) -> + SS (insertAt v (adj^._2) t) + (IntMap.insert i i . IntMap.insert j i $ h) + -- return the diagonal + tell' $ ClosedLineSegment (v :+ i) u + +handleMerge :: (Fractional r, Ord r) => Int -> Event r -> Sweep p r () +handleMerge i (v :+ adj) = do let ePred = adj^._1.start.extra -- i-1 + tellIfMerge i v ePred + -- delete e_{i-1} from the status struct + modify $ \ss -> ss&statusStruct %~ deleteAt v (adj^._1) + connectToLeft i v + +-- | finds the edge j to the left of v_i, and connect v_i to it if the helper +-- of j is a merge vertex +connectToLeft :: (Fractional r, Ord r) => Int -> Point 2 r -> Sweep p r () +connectToLeft i v = do ej <- gets $ \ss -> ss^?!statusStruct.to (lookupLE v)._Just + let j = ej^.start.extra + tellIfMerge i v j + modify $ \ss -> ss&helper %~ IntMap.insert j i + +-- | returns True if v the interior of the polygon is to the right of v +isLeftVertex :: Ord r => Int -> Event r -> Bool +isLeftVertex i (v :+ adj) = case (adj^._1.start) `cmpSweep` (v :+ i) of + GT -> True + _ -> False + -- if the predecessor occurs before the sweep, this must be a left vertex + +handleRegularL :: (Fractional r, Ord r) => Int -> Event r -> Sweep p r () +handleRegularL i (v :+ adj) = do let ePred = adj^._1.start.extra -- i-1 + tellIfMerge i v ePred + -- delete e_{i-1} from the status struct + modify $ \ss -> + ss&statusStruct %~ deleteAt v (adj^._1) + -- insert a e_i in the status struct, and set its helper + -- to be v_i + modify $ \(SS t h) -> + SS (insertAt v (adj^._2) t) + (IntMap.insert i i h) + +handleRegularR :: (Fractional r, Ord r) => Int -> Event r -> Sweep p r () +handleRegularR i (v :+ _) = connectToLeft i v + + + + +-------------------------------------------------------------------------------- + + +-- testPolygon :: SimplePolygon Int Rational +-- testPolygon = fromPoints [ Point2 20 20 :+ 1 +-- , Point2 18 19 :+ 2 +-- , Point2 16 25 :+ 3 +-- , Point2 13 23 :+ 4 +-- , Point2 10 24 :+ 5 +-- , Point2 6 22 :+ 6 +-- , Point2 8 21 :+ 7 +-- , Point2 7 18 :+ 8 +-- , Point2 2 19 :+ 9 +-- , Point2 1 10 :+ 10 +-- , Point2 3 5 :+ 11 +-- , Point2 11 7 :+ 12 +-- , Point2 15 1 :+ 13 +-- , Point2 12 15 :+ 14 +-- , Point2 15 12 :+ 15 +-- ] + +-- vertexTypes = [Start,Merge,Start,Merge,Start,Regular,Regular,Merge,Start,Regular,End,Split,End,Split,End] + + +-- loadT = do pgs <- readAllFrom "/Users/frank/tmp/testPoly.ipe" +-- :: IO [SimplePolygon () Rational :+ IpeAttributes Path Rational] +-- mapM_ print pgs +-- let diags = map (computeDiagonals . (^.core)) pgs +-- f = asIpeGroup . map (asIpeObject' mempty) +-- out = [ asIpeGroup $ map (\(pg :+ a) -> asIpeObject pg a) pgs +-- , asIpeGroup $ map f diags +-- ] +-- outFile = "/Users/frank/tmp/out.ipe" +-- writeIpeFile outFile . singlePageFromContent $ out diff --git a/benchmark/Benchmark/Util.hs b/benchmark/Benchmark/Util.hs new file mode 100644 --- /dev/null +++ b/benchmark/Benchmark/Util.hs @@ -0,0 +1,7 @@ +module Benchmark.Util where + + + +-- | Generates different size benchmarks +sizes :: Foldable f => f a -> [Int] +sizes xs = let n = length xs in (\i -> n*i `div` 100) <$> [5,10..100] diff --git a/benchmark/Benchmarks.hs b/benchmark/Benchmarks.hs new file mode 100644 --- /dev/null +++ b/benchmark/Benchmarks.hs @@ -0,0 +1,10 @@ +module Main where + +import qualified Algorithms.Geometry.ClosestPair.Bench as CP +import qualified Algorithms.Geometry.LineSegmentIntersection.Bench as Line +-- import qualified Algorithms.Geometry.PolygonTriangulation.Bench as M +import qualified Algorithms.Geometry.ConvexHull.Bench as M +import Test.Tasty.Bench + +main :: IO () +main = defaultMain [ CP.benchmark, M.benchmark, Line.benchmark ] diff --git a/benchmark/Data/Geometry/IntervalTreeBench.hs b/benchmark/Data/Geometry/IntervalTreeBench.hs new file mode 100644 --- /dev/null +++ b/benchmark/Data/Geometry/IntervalTreeBench.hs @@ -0,0 +1,75 @@ +module Data.Geometry.IntervalTreeBench where + +import Benchmark.Util +import Control.DeepSeq +import Control.Lens +import Test.Tasty.Bench +import Data.Ext +import Data.Geometry.Interval +import qualified Data.Geometry.IntervalTree as IT +import Data.Geometry.SegmentTree (I(..)) +import qualified Data.Geometry.SegmentTree as SegTree +import qualified Data.List.NonEmpty as NonEmpty +import Debug.Trace +import Test.QuickCheck + +-------------------------------------------------------------------------------- + +main :: IO () +main = defaultMain [ intervalBench ] + +intervalBench :: Benchmark +intervalBench = bgroup "IntervalTree" + [ -- env (genIntervals (I (5 :: Int)) 1000) benchBuild + -- env (genIntervals (I (5 :: Int)) 100) benchQueryIT + ] + +-------------------------------------------------------------------------------- + +-- | generates n random intervals +genIntervals :: (Ord r, Arbitrary r) + => proxy r -> Int -> IO [Interval () r] +genIntervals _ n | n <= 0 = error "genIntervals: need n > 0" + | otherwise = generate (vectorOf n arbitrary) + +genQueries :: (Ord r, Arbitrary r) + => proxy r -> Int -> IO [r] +genQueries _ n | n <= 0 = error "genQueries: need n > 0" + | otherwise = generate (vectorOf n arbitrary) + + +-- genQuerySetup :: (Ord r, Arbitrary r) +-- => proxy r -> Int -> IO (Int,IT.IntervalTree (I (Interval () r)) r, [r]) +-- genQuerySetup p n = (\is qs -> (n, IT.fromIntervals . fmap I $ is, qs)) +-- <$> genIntervals p n +-- <*> genQueries p n + + +-- | Benchmark building the interval tree +benchBuild :: (Ord r, NFData r) => [Interval () r] -> Benchmark +benchBuild is = bgroup "build" [ bench (show n) $ nf IT.fromIntervals (take n is') + | n <- sizes is + ] + where + is' = I <$> is + +-- benchQueryIT :: (Ord r, Arbitrary r, NFData r) => [Interval () r] -> Benchmark +-- benchQueryIT is = bgroup "queries" +-- [ env (setup' n) (\(t,qs) -> +-- bench ("queries on size" ++ show n) $ whnf (queryAll t) qs) +-- | n <- sizes is +-- ] +-- where +-- is' = I <$> is +-- r = is^.to head.start.core +-- setup' n = traceShow "setup" $ setup n + +-- setup n = (IT.fromIntervals (take n is'),) <$> genQueries (I r) 100000 +-- queryAll t = map (flip IT.search t) + + +-- benchQueryIT :: Ord r +-- => (Int, IT.IntervalTree (I (Interval () r)) r, [r]) -> Benchmark +-- benchQueryIT (n,t,qs) = bgroup "queries" [ bench "query" $ whnf (flip IT.search t) q +-- | q <- qs +-- ] diff --git a/benchmark/Data/Geometry/Vector/VectorFamily6.hs b/benchmark/Data/Geometry/Vector/VectorFamily6.hs new file mode 100644 --- /dev/null +++ b/benchmark/Data/Geometry/Vector/VectorFamily6.hs @@ -0,0 +1,257 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE UndecidableInstances #-} +module Data.Geometry.Vector.VectorFamily6 where + +import Control.Applicative (liftA2) +import Control.DeepSeq +import Control.Lens hiding (element) +-- import Data.Aeson (ToJSON(..),FromJSON(..)) +import qualified Data.Foldable as F +import qualified Data.Geometry.Vector.VectorFixed as FV +import Data.Maybe (fromMaybe) +import Data.Proxy +import Data.Traversable (foldMapDefault,fmapDefault) +import qualified Data.Vector.Fixed as V +import Data.Vector.Fixed.Cont (Peano(..), PeanoNum(..), Fun(..)) +import GHC.TypeLits +import Linear.Affine (Affine(..)) +import Linear.Metric +import qualified Linear.V2 as L2 +import qualified Linear.V3 as L3 +import qualified Linear.V4 as L4 +import Linear.Vector + +-------------------------------------------------------------------------------- +-- * d dimensional Vectors + + +type One = S Z +type Two = S One +type Three = S Two +type Four = S Three +type Many d = S (S (S (S (S d)))) + + +type family FromPeano (d :: PeanoNum) :: Nat where + FromPeano Z = 0 + FromPeano (S d) = 1 + FromPeano d + + +data SingPeano (d :: PeanoNum) where + SZ :: SingPeano Z + SS :: !(SingPeano d) -> SingPeano (S d) + +class ImplicitPeano (d :: PeanoNum) where + implicitPeano :: SingPeano d +instance ImplicitPeano Z where + implicitPeano = SZ +instance ImplicitPeano d => ImplicitPeano (S d) where + implicitPeano = SS implicitPeano + +-- | Mapping between the implementation type, and the actual implementation. +type family VectorFamilyF (d :: PeanoNum) :: * -> * where + VectorFamilyF Z = Const () + VectorFamilyF One = Identity + VectorFamilyF Two = L2.V2 + VectorFamilyF Three = L3.V3 + VectorFamilyF Four = L4.V4 + VectorFamilyF (Many d) = FV.Vector (FromPeano (Many d)) + + +-- | Datatype representing d dimensional vectors. The default implementation is +-- based n VectorFixed. However, for small vectors we automatically select a +-- more efficient representation. +newtype VectorFamily (d :: PeanoNum) (r :: *) = + VectorFamily { _unVF :: VectorFamilyF d r } + +type ImplicitArity d = (ImplicitPeano d, V.Arity (FromPeano d)) + + + +instance (Eq r, ImplicitArity d) => Eq (VectorFamily d r) where + (VectorFamily u) == (VectorFamily v) = case (implicitPeano :: SingPeano d) of + SZ -> u == v + (SS SZ) -> u == v + (SS (SS SZ)) -> u == v + (SS (SS (SS SZ))) -> u == v + (SS (SS (SS (SS SZ)))) -> u == v + (SS (SS (SS (SS (SS _))))) -> u == v + {-# INLINE (==) #-} + +instance (Ord r, ImplicitArity d) => Ord (VectorFamily d r) where + (VectorFamily u) `compare` (VectorFamily v) = case (implicitPeano :: SingPeano d) of + SZ -> u `compare` v + (SS SZ) -> u `compare` v + (SS (SS SZ)) -> u `compare` v + (SS (SS (SS SZ))) -> u `compare` v + (SS (SS (SS (SS SZ)))) -> u `compare` v + (SS (SS (SS (SS (SS _))))) -> u `compare` v + {-# INLINE compare #-} + + +instance ImplicitArity d => Functor (VectorFamily d) where + fmap f = VectorFamily . g f . _unVF + where g = case (implicitPeano :: SingPeano d) of + SZ -> fmap + (SS SZ) -> fmap + (SS (SS SZ)) -> fmap + (SS (SS (SS SZ))) -> fmap + (SS (SS (SS (SS SZ)))) -> fmap + (SS (SS (SS (SS (SS _))))) -> fmap + {-# INLINE fmap #-} + + +instance ImplicitArity d => Foldable (VectorFamily d) where + foldMap f = g f . _unVF + where g = case (implicitPeano :: SingPeano d) of + SZ -> foldMap + (SS SZ) -> foldMap + (SS (SS SZ)) -> foldMap + (SS (SS (SS SZ))) -> foldMap + (SS (SS (SS (SS SZ)))) -> foldMap + (SS (SS (SS (SS (SS _))))) -> foldMap + {-# INLINE foldMap #-} + +instance ImplicitArity d => Traversable (VectorFamily d) where + traverse f = fmap VectorFamily . g f . _unVF + where g = case (implicitPeano :: SingPeano d) of + SZ -> traverse + (SS SZ) -> traverse + (SS (SS SZ)) -> traverse + (SS (SS (SS SZ))) -> traverse + (SS (SS (SS (SS SZ)))) -> traverse + (SS (SS (SS (SS (SS _))))) -> traverse + {-# INLINE traverse #-} + +instance ImplicitArity d => Applicative (VectorFamily d) where + pure = VectorFamily . case (implicitPeano :: SingPeano d) of + SZ -> pure + (SS SZ) -> pure + (SS (SS SZ)) -> pure + (SS (SS (SS SZ))) -> pure + (SS (SS (SS (SS SZ)))) -> pure + (SS (SS (SS (SS (SS _))))) -> pure + {-# INLINE pure #-} + liftA2 f (VectorFamily u) (VectorFamily v) = VectorFamily $ + case (implicitPeano :: SingPeano d) of + SZ -> liftA2 f u v + (SS SZ) -> liftA2 f u v + (SS (SS SZ)) -> liftA2 f u v + (SS (SS (SS SZ))) -> liftA2 f u v + (SS (SS (SS (SS SZ)))) -> liftA2 f u v + (SS (SS (SS (SS (SS _))))) -> liftA2 f u v + {-# INLINE liftA2 #-} + + + + +type instance V.Dim (VectorFamily d) = FromPeano d + + + + +instance ImplicitArity d => V.Vector (VectorFamily d) r where + construct = fmap VectorFamily $ case (implicitPeano :: SingPeano d) of + SZ -> Fun $ Const () + (SS SZ) -> V.construct + (SS (SS SZ)) -> Fun L2.V2 + (SS (SS (SS SZ))) -> Fun L3.V3 + (SS (SS (SS (SS SZ)))) -> Fun L4.V4 + (SS (SS (SS (SS (SS _))))) -> V.construct + {-# INLINE construct #-} + inspect (VectorFamily v) ff@(Fun f) = case (implicitPeano :: SingPeano d) of + SZ -> f + (SS SZ) -> V.inspect v ff + (SS (SS SZ)) -> let (L2.V2 x y) = v in f x y + (SS (SS (SS SZ))) -> let (L3.V3 x y z) = v in f x y z + (SS (SS (SS (SS SZ)))) -> let (L4.V4 x y z w) = v in f x y z w + (SS (SS (SS (SS (SS _))))) -> V.inspect v ff + {-# INLINE inspect #-} + -- basicIndex (VectorFamily v) i = case (implicitPeano :: SingPeano d) of + -- SZ -> err + -- (SS SZ) -> if i == 0 then runIdentity v else err + -- (SS (SS SZ)) -> let (L2.V2 x y) = v in f x y + -- (SS (SS (SS SZ))) -> let (L3.V3 x y z) = v in f x y z + -- (SS (SS (SS (SS SZ)))) -> let (L4.V4 x y z w) = v in f x y z w + -- (SS (SS (SS (SS (SS _))))) -> V.basicIndex v i + -- where + -- err = error "VectorFamily: basicIndex out of range" + -- {-# INLINE basicIndex #-} + + +instance (ImplicitArity d, Show r) => Show (VectorFamily d r) where + show v = mconcat [ "Vector", show $ F.length v , " " + , show $ F.toList v ] + +deriving instance (NFData (VectorFamilyF d r)) => NFData (VectorFamily d r) + + +type instance Index (VectorFamily d r) = Int +type instance IxValue (VectorFamily d r) = r + +-------------------------------------------------------------------------------- + + +newtype Vector (d :: Nat) (r :: *) = MKVector { _unV :: VectorFamily (Peano d) r } + +type instance V.Dim (Vector d) = d + + +type instance Index (Vector d r) = Int +type instance IxValue (Vector d r) = r + +type Arity d = ImplicitArity (Peano d) + +deriving instance (Eq r, Arity d) => Eq (Vector d r) +deriving instance (Ord r, Arity d) => Ord (Vector d r) + +deriving instance Arity d => Functor (Vector d) +deriving instance Arity d => Foldable (Vector d) +deriving instance Arity d => Traversable (Vector d) + +instance (Arity d, Show r) => Show (Vector d r) where + show v = mconcat [ "Vector", show $ F.length v , " " + , show $ F.toList v ] + + +deriving instance (NFData (VectorFamily (Peano d) r)) => NFData (Vector d r) + + + + +-------------------------------------------------------------------------------- +-- * Convenience "constructors" + +pattern Vector :: VectorFamilyF (Peano d) r -> Vector d r +pattern Vector v = MKVector (VectorFamily v) + +pattern Vector1 :: r -> Vector 1 r +pattern Vector1 x = (Vector (Identity x)) + +pattern Vector2 :: r -> r -> Vector 2 r +pattern Vector2 x y = (Vector (L2.V2 x y)) + +pattern Vector3 :: r -> r -> r -> Vector 3 r +pattern Vector3 x y z = (Vector (L3.V3 x y z)) + +pattern Vector4 :: r -> r -> r -> r -> Vector 4 r +pattern Vector4 x y z w = (Vector (L4.V4 x y z w)) + +-------------------------------------------------------------------------------- + +-- -- destruct :: (Vec d r, Vec (d + 1) r, 1 <= (d + 1)) +-- -- => Vector (d + 1) r -> (r, Vector d r) +-- -- destruct (Vector v) = (V.head v, Vector $ V.tail v) + + +-- -- -- vectorFromList :: Arity d => [a] -> Maybe (Vector d a) +-- -- vectorFromList = fmap Vector . V.fromListM + +-- -- vectorFromListUnsafe :: V.Arity d => [a] -> Vector d a +-- -- vectorFromListUnsafe = Vector . V.fromList + + -------------------------------------------------------------------------------- + +-- | Cross product of two three-dimensional vectors +cross :: Num r => Vector 3 r -> Vector 3 r -> Vector 3 r +(Vector u) `cross` (Vector v) = Vector $ u `L3.cross` v diff --git a/changelog.org b/changelog.org --- a/changelog.org +++ b/changelog.org @@ -2,6 +2,32 @@ * Changelog +** 0.12 + +- New website: https://hgeometry.org/ +- Switch polygon implementation from a circular seq to a circular vector. +- Hide polygon implementation details. +- Enforce CCW polygon order by default. +- Fix bug in Data.Geometry.Polygon.Convex.extremes/maxInDirection. +- Fix bug in pointInPolygon in case of degenerate situations. +- Fix Read/Show instances for Point and Polygon such that 'read.show = id'. +- Improved numerical robustness. +- Random generation of monotone polygons. Thanks to @1ndy. +- Random and uniform generation of convex polygons. +- More IsIntersectableWith instances +- Updated Show/Read instances for LineSegments +- New algorithm: Visibility polygon in O(n log n) time. +- New algorithm: Earclip triangulation in O(n^2) time worst case, O(n) + time expected case. +- New algorithm: Single-source shortest path in O(n) time. +- New algorithm: Planar point locator in O(log n) time. +- New algorithm: Point set diameter in O(n log n) time. +- New algorithm: Convex hull of a polygon in O(n) time. +- New algorithm: Diameter of a convex polygon in O(n) time. +- New algorithm: Check if a point lies inside a convex polygon in O(n) + time. +- New algorithm: Discrete Frechet distance in O(n^2) time. + ** 0.11 - Removed Functor instance from Triangle and replaced it with Bifunctor/Bifoldable/Bitraversable diff --git a/doctests.hs b/doctests.hs --- a/doctests.hs +++ b/doctests.hs @@ -29,7 +29,6 @@ , "DeriveFunctor" , "DeriveFoldable" , "DeriveTraversable" - , "AutoDeriveTypeable" , "DeriveGeneric" , "FlexibleInstances" , "FlexibleContexts" @@ -70,4 +69,5 @@ , "Algorithms.Geometry.ConvexHull.JarvisMarch" , "Algorithms.Geometry.SoS.Orientation" + , "Algorithms.Geometry.InPolygon" ] diff --git a/hgeometry.cabal b/hgeometry.cabal --- a/hgeometry.cabal +++ b/hgeometry.cabal @@ -1,5 +1,5 @@ name: hgeometry -version: 0.11.0.0 +version: 0.12.0.0 synopsis: Geometric Algorithms, Data structures, and Data types. description: HGeometry provides some basic geometry types, and geometric algorithms and @@ -19,28 +19,6 @@ category: Geometry build-type: Simple -data-files: test/Algorithms/Geometry/LineSegmentIntersection/manual.ipe - test/Algorithms/Geometry/LineSegmentIntersection/selfIntersections.ipe - test/Algorithms/Geometry/LowerEnvelope/manual.ipe - test/Algorithms/Geometry/PolygonTriangulation/monotone.ipe - test/Algorithms/Geometry/PolygonTriangulation/simplepolygon6.ipe - test/Algorithms/Geometry/SmallestEnclosingDisk/manual.ipe - test/Algorithms/Geometry/LinearProgramming/manual.ipe - test/Algorithms/Geometry/RedBlueSeparator/manual.ipe - test/Data/Geometry/pointInPolygon.ipe - test/Data/Geometry/pointInTriangle.ipe - test/Data/Geometry/Polygon/star_shaped.ipe - test/Data/Geometry/Polygon/Convex/convexTests.ipe - test/Data/Geometry/arrangement.ipe - test/Data/Geometry/arrangement.ipe.out.ipe - test/Data/PlaneGraph/myPlaneGraph.yaml - test/Data/PlaneGraph/small.yaml - test/Data/PlaneGraph/testsegs.png - - -- in the future (cabal >=2.4) we can use - -- examples/**/*.in - -- examples/**/*.out - extra-source-files: README.md changelog.org @@ -52,6 +30,10 @@ type: git location: https://github.com/noinia/hgeometry +flag planargraph + default: False + manual: True + library ghc-options: -O2 -Wall -fno-warn-unticked-promoted-constructors -fno-warn-type-defaults @@ -84,6 +66,7 @@ Data.Geometry.Line Data.Geometry.Line.Internal Data.Geometry.LineSegment + Data.Geometry.LineSegment.Internal Data.Geometry.SubLine Data.Geometry.HalfLine Data.Geometry.PolyLine @@ -101,7 +84,9 @@ Data.Geometry.Ellipse Data.Geometry.Polygon + Data.Geometry.Polygon.Inflate Data.Geometry.Polygon.Convex + Data.Geometry.Polygon.Monotone Data.Geometry.BezierSpline @@ -132,10 +117,16 @@ Data.Geometry.QuadTree.Split Data.Geometry.QuadTree.Tree + Data.Geometry.PointLocation + Data.Geometry.PointLocation.PersistentSweep + Data.Geometry.VerticalRayShooting + Data.Geometry.VerticalRayShooting.PersistentSweep + -- * Algorithms -- * Geometric Algorithms + Algorithms.Geometry.ConvexHull Algorithms.Geometry.ConvexHull.GrahamScan Algorithms.Geometry.ConvexHull.DivideAndConquer Algorithms.Geometry.ConvexHull.QuickHull @@ -144,7 +135,7 @@ Algorithms.Geometry.LowerEnvelope.DualCH - Algorithms.Geometry.SmallestEnclosingBall.Types + Algorithms.Geometry.SmallestEnclosingBall Algorithms.Geometry.SmallestEnclosingBall.RIC Algorithms.Geometry.SmallestEnclosingBall.Naive @@ -154,12 +145,16 @@ Algorithms.Geometry.PolyLineSimplification.DouglasPeucker + Algorithms.Geometry.EuclideanMST Algorithms.Geometry.EuclideanMST.EuclideanMST + Algorithms.Geometry.WSPD Algorithms.Geometry.WellSeparatedPairDecomposition.WSPD Algorithms.Geometry.WellSeparatedPairDecomposition.Types + Algorithms.Geometry.Diameter Algorithms.Geometry.Diameter.Naive + Algorithms.Geometry.Diameter.ConvexHull -- Algorithms.Geometry.Sweep @@ -167,14 +162,16 @@ Algorithms.Geometry.PolygonTriangulation.Triangulate Algorithms.Geometry.PolygonTriangulation.MakeMonotone Algorithms.Geometry.PolygonTriangulation.TriangulateMonotone + Algorithms.Geometry.PolygonTriangulation.EarClip Algorithms.Geometry.LineSegmentIntersection Algorithms.Geometry.LineSegmentIntersection.Naive Algorithms.Geometry.LineSegmentIntersection.BentleyOttmann - Algorithms.Geometry.LineSegmentIntersection.Types + Algorithms.Geometry.LineSegmentIntersection.BooleanSweep -- Algorithms.Geometry.HiddenSurfaceRemoval.HiddenSurfaceRemoval + Algorithms.Geometry.ClosestPair Algorithms.Geometry.ClosestPair.Naive Algorithms.Geometry.ClosestPair.DivideAndConquer @@ -185,6 +182,9 @@ Algorithms.Geometry.FrechetDistance.Discrete + Algorithms.Geometry.VisibilityPolygon.Lee + Algorithms.Geometry.SSSP + Algorithms.Geometry.SSSP.Naive -- * Embedded Planar Graphs Data.PlaneGraph @@ -202,8 +202,13 @@ -- * Implementation Internals of Polygons Data.Geometry.Polygon.Core Data.Geometry.Polygon.Extremes + Algorithms.Geometry.InPolygon + Algorithms.Geometry.LineSegmentIntersection.Types + Algorithms.Geometry.SmallestEnclosingBall.Types + Algorithms.Geometry.WSPD.Types + Data.Geometry.Point.Internal Data.Geometry.Point.Orientation Data.Geometry.Point.Quadrants @@ -222,7 +227,7 @@ -- other-extensions: build-depends: base >= 4.11 && < 5 - , hgeometry-combinatorial >= 0.11.0.0 + , hgeometry-combinatorial >= 0.12.0.0 , bifunctors >= 4.1 , bytestring >= 0.10 @@ -251,9 +256,12 @@ -- , ghc-typelits-natnormalise >= 0.6 -- , ghc-typelits-knownnat >= 0.6 - , vector >= 0.11 + , vector >= 0.11 && < 0.12.2.0 , data-clist >= 0.1.2.3 + , vector-circular >= 0.1.2 + , nonempty-vector >= 0.2.0.0 , text >= 1.1.1.0 + , vector-algorithms , aeson >= 1.0 , yaml >= 0.8 @@ -304,5 +312,111 @@ , doctest >= 0.8 , doctest-discover , QuickCheck + , quickcheck-instances default-language: Haskell2010 + +benchmark benchmarks + + hs-source-dirs: benchmark + + main-is: Benchmarks.hs + type: exitcode-stdio-1.0 + + other-modules: Benchmark.Util + Algorithms.Geometry.ConvexHull.Bench + Algorithms.Geometry.ConvexHull.GrahamV2 + Algorithms.Geometry.ConvexHull.GrahamFam + Algorithms.Geometry.ConvexHull.GrahamFamPeano + Algorithms.Geometry.ConvexHull.GrahamFixed + Data.Geometry.Vector.VectorFamily6 + Algorithms.Geometry.ConvexHull.GrahamFam6 + Data.Geometry.IntervalTreeBench + -- Demo.ExpectedPairwiseDistance + -- Demo.TriangulateWorld + -- WSPDBench + Algorithms.Geometry.ClosestPair.Bench + + Algorithms.Geometry.LineSegmentIntersection.Bench + Algorithms.Geometry.LineSegmentIntersection.BentleyOttmannOld + + Algorithms.Geometry.PolygonTriangulation.Bench + Algorithms.Geometry.PolygonTriangulation.MakeMonotoneOld + + + build-depends: + base + , tasty-bench + , fixed-vector + , linear + , semigroups + , deepseq + , deepseq-generics + , hgeometry + , hgeometry-combinatorial + , lens + , semigroupoids + , QuickCheck + , bytestring + , containers + , optparse-applicative + , vinyl + , vector + , dlist + , mtl + , vector-circular + , MonadRandom + , hashable + + + ghc-options: -Wall -O2 -rtsopts -fno-warn-unticked-promoted-constructors + + default-language: Haskell2010 + + default-extensions: TypeFamilies + , GADTs + , KindSignatures + , DataKinds + , TypeOperators + , ConstraintKinds + , PolyKinds + , RankNTypes + , TypeApplications + , ScopedTypeVariables + + , PatternSynonyms + , ViewPatterns + , LambdaCase + , TupleSections + + + , StandaloneDeriving + , GeneralizedNewtypeDeriving + , DeriveFunctor + , DeriveFoldable + , DeriveTraversable + + , FlexibleInstances + , FlexibleContexts + , MultiParamTypeClasses + +executable planargraph + main-is: planargraph.hs + if flag(planargraph) + buildable: True + else + buildable: False + default-language: Haskell2010 + build-depends: base, + vector, + vector-circular, + linear, + text, + hashable, + lens, + directory, + filepath, + hgeometry, + hgeometry-combinatorial, + reanimate, + reanimate-svg diff --git a/planargraph.hs b/planargraph.hs new file mode 100644 --- /dev/null +++ b/planargraph.hs @@ -0,0 +1,136 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +module Main where + +import Data.PlanarGraph.Immutable +import qualified Data.PlanarGraph.Mutable as Mut + +import Control.Lens () +import Control.Monad.ST +import Data.Ext +import Data.Foldable as F +import Data.Geometry.Point +import Data.Geometry.Polygon +import Data.STRef +import Data.Hashable +import qualified Data.Text as T +import qualified Data.Vector as V +import qualified Data.Vector.Circular as CV +import Graphics.SvgTree (Number (..)) +import Linear.Metric +import Linear.V2 +import Linear.Vector +import Reanimate +import Reanimate.Animation +import System.Directory +import System.FilePath +import Debug.Trace + +graphs :: [PlanarGraph] +graphs = + [ pgFromFaces [[0..2]] + , pgFromFaces [[1,2,3]] + , pgFromFaces [[0..3]] + , pgFromFaces [[0..3],[4,3,2,1]] + , let pg = pgFromFaces [[0..3]] + in pgMutate pg $ \pg' -> do + let he0 = Mut.halfEdgeFromId 0 pg' + he4 = Mut.halfEdgeFromId 4 pg' + _newEdge <- Mut.pgConnectVertices he0 he4 + return () + , pgFromFaces [[0,4,1],[0,1,2],[4,3,1],[4,5,3],[3,5,2],[2,5,0]] + ] + +main :: IO () +-- main = reanimate $ staticFrame (1/60) (fst test2) +main = do + forM_ graphs savePlanarGraphSVG + +-- test1 = renderPlanarGraph (pgFromFaces [[0..2]]) +-- test2 = renderPlanarGraph (pgFromFaces [[0..3],[4,3,2,1]]) + +savePlanarGraphSVG :: PlanarGraph -> IO () +savePlanarGraphSVG pg = do + writeFile fileName svgOutput + writeFile compactName compactOutput + where + svgOutput = renderSvg (Just $ Num 300) (Just $ Num 300) svg + compactOutput = renderSvg (Just $ Num 300) (Just $ Num 300) compactSvg + fileName = "planargraph-" ++ show (hash pg) <.> "svg" + compactName = "planargraph-" ++ show (hash pg) <.> "compact" <.> "svg" + defOpts = RenderOptions { disableHalfEdges = False } + compactOpts = RenderOptions { disableHalfEdges = True } + svg = renderPlanarGraph defOpts pg + compactSvg = renderPlanarGraph compactOpts pg + +data RenderOptions = RenderOptions + { disableHalfEdges :: Bool } + +renderPlanarGraph :: RenderOptions -> PlanarGraph -> SVG +renderPlanarGraph RenderOptions{..} pg = svg + where + vs = tutteEmbedding pg + faces = pgFaces pg + svg = + withViewBox (screenBottom, screenBottom, screenHeight, screenHeight) $ + mkGroup + [ mkBackground bgColor + , mkGroup + [ translate (x*scaleFactor) (y*scaleFactor) $ + mkGroup + [ label + , withFillOpacity 0 $ withStrokeColor "black" $ withStrokeWidth strokeWidth $ + -- mkRect (strokeWidth+svgWidth label*1.5) (strokeWidth+svgHeight label*1.5) + translate 0 (-(svgHeight label+0.1)/2) $ + center $ mkLine (0,0) (svgWidth label*1.2,0) + ] + | face <- faces + , let boundary = faceBoundary face pg + poly = simpleFromPoints $ map ext + [ Point2 x y + | vId <- boundary + , let V2 x y = vs V.! vertexId vId + ] + Point2 x y = centroid poly + label = scale 0.5 $ center $ latex (T.pack $ show $ faceId face) + ] + , mkGroup + [ mkGroup $ + [ withStrokeColor "black" $ + mkLine (tipX*scaleFactor, tipY*scaleFactor) (tailX*scaleFactor, tailY*scaleFactor) + ] ++ if disableHalfEdges + then [] + else + [ translate (halfX*scaleFactor + angY) (halfY*scaleFactor - angX) $ + labelTwin + , translate (halfX*scaleFactor - angY) (halfY*scaleFactor + angX) $ + labelEdge + ] + | edge <- pgEdges pg + , let (tip, tail) = edgeHalfEdges edge + V2 tipX tipY = vs V.! vertexId (halfEdgeVertex tip pg) + V2 tailX tailY = vs V.! vertexId (halfEdgeVertex tail pg) + (halfX,halfY) = (tipX + (tailX-tipX)/2, tipY + (tailY-tipY)/2) + labelEdge = scale 0.4 $ center $ latex (T.pack $ show $ halfEdgeId tip) + labelTwin = scale 0.4 $ center $ latex (T.pack $ show $ halfEdgeId tail) + V2 angX angY = signorm (V2 tipX tipY - V2 tailX tailY) ^* 0.3 + ] + , mkGroup + [ translate (x*scaleFactor) (y*scaleFactor) $ + mkGroup + [ withFillOpacity 1 $ withFillColor "white" $ withStrokeColor "black" $ + mkCircle 0.3 + , label ] + | v <- map vertexId $ pgVertices pg + , let V2 x y = vs V.! v + label = scaleToWidth 0.2 $ center $ latex (T.pack $ show v) + ] + ] + +strokeWidth = defaultStrokeWidth*0.5 + +bgColor :: String +bgColor = "white" + +scaleFactor :: Double +scaleFactor = screenTop*0.8 diff --git a/src/Algorithms/Geometry/ClosestPair.hs b/src/Algorithms/Geometry/ClosestPair.hs new file mode 100644 --- /dev/null +++ b/src/Algorithms/Geometry/ClosestPair.hs @@ -0,0 +1,14 @@ +-------------------------------------------------------------------------------- +-- | +-- Module : Algorithms.Geometry.ClosestPair +-- Copyright : (C) Frank Staals +-- License : see the LICENSE file +-- Maintainer : Frank Staals +-- +-- \(O(n\log n)\) time algorithm to compute the +-- closest pair among a set of \(n\) points in \(\mathbb{R}^2\). +-- +-------------------------------------------------------------------------------- +module Algorithms.Geometry.ClosestPair( closestPair ) where + +import Algorithms.Geometry.ClosestPair.DivideAndConquer diff --git a/src/Algorithms/Geometry/ClosestPair/DivideAndConquer.hs b/src/Algorithms/Geometry/ClosestPair/DivideAndConquer.hs --- a/src/Algorithms/Geometry/ClosestPair/DivideAndConquer.hs +++ b/src/Algorithms/Geometry/ClosestPair/DivideAndConquer.hs @@ -36,7 +36,7 @@ -- | Classical divide and conquer algorithm to compute the closest pair among -- \(n\) points. -- --- running time: \(O(n)\) +-- running time: \(O(n \log n)\) closestPair :: (Ord r, Num r) => LSeq 2 (Point 2 r :+ p) -> Two (Point 2 r :+ p) closestPair = f . divideAndConquer1 mkCCP . toNonEmpty . LSeq.unstableSortBy (comparing (^.core)) @@ -100,8 +100,8 @@ -> CP (Point 2 r :+ p) r run cp'' r ls = runWhile cp'' ls - (\cp l -> (ValT $ sqVertDist r l) < getDist cp) -- r and l inverted - -- by design + (\cp l -> ValT (sqVertDist r l) < getDist cp) -- r and l inverted + -- by design (\cp l -> minBy getDist cp (ValT $ SP (Two l r) (dist l r))) where dist (p :+ _) (q :+ _) = squaredEuclideanDist p q diff --git a/src/Algorithms/Geometry/ConvexHull.hs b/src/Algorithms/Geometry/ConvexHull.hs new file mode 100644 --- /dev/null +++ b/src/Algorithms/Geometry/ConvexHull.hs @@ -0,0 +1,10 @@ +-------------------------------------------------------------------------------- +-- | +-- Module : Algorithms.Geometry.ConvexHull +-- Copyright : (C) Frank Staals +-- License : see the LICENSE file +-- Maintainer : Frank Staals +-------------------------------------------------------------------------------- +module Algorithms.Geometry.ConvexHull( convexHull ) where + +import Algorithms.Geometry.ConvexHull.GrahamScan diff --git a/src/Algorithms/Geometry/ConvexHull/DivideAndConquer.hs b/src/Algorithms/Geometry/ConvexHull/DivideAndConquer.hs --- a/src/Algorithms/Geometry/ConvexHull/DivideAndConquer.hs +++ b/src/Algorithms/Geometry/ConvexHull/DivideAndConquer.hs @@ -28,10 +28,10 @@ -- | \(O(n \log n)\) time ConvexHull using divide and conquer. The resulting polygon is -- given in clockwise order. convexHull :: (Ord r, Num r) => NonEmpty (Point 2 r :+ p) -> ConvexPolygon p r -convexHull (p :| []) = ConvexPolygon . fromPoints $ [p] +convexHull (p :| []) = ConvexPolygon . unsafeFromPoints $ [p] convexHull pts = combine . (upperHull' &&& lowerHull') . NonEmpty.sortBy incXdecY $ pts where - combine (l:|uh,_:|lh) = ConvexPolygon . fromPoints $ l : uh <> reverse (init lh) + combine (l:|uh,_:|lh) = ConvexPolygon . unsafeFromPoints $ l : uh <> reverse (init lh) ---------------------------------------- -- * Computing a lower hull @@ -72,10 +72,10 @@ hull :: (NonEmpty p -> NonEmpty p -> Two (p :+ [p])) -> NonEmpty p -> NonEmpty p -> NonEmpty p hull tangent lh rh = let Two (l :+ lh') (r :+ rh') = tangent (NonEmpty.reverse lh) rh - in NonEmpty.fromList $ (reverse lh') <> [l,r] <> rh' + in NonEmpty.fromList $ reverse lh' <> [l,r] <> rh' -------------------------------------------------------------------------------- -incXdecY :: Ord r => (Point 2 r) :+ p -> (Point 2 r) :+ q -> Ordering +incXdecY :: Ord r => Point 2 r :+ p -> Point 2 r :+ q -> Ordering incXdecY (Point2 px py :+ _) (Point2 qx qy :+ _) = compare px qx <> compare qy py diff --git a/src/Algorithms/Geometry/ConvexHull/GrahamScan.hs b/src/Algorithms/Geometry/ConvexHull/GrahamScan.hs --- a/src/Algorithms/Geometry/ConvexHull/GrahamScan.hs +++ b/src/Algorithms/Geometry/ConvexHull/GrahamScan.hs @@ -1,3 +1,10 @@ +-------------------------------------------------------------------------------- +-- | +-- Module : Algorithms.Geometry.ConvexHull.GrahamScan +-- Copyright : (C) Frank Staals +-- License : see the LICENSE file +-- Maintainer : Frank Staals +-------------------------------------------------------------------------------- module Algorithms.Geometry.ConvexHull.GrahamScan( convexHull , upperHull, upperHull' , lowerHull, lowerHull' @@ -18,11 +25,11 @@ -- given in clockwise order. convexHull :: (Ord r, Num r) => NonEmpty (Point 2 r :+ p) -> ConvexPolygon p r -convexHull (p :| []) = ConvexPolygon . fromPoints $ [p] +convexHull (p :| []) = ConvexPolygon . unsafeFromPoints $ [p] convexHull ps = let ps' = NonEmpty.toList . NonEmpty.sortBy incXdecY $ ps uh = NonEmpty.tail . hull' $ ps' lh = NonEmpty.tail . hull' $ reverse ps' - in ConvexPolygon . fromPoints . reverse $ lh ++ uh + in ConvexPolygon . unsafeFromPoints . reverse $ lh ++ uh -- | Computes the upper hull. The upper hull is given from left to right. -- @@ -83,7 +90,7 @@ hull f pts = hull' . f . NonEmpty.toList . NonEmpty.sortBy incXdecY $ pts -incXdecY :: Ord r => (Point 2 r) :+ p -> (Point 2 r) :+ q -> Ordering +incXdecY :: Ord r => Point 2 r :+ p -> Point 2 r :+ q -> Ordering incXdecY (Point2 px py :+ _) (Point2 qx qy :+ _) = compare px qx <> compare qy py @@ -126,6 +133,9 @@ | rightTurn (x^.core) (y^.core) (z^.core) = h | otherwise = cleanMiddle (z:x:rest) cleanMiddle _ = error "cleanMiddle: too few points" +hull' _ = error + "Algorithms.Geometry.ConvexHull.GrahamScan.hull' requires a list with at least \ + \two elements." rightTurn :: (Ord r, Num r) => Point 2 r -> Point 2 r -> Point 2 r -> Bool rightTurn a b c = ccw a b c == CW diff --git a/src/Algorithms/Geometry/ConvexHull/JarvisMarch.hs b/src/Algorithms/Geometry/ConvexHull/JarvisMarch.hs --- a/src/Algorithms/Geometry/ConvexHull/JarvisMarch.hs +++ b/src/Algorithms/Geometry/ConvexHull/JarvisMarch.hs @@ -1,3 +1,10 @@ +-------------------------------------------------------------------------------- +-- | +-- Module : Algorithms.Geometry.ConvexHull.JarvisMarch +-- Copyright : (C) Frank Staals +-- License : see the LICENSE file +-- Maintainer : Frank Staals +-------------------------------------------------------------------------------- module Algorithms.Geometry.ConvexHull.JarvisMarch( convexHull @@ -8,7 +15,6 @@ import Control.Lens ((^.)) import Data.Bifunctor -import Data.Either (either) import Data.Ext import Data.Foldable import Data.Geometry.Point @@ -30,8 +36,8 @@ -- and \(h\) is the complexity of the hull. convexHull :: (Ord r, Num r) => NonEmpty (Point 2 r :+ p) -> ConvexPolygon p r -convexHull (p :| []) = ConvexPolygon . fromPoints $ [p] -convexHull pts = ConvexPolygon . fromPoints $ uh <> reverse lh +convexHull (p :| []) = ConvexPolygon . unsafeFromPoints $ [p] +convexHull pts = ConvexPolygon . unsafeFromPoints $ uh <> reverse lh where lh = case NonEmpty.nonEmpty (NonEmpty.init $ lowerHull pts) of Nothing -> [] @@ -93,13 +99,13 @@ -- with minimum slope w.r.t. the given point. steepestCcwFrom :: (Ord r, Num r) => (Point 2 r :+ a) -> NonEmpty (Point 2 r :+ b) -> Point 2 r :+ b -steepestCcwFrom p = List.minimumBy (ccwCmpAroundWith (Vector2 0 (-1)) p) +steepestCcwFrom p = List.minimumBy (ccwCmpAroundWith' (Vector2 0 (-1)) p) -- | Find the next point in clockwise order, i.e. the point -- with maximum slope w.r.t. the given point. steepestCwFrom :: (Ord r, Num r) => (Point 2 r :+ a) -> NonEmpty (Point 2 r :+ b) -> Point 2 r :+ b -steepestCwFrom p = List.minimumBy (cwCmpAroundWith (Vector2 0 1) p) +steepestCwFrom p = List.minimumBy (cwCmpAroundWith' (Vector2 0 1) p) repeatedly :: (a -> a -> Ordering) -> (a -> NonEmpty a -> a) -> a -> [a] -> NonEmpty a repeatedly cmp f = go @@ -126,7 +132,7 @@ where go (x :| xs) = case NonEmpty.nonEmpty xs of Nothing -> b x - Just xs' -> x `f` (go xs') + Just xs' -> x `f` go xs' -- | extracts all minima from the list. The result consists of the -- list of minima, and all remaining points. Both lists are returned diff --git a/src/Algorithms/Geometry/ConvexHull/Naive.hs b/src/Algorithms/Geometry/ConvexHull/Naive.hs --- a/src/Algorithms/Geometry/ConvexHull/Naive.hs +++ b/src/Algorithms/Geometry/ConvexHull/Naive.hs @@ -1,3 +1,10 @@ +-------------------------------------------------------------------------------- +-- | +-- Module : Algorithms.Geometry.ConvexHull.Naive +-- Copyright : (C) Frank Staals +-- License : see the LICENSE file +-- Maintainer : Frank Staals +-------------------------------------------------------------------------------- module Algorithms.Geometry.ConvexHull.Naive( ConvexHull , lowerHull', lowerHullAll @@ -14,10 +21,9 @@ import Data.Geometry.Triangle import Data.Geometry.Vector import Data.Intersection(intersects) -import qualified Data.List as List import Data.List.NonEmpty (NonEmpty(..)) -import qualified Data.List.NonEmpty as NonEmpty -import Data.Maybe (listToMaybe, isNothing) +import Data.List (find) +import Data.Maybe (isNothing) import Data.Util -------------------------------------------------------------------------------- @@ -50,15 +56,14 @@ -killOverlapping :: (Ord r, Fractional r) => [Triangle 3 p r] -> [Triangle 3 p r] -killOverlapping = foldr keepIfNotOverlaps [] +_killOverlapping :: (Ord r, Fractional r) => [Triangle 3 p r] -> [Triangle 3 p r] +_killOverlapping = foldr keepIfNotOverlaps [] where keepIfNotOverlaps t ts | any (t `overlaps`) ts = ts | otherwise = t:ts - -t1@(Triangle p q r) `overlaps` t2@(Triangle a b c) = upperHalfSpaceOf t1 == upperHalfSpaceOf t2 - && False +overlaps :: (Fractional r, Ord r) => Triangle 3 p1 r -> Triangle 3 p2 r -> Bool +t1 `overlaps` t2 = upperHalfSpaceOf t1 == upperHalfSpaceOf t2 && False @@ -72,10 +77,10 @@ -- Nothing -- >>> let t = (Triangle (ext origin) (ext $ Point3 1 0 0) (ext $ Point3 0 1 0)) -- >>> isValidTriangle t [ext $ Point3 5 5 (-10)] --- Just (Point3 [5,5,-10] :+ ()) +-- Just (Point3 5 5 (-10) :+ ()) isValidTriangle :: (Num r, Ord r) => Triangle 3 p r -> [Point 3 r :+ q] -> Maybe (Point 3 r :+ q) -isValidTriangle t = listToMaybe . filter (\a -> not $ (a^.core) `intersects` h) +isValidTriangle t = find (\a -> not $ (a^.core) `intersects` h) where h = upperHalfSpaceOf t @@ -83,7 +88,7 @@ -- | Computes the halfspace above the triangle. -- -- >>> upperHalfSpaceOf (Triangle (ext $ origin) (ext $ Point3 10 0 0) (ext $ Point3 0 10 0)) --- HalfSpace {_boundingPlane = HyperPlane {_inPlane = Point3 [0,0,0], _normalVec = Vector3 [0,0,100]}} +-- HalfSpace {_boundingPlane = HyperPlane {_inPlane = Point3 0 0 0, _normalVec = Vector3 0 0 100}} upperHalfSpaceOf :: (Ord r, Num r) => Triangle 3 p r -> HalfSpace 3 r upperHalfSpaceOf (Triangle p q r) = HalfSpace h where diff --git a/src/Algorithms/Geometry/ConvexHull/QuickHull.hs b/src/Algorithms/Geometry/ConvexHull/QuickHull.hs --- a/src/Algorithms/Geometry/ConvexHull/QuickHull.hs +++ b/src/Algorithms/Geometry/ConvexHull/QuickHull.hs @@ -1,6 +1,13 @@ +-------------------------------------------------------------------------------- +-- | +-- Module : Algorithms.Geometry.ConvexHull.QuickHull +-- Copyright : (C) Frank Staals +-- License : see the LICENSE file +-- Maintainer : Frank Staals +-------------------------------------------------------------------------------- module Algorithms.Geometry.ConvexHull.QuickHull( convexHull ) where -import Control.Lens ((^.),(&),(.~)) +import Control.Lens ((^.)) import Data.Ext import qualified Data.Foldable as F import Data.Geometry.Line @@ -26,9 +33,9 @@ -- running time: \(O(n^2)\) convexHull :: (Ord r, Fractional r, Show r, Show p) => NonEmpty (Point 2 r :+ p) -> ConvexPolygon p r -convexHull (p :| []) = ConvexPolygon . fromPoints $ [p] -convexHull ps = ConvexPolygon . fromPoints - $ [l] <> hull l r above <> [r] <> (reverse $ hull l r below) +convexHull (p :| []) = ConvexPolygon . unsafeFromPoints $ [p] +convexHull ps = ConvexPolygon . unsafeFromPoints + $ [l] <> hull l r above <> [r] <> reverse (hull l r below) where STR l r mids = findExtremes ps m = lineThrough (l^.core) (r^.core) @@ -59,7 +66,7 @@ -- in STR l r [p | p <- F.toList pts, p /=. l, p /=. r] -incXdecY :: Ord r => (Point 2 r) :+ p -> (Point 2 r) :+ q -> Ordering +incXdecY :: Ord r => Point 2 r :+ p -> Point 2 r :+ q -> Ordering incXdecY (Point2 px py :+ _) (Point2 qx qy :+ _) = compare px qx <> compare qy py diff --git a/src/Algorithms/Geometry/DelaunayTriangulation/DivideAndConquer.hs b/src/Algorithms/Geometry/DelaunayTriangulation/DivideAndConquer.hs --- a/src/Algorithms/Geometry/DelaunayTriangulation/DivideAndConquer.hs +++ b/src/Algorithms/Geometry/DelaunayTriangulation/DivideAndConquer.hs @@ -1,30 +1,40 @@ {-# LANGUAGE ScopedTypeVariables #-} -module Algorithms.Geometry.DelaunayTriangulation.DivideAndConquer where +-------------------------------------------------------------------------------- +-- | +-- Module : Algorithms.Geometry.DelaunayTriangulation.DivideAndConquer +-- Copyright : (C) Frank Staals +-- License : see the LICENSE file +-- Maintainer : Frank Staals +-------------------------------------------------------------------------------- +module Algorithms.Geometry.DelaunayTriangulation.DivideAndConquer + ( + -- * Divide & Conqueror Delaunay Triangulation + delaunayTriangulation + ) where -import Algorithms.Geometry.ConvexHull.GrahamScan as GS +import Algorithms.Geometry.ConvexHull.GrahamScan as GS import Algorithms.Geometry.DelaunayTriangulation.Types import Control.Lens import Control.Monad.Reader import Control.Monad.State import Data.BinaryTree -import qualified Data.CircularList as CL -import qualified Data.CircularList.Util as CU -import qualified Data.CircularSeq as CS +import qualified Data.CircularList as CL +import qualified Data.CircularList.Util as CU import Data.Ext -import qualified Data.Foldable as F -import Data.Function (on) -import Data.Geometry hiding (rotateTo) -import Data.Geometry.Ball (disk, insideBall) -import Data.Geometry.Polygon -import Data.Geometry.Polygon.Convex (ConvexPolygon(..), simplePolygon) -import qualified Data.Geometry.Polygon.Convex as Convex -import qualified Data.IntMap.Strict as IM -import qualified Data.List as L -import qualified Data.List.NonEmpty as NonEmpty -import qualified Data.Map as M -import Data.Maybe (fromJust, fromMaybe) +import qualified Data.Foldable as F +import Data.Function (on) +import Data.Geometry hiding (rotateTo) +import Data.Geometry.Ball (disk, insideBall) +import Data.Geometry.Polygon.Convex (ConvexPolygon (..), simplePolygon) +import qualified Data.Geometry.Polygon.Convex as Convex +import qualified Data.IntMap.Strict as IM +import qualified Data.List as L +import qualified Data.List.NonEmpty as NonEmpty +import qualified Data.Map as M +import Data.Maybe (fromJust, fromMaybe) import Data.Measured.Size -import qualified Data.Vector as V +import qualified Data.Vector as V +import qualified Data.Vector.Circular.Util as CV ------------------------------------------------------------------------------- -- * Divide & Conqueror Delaunay Triangulation @@ -42,7 +52,6 @@ -- -- Rotating Right <-> rotate clockwise - -- | Computes the delaunay triangulation of a set of points. -- -- Running time: \(O(n \log n)\) @@ -73,7 +82,7 @@ delaunayTriangulation' pts mapping'@(vtxMap,_) | size' pts == 1 = let (Leaf p) = pts i = lookup' vtxMap (p^.core) - in (IM.singleton i CL.empty, ConvexPolygon $ fromPoints [withID p i]) + in (IM.singleton i CL.empty, ConvexPolygon $ unsafeFromPoints [withID p i]) | size' pts <= 3 = let pts' = NonEmpty.fromList . map (\p -> withID p (lookup' vtxMap (p^.core))) . F.toList $ pts @@ -99,8 +108,8 @@ -- pre: at least two elements fromHull :: Ord r => Mapping p r -> ConvexPolygon (p :+ q) r -> Adj fromHull (vtxMap,_) p = let vs@(u:v:vs') = map (lookup' vtxMap . (^.core)) - . F.toList . CS.rightElements - $ p^.simplePolygon.outerBoundary + . F.toList . CV.rightElements + $ p^.simplePolygon.outerBoundaryVector es = zipWith3 f vs (tail vs ++ [u]) (vs' ++ [u,v]) f prv c nxt = (c,CL.fromList . L.nub $ [prv, nxt]) in IM.fromList es @@ -138,8 +147,8 @@ | otherwise = do insert l r -- Get the neighbours of r and l along the convex hull - r1 <- pred' . rotateTo l . lookup'' r <$> get - l1 <- succ' . rotateTo r . lookup'' l <$> get + r1 <- gets (pred' . rotateTo l . lookup'' r) + l1 <- gets (succ' . rotateTo r . lookup'' l) (r1',a) <- rotateR l r r1 (l1',b) <- rotateL l r l1 @@ -152,7 +161,7 @@ moveUp ut l' r' --- | ''rotates'' around r and removes all neighbours of r that violate the +-- | \'rotates\' around r and removes all neighbours of r that violate the -- delaunay condition. Returns the first vertex (as a Neighbour of r) that -- should remain in the Delaunay Triangulation, as well as a boolean A that -- helps deciding if we merge up by rotating left or rotating right (See @@ -199,12 +208,12 @@ -- by the first three points. qTest :: (Ord r, Fractional r) => VertexID -> VertexID -> Vertex -> Vertex -> Merge p r Bool -qTest h i j k = withPtMap . snd . fst <$> ask +qTest h i j k = asks (withPtMap . snd . fst) where withPtMap ptMap = let h' = ptMap V.! h i' = ptMap V.! i - j' = ptMap V.! (focus' j) - k' = ptMap V.! (focus' k) + j' = ptMap V.! focus' j + k' = ptMap V.! focus' k in not . maybe True ((k'^.core) `insideBall`) $ disk' h' i' j' disk' p q r = disk (p^.core) (q^.core) (r^.core) @@ -233,8 +242,8 @@ . IM.adjustWithKey (insert'' u) v where -- inserts b into the adjacency list of a - insert'' bi ai = CU.insertOrdBy (cwCmpAround' (ptMap V.! ai) `on` (ptMap V.!)) bi - cwCmpAround' c p q = cwCmpAround c p q <> cmpByDistanceTo c p q + insert'' bi ai = CU.insertOrdBy (cmp (ptMap V.! ai) `on` (ptMap V.!)) bi + cmp c p q = cwCmpAround' c p q <> cmpByDistanceTo' c p q -- | Deletes an edge @@ -247,7 +256,7 @@ -- | Lifted version of Convex.IsLeftOf isLeftOf :: (Ord r, Num r) => VertexID -> (VertexID, VertexID) -> Merge p r Bool -p `isLeftOf` (l,r) = withPtMap . snd . fst <$> ask +p `isLeftOf` (l,r) = asks (withPtMap . snd . fst) where withPtMap ptMap = (ptMap V.! p) `isLeftOf'` (ptMap V.! l, ptMap V.! r) a `isLeftOf'` (b,c) = ccw' b c a == CCW @@ -255,7 +264,7 @@ -- | Lifted version of Convex.IsRightOf isRightOf :: (Ord r, Num r) => VertexID -> (VertexID, VertexID) -> Merge p r Bool -p `isRightOf` (l,r) = withPtMap . snd . fst <$> ask +p `isRightOf` (l,r) = asks (withPtMap . snd . fst) where withPtMap ptMap = (ptMap V.! p) `isRightOf'` (ptMap V.! l, ptMap V.! r) a `isRightOf'` (b,c) = ccw' b c a == CW @@ -271,7 +280,7 @@ size' (Leaf _) = 1 size' (Node _ s _) = s --- | an 'unsafe' version of rotateTo that assumes the element to rotate to +-- | an \'unsafe\' version of rotateTo that assumes the element to rotate to -- occurs in the list. rotateTo :: Eq a => a -> CL.CList a -> CL.CList a rotateTo x = fromJust . CL.rotateTo x @@ -284,6 +293,7 @@ succ' :: CL.CList a -> CL.CList a succ' = CL.rotL +-- | Return the focus of the CList, throwing an exception if the list is empty. focus' :: CL.CList a -> a focus' = fromJust . CL.focus @@ -296,4 +306,4 @@ withID p i = p&extra %~ (:+i) lookup'' :: Int -> IM.IntMap a -> a -lookup'' k m = fromJust . IM.lookup k $ m +lookup'' k m = m IM.! k diff --git a/src/Algorithms/Geometry/DelaunayTriangulation/Naive.hs b/src/Algorithms/Geometry/DelaunayTriangulation/Naive.hs --- a/src/Algorithms/Geometry/DelaunayTriangulation/Naive.hs +++ b/src/Algorithms/Geometry/DelaunayTriangulation/Naive.hs @@ -1,3 +1,10 @@ +-------------------------------------------------------------------------------- +-- | +-- Module : Algorithms.Geometry.DelaunayTriangulation.Naive +-- Copyright : (C) Frank Staals +-- License : see the LICENSE file +-- Maintainer : Frank Staals +-------------------------------------------------------------------------------- module Algorithms.Geometry.DelaunayTriangulation.Naive where import Algorithms.Geometry.DelaunayTriangulation.Types @@ -17,7 +24,7 @@ -------------------------------------------------------------------------------- --- | Naive O(n^4) time implementation of the delaunay triangulation. Simply +-- | Naive \( O(n^4) \) time implementation of the delaunay triangulation. Simply -- tries each triple (p,q,r) and tests if it is delaunay, i.e. if there are no -- other points in the circle defined by p, q, and r. -- @@ -52,14 +59,14 @@ addAt v i j = updateAt v i (j:) -- convert to a CList, sorted in CCW order around point u - toCList u = C.fromList . sortAround' m u + toCList u = C.fromList . sortAroundMapping m u -- | Given a particular point u and a list of points vs, sort the points vs in -- CW order around u. --- running time: O(m log m), where m=|vs| is the number of vertices to sort. -sortAround' :: (Num r, Ord r) +-- running time: \( O(m log m) \), where m=|vs| is the number of vertices to sort. +sortAroundMapping :: (Num r, Ord r) => Mapping p r -> VertexID -> [VertexID] -> [VertexID] -sortAround' (_,ptsV) u vs = reverse . map (^.extra) $ sortAround (f u) (map f vs) +sortAroundMapping (_,ptsV) u vs = reverse . map (^.extra) $ sortAround' (f u) (map f vs) where f v = (ptsV V.! v)&extra .~ v @@ -71,8 +78,7 @@ -- we sort, group, and take the head of the lists --- | Test if the given three points form a triangle in the delaunay triangulation. --- running time: O(n) +-- | \( O(n) \) Test if the given three points form a triangle in the delaunay triangulation. isDelaunay :: (Fractional r, Ord r) => Mapping p r -> VertexID -> VertexID -> VertexID -> Bool isDelaunay (_,ptsV) p q r = case disk (pt p) (pt q) (pt r) of diff --git a/src/Algorithms/Geometry/DelaunayTriangulation/Types.hs b/src/Algorithms/Geometry/DelaunayTriangulation/Types.hs --- a/src/Algorithms/Geometry/DelaunayTriangulation/Types.hs +++ b/src/Algorithms/Geometry/DelaunayTriangulation/Types.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE ScopedTypeVariables #-} -------------------------------------------------------------------------------- -- | @@ -10,7 +9,20 @@ -- Defines some geometric types used in the delaunay triangulation -- -------------------------------------------------------------------------------- -module Algorithms.Geometry.DelaunayTriangulation.Types where +module Algorithms.Geometry.DelaunayTriangulation.Types + ( VertexID + , Vertex + , Adj + , Triangulation(..) + , vertexIds + , positions + , neighbours + , Mapping + , edgesAsPoints + , edgesAsVertices + , toPlanarSubdivision + , toPlaneGraph + ) where import Control.Lens import qualified Data.CircularList as C @@ -19,7 +31,7 @@ import Data.Geometry.PlanarSubdivision import qualified Data.IntMap.Strict as IM import qualified Data.Map as M -import qualified Data.Map.Strict as SM +-- import qualified Data.Map.Strict as SM import qualified Data.PlaneGraph as PG import qualified Data.PlanarGraph as PPG import qualified Data.Vector as V @@ -32,12 +44,13 @@ -- : If v on the convex hull, then its first entry in the adj. lists is its CCW -- successor (i.e. its predecessor) on the convex hull --- | Rotating Right <-> rotate clockwise - +-- | Vertex identifier. type VertexID = Int +-- | Rotating Right <-> rotate clockwise type Vertex = C.CList VertexID +-- | Neighbours indexed by VertexID. type Adj = IM.IntMap (C.CList VertexID) -- | Neighbours are stored in clockwise order: i.e. rotating right moves to the @@ -47,35 +60,48 @@ , _neighbours :: V.Vector (C.CList VertexID) } deriving (Show,Eq) -makeLenses ''Triangulation -type instance NumType (Triangulation p r) = r -type instance Dimension (Triangulation p r) = 2 +-- | Mapping between triangulated points and their internal VertexID. +vertexIds :: Lens' (Triangulation p r) (M.Map (Point 2 r) VertexID) +vertexIds = lens _vertexIds (\(Triangulation _v p n) v -> Triangulation v p n) +-- | Point positions indexed by VertexID. +positions :: Lens (Triangulation p1 r) (Triangulation p2 r) (V.Vector (Point 2 r :+ p1)) (V.Vector (Point 2 r :+ p2)) +positions = lens _positions (\(Triangulation v _p n) p -> Triangulation v p n) -type Mapping p r = (M.Map (Point 2 r) VertexID, V.Vector (Point 2 r :+ p)) +-- | Point neighbours indexed by VertexID. +neighbours :: Lens' (Triangulation p r) (V.Vector (C.CList VertexID)) +neighbours = lens _neighbours (\(Triangulation v p _n) n -> Triangulation v p n) +type instance NumType (Triangulation p r) = r +type instance Dimension (Triangulation p r) = 2 +-- | Bidirectional mapping between points and VertexIDs. +type Mapping p r = (M.Map (Point 2 r) VertexID, V.Vector (Point 2 r :+ p)) -showDT :: (Show p, Show r) => Triangulation p r -> IO () -showDT = mapM_ print . triangulationEdges -triangulationEdges :: Triangulation p r -> [(Point 2 r :+ p, Point 2 r :+ p)] -triangulationEdges t = let pts = _positions t - in map (\(u,v) -> (pts V.! u, pts V.! v)) . tEdges $ t +-- showDT :: (Show p, Show r) => Triangulation p r -> IO () +-- showDT = mapM_ print . edgesAsPoints -tEdges :: Triangulation p r -> [(VertexID,VertexID)] -tEdges = concatMap (\(i,ns) -> map (i,) . filter (> i) . C.toList $ ns) +{- HLINT ignore edgesAsPoints -} +-- | List add edges as point pairs. +edgesAsPoints :: Triangulation p r -> [(Point 2 r :+ p, Point 2 r :+ p)] +edgesAsPoints t = let pts = _positions t + in map (\(u,v) -> (pts V.! u, pts V.! v)) . edgesAsVertices $ t + +-- | List add edges as VertexID pairs. +edgesAsVertices :: Triangulation p r -> [(VertexID,VertexID)] +edgesAsVertices = concatMap (\(i,ns) -> map (i,) . filter (> i) . C.toList $ ns) . zip [0..] . V.toList . _neighbours -------------------------------------------------------------------------------- -data ST a b c = ST { fst' :: !a, snd' :: !b , trd' :: !c} +-- data ST a b c = ST { fst' :: !a, snd' :: !b , trd' :: !c} -type ArcID = Int +-- type ArcID = Int -- | ST' is a strict triple (m,a,x) containing: -- @@ -83,7 +109,7 @@ -- u < v, to arcId's. -- - a: the next available unused arcID -- - x: the data value we are interested in computing -type ST' a = ST (SM.Map (VertexID,VertexID) ArcID) ArcID a +-- type ST' a = ST (SM.Map (VertexID,VertexID) ArcID) ArcID a -- | convert the triangulation into a planarsubdivision diff --git a/src/Algorithms/Geometry/Diameter.hs b/src/Algorithms/Geometry/Diameter.hs new file mode 100644 --- /dev/null +++ b/src/Algorithms/Geometry/Diameter.hs @@ -0,0 +1,13 @@ +-------------------------------------------------------------------------------- +-- | +-- Module : Algorithms.Geometry.Diameter +-- Copyright : (C) David Himmelstrup +-- License : see the LICENSE file +-- Maintainer : Frank Staals, David Himmelstrup +-------------------------------------------------------------------------------- +module Algorithms.Geometry.Diameter + ( diameter + , diametralPair + ) where + +import Algorithms.Geometry.Diameter.ConvexHull diff --git a/src/Algorithms/Geometry/Diameter/ConvexHull.hs b/src/Algorithms/Geometry/Diameter/ConvexHull.hs new file mode 100644 --- /dev/null +++ b/src/Algorithms/Geometry/Diameter/ConvexHull.hs @@ -0,0 +1,35 @@ +-------------------------------------------------------------------------------- +-- | +-- Module : Algorithms.Geometry.Diameter.ConvexHull +-- Copyright : (C) David Himmelstrup +-- License : see the LICENSE file +-- Maintainer : Frank Staals, David Himmelstrup +-------------------------------------------------------------------------------- +module Algorithms.Geometry.Diameter.ConvexHull + ( diameter + , diametralPair + ) where + +import Algorithms.Geometry.ConvexHull.GrahamScan (convexHull) +import qualified Algorithms.Geometry.Diameter.Naive as Naive +import Control.Lens ((^.)) +import Data.Ext (core, type (:+)) +import Data.Geometry (Point, euclideanDist) +import qualified Data.Geometry.Polygon.Convex as Convex +import qualified Data.List.NonEmpty as NonEmpty + +-------------------------------------------------------------------------------- + +-- | Computes the Euclidean diameter by first finding the convex hull. +-- +-- running time: \(O(n \log n)\) +diameter :: (Ord r, Floating r) => [Point 2 r :+ p] -> r +diameter = maybe 0 (\(p,q) -> euclideanDist (p^.core) (q^.core)) . diametralPair + +-- | Computes the Euclidean diameter by first finding the convex hull. +-- +-- running time: \(O(n \log n)\) +diametralPair :: (Ord r, Num r) + => [Point 2 r :+ p] -> Maybe (Point 2 r :+ p, Point 2 r :+ p) +diametralPair lst@(_:_:_:_) = Just . Convex.diametralPair $ convexHull $ NonEmpty.fromList lst +diametralPair lst = Naive.diametralPair lst diff --git a/src/Algorithms/Geometry/Diameter/Naive.hs b/src/Algorithms/Geometry/Diameter/Naive.hs --- a/src/Algorithms/Geometry/Diameter/Naive.hs +++ b/src/Algorithms/Geometry/Diameter/Naive.hs @@ -1,3 +1,10 @@ +-------------------------------------------------------------------------------- +-- | +-- Module : Algorithms.Geometry.Diameter.Naive +-- Copyright : (C) Frank Staals +-- License : see the LICENSE file +-- Maintainer : Frank Staals +-------------------------------------------------------------------------------- module Algorithms.Geometry.Diameter.Naive where import Control.Lens @@ -7,6 +14,9 @@ -------------------------------------------------------------------------------- +-- | Computes the Euclidean diameter by naively trying all pairs. +-- +-- running time: \(O(n^2)\) diameter :: (Ord r, Floating r, Arity d) => [Point d r :+ p] -> r diameter = maybe 0 (\(p,q) -> euclideanDist (p^.core) (q^.core)) . diametralPair diff --git a/src/Algorithms/Geometry/EuclideanMST.hs b/src/Algorithms/Geometry/EuclideanMST.hs new file mode 100644 --- /dev/null +++ b/src/Algorithms/Geometry/EuclideanMST.hs @@ -0,0 +1,47 @@ +-------------------------------------------------------------------------------- +-- | +-- Module : Algorithms.Geometry.EuclideanMST +-- Copyright : (C) Frank Staals +-- License : see the LICENSE file +-- Maintainer : Frank Staals +-- +-- \(O(n\log n)\) time algorithm algorithm to compute the Euclidean minimum +-- spanning tree of a set of \(n\) points in \(\mathbb{R}^2\). +-- +-------------------------------------------------------------------------------- +module Algorithms.Geometry.EuclideanMST ( euclideanMST ) where + +import Algorithms.Geometry.DelaunayTriangulation.DivideAndConquer +import Algorithms.Geometry.DelaunayTriangulation.Types +import Algorithms.Graph.MST +import Control.Lens +import Data.Ext +import Data.Geometry +import qualified Data.List.NonEmpty as NonEmpty +import Data.PlaneGraph +import Data.Proxy +import Data.Tree + +-------------------------------------------------------------------------------- + +-- | Computes the Euclidean Minimum Spanning Tree. We compute the Delaunay +-- Triangulation (DT), and then extract the EMST. Hence, the same restrictions +-- apply as for the DT: +-- +-- pre: the input is a *SET*, i.e. contains no duplicate points. (If the input +-- does contain duplicate points, the implementation throws them away) +-- +-- running time: \(O(n \log n)\) +euclideanMST :: (Ord r, Fractional r) + => NonEmpty.NonEmpty (Point 2 r :+ p) -> Tree (Point 2 r :+ p) +euclideanMST pts = (\v -> g^.locationOf v :+ g^.dataOf v) <$> t + where + -- since we care only about the relative order of the edges we can use the + -- squared Euclidean distance rather than the Euclidean distance, thus + -- avoiding the Floating constraint + g = withEdgeDistances squaredEuclideanDist . toPlaneGraph (Proxy :: Proxy MSTW) + . delaunayTriangulation $ pts + t = mst $ g^.graph + + +data MSTW diff --git a/src/Algorithms/Geometry/EuclideanMST/EuclideanMST.hs b/src/Algorithms/Geometry/EuclideanMST/EuclideanMST.hs --- a/src/Algorithms/Geometry/EuclideanMST/EuclideanMST.hs +++ b/src/Algorithms/Geometry/EuclideanMST/EuclideanMST.hs @@ -9,39 +9,9 @@ -- spanning tree of a set of \(n\) points in \(\mathbb{R}^2\). -- -------------------------------------------------------------------------------- -module Algorithms.Geometry.EuclideanMST.EuclideanMST where - -import Algorithms.Geometry.DelaunayTriangulation.DivideAndConquer -import Algorithms.Geometry.DelaunayTriangulation.Types -import Algorithms.Graph.MST -import Control.Lens -import Data.Ext -import Data.Geometry -import qualified Data.List.NonEmpty as NonEmpty -import Data.PlaneGraph -import Data.Proxy -import Data.Tree - --------------------------------------------------------------------------------- - --- | Computes the Euclidean Minimum Spanning Tree. We compute the Delaunay --- Triangulation (DT), and then extract the EMST. Hence, the same restrictions --- apply as for the DT: --- --- pre: the input is a *SET*, i.e. contains no duplicate points. (If the input --- does contain duplicate points, the implementation throws them away) --- --- running time: \(O(n \log n)\) -euclideanMST :: (Ord r, Fractional r) - => NonEmpty.NonEmpty (Point 2 r :+ p) -> Tree (Point 2 r :+ p) -euclideanMST pts = (\v -> g^.locationOf v :+ g^.dataOf v) <$> t - where - -- since we care only about the relative order of the edges we can use the - -- squared Euclidean distance rather than the Euclidean distance, thus - -- avoiding the Floating constraint - g = withEdgeDistances squaredEuclideanDist . toPlaneGraph (Proxy :: Proxy MSTW) - . delaunayTriangulation $ pts - t = mst $ g^.graph - +module Algorithms.Geometry.EuclideanMST.EuclideanMST + {-# DEPRECATED "This module will be deleted after 2021-06-01. \ + \Use Algorithms.Geometry.EuclideanMST instead." #-} + ( module Algorithms.Geometry.EuclideanMST ) where -data MSTW +import Algorithms.Geometry.EuclideanMST diff --git a/src/Algorithms/Geometry/FrechetDistance/Discrete.hs b/src/Algorithms/Geometry/FrechetDistance/Discrete.hs --- a/src/Algorithms/Geometry/FrechetDistance/Discrete.hs +++ b/src/Algorithms/Geometry/FrechetDistance/Discrete.hs @@ -1,3 +1,10 @@ +-------------------------------------------------------------------------------- +-- | +-- Module : Algorithms.Geometry.FrechetDistance.Discrete +-- Copyright : (C) Frank Staals +-- License : see the LICENSE file +-- Maintainer : Frank Staals +-------------------------------------------------------------------------------- module Algorithms.Geometry.FrechetDistance.Discrete( discreteFrechetDistance , discreteFrechetDistanceWith ) where diff --git a/src/Algorithms/Geometry/InPolygon.hs b/src/Algorithms/Geometry/InPolygon.hs new file mode 100644 --- /dev/null +++ b/src/Algorithms/Geometry/InPolygon.hs @@ -0,0 +1,155 @@ +-------------------------------------------------------------------------------- +-- | +-- Module : Algorithms.Geometry.InPolygon +-- Copyright : (C) Frank Staals +-- License : see the LICENSE file +-- Maintainer : Frank Staals +-- +-- Testing if a point lies in a polygon +-- +-------------------------------------------------------------------------------- +module Algorithms.Geometry.InPolygon + ( inPolygon + , insidePolygon + , onBoundary + ) where + +import Control.Lens + +import Data.Ext +import qualified Data.Foldable as F +import Data.Geometry.Boundary +import Data.Geometry.Line +import Data.Geometry.LineSegment +import Data.Geometry.Point +import Data.Geometry.Polygon.Core +import Data.Geometry.Properties + +import qualified Data.List.Util as List +import Data.Maybe (mapMaybe) +import Data.Vinyl.CoRec (asA) +-------------------------------------------------------------------------------- + +{- $setup +>>> import Data.RealNumber.Rational +>>> import Data.Foldable +>>> import Control.Lens.Extras +>>> :{ +-- import qualified Data.Vector.Circular as CV +let simplePoly :: SimplePolygon () (RealNumber 10) + simplePoly = fromPoints . map ext $ + [ Point2 0 0 + , Point2 10 0 + , Point2 10 10 + , Point2 5 15 + , Point2 1 11 + ] + simpleTriangle :: SimplePolygon () (RealNumber 10) + simpleTriangle = fromPoints . map ext $ + [ Point2 0 0, Point2 2 0, Point2 1 1] + multiPoly :: MultiPolygon () (RealNumber 10) + multiPoly = MultiPolygon + (fromPoints . map ext $ [Point2 (-1) (-1), Point2 3 (-1), Point2 2 2]) + [simpleTriangle] +:} -} + + +-- | \( O(n) \) Test if q lies on the boundary of the polygon. +-- +-- >>> Point2 1 1 `onBoundary` simplePoly +-- False +-- >>> Point2 0 0 `onBoundary` simplePoly +-- True +-- >>> Point2 10 0 `onBoundary` simplePoly +-- True +-- >>> Point2 5 13 `onBoundary` simplePoly +-- False +-- >>> Point2 5 10 `onBoundary` simplePoly +-- False +-- >>> Point2 10 5 `onBoundary` simplePoly +-- True +-- >>> Point2 20 5 `onBoundary` simplePoly +-- False +-- +-- TODO: testcases multipolygon +onBoundary :: (Num r, Ord r) => Point 2 r -> Polygon t p r -> Bool +q `onBoundary` pg = any (q `intersects`) es + where + out = pg^.outerBoundary + es = concatMap (F.toList . outerBoundaryEdges) $ out : holeList pg + +-- | Check if a point lies inside a polygon, on the boundary, or outside of the polygon. +-- Running time: O(n). +-- +-- >>> Point2 1 1 `inPolygon` simplePoly +-- Inside +-- >>> Point2 0 0 `inPolygon` simplePoly +-- OnBoundary +-- >>> Point2 10 0 `inPolygon` simplePoly +-- OnBoundary +-- >>> Point2 5 13 `inPolygon` simplePoly +-- Inside +-- >>> Point2 5 10 `inPolygon` simplePoly +-- Inside +-- >>> Point2 10 5 `inPolygon` simplePoly +-- OnBoundary +-- >>> Point2 20 5 `inPolygon` simplePoly +-- Outside +-- +-- TODO: Add some testcases with multiPolygons +-- TODO: Add some more onBoundary testcases +inPolygon :: forall t p r. (Fractional r, Ord r) + => Point 2 r -> Polygon t p r -> PointLocationResult +q `inPolygon` pg + | q `onBoundary` pg = OnBoundary + | inHole = Outside + | otherwise = q `inPolygon'` (pg^.outerBoundary) + where + inHole = any (q `insidePolygon`) $ holeList pg + +-- | Returns true if the point lies in the polygon +-- pre: point lies inside or outside the polygon, not on its boundary. +inPolygon' :: forall p r. (Fractional r, Ord r) + => Point 2 r -> SimplePolygon p r + -> PointLocationResult +q `inPolygon'` pg = if odd . length . mapMaybe intersectionPoint $ ups <> downs + then Inside else Outside + where + -- we don't care about horizontal edges + (ups',_horizontals,downs') = partitionEdges . listEdges $ pg + partitionEdges = List.partition3 $ \s -> (s^.end.core.yCoord) `compare` (s^.start.core.yCoord) + + -- upward edges include start, exclude end + ups = map (\(LineSegment' a b) -> LineSegment (Closed a) (Open b)) ups' + -- downward edges exclude start, include end + downs = map (\(LineSegment' a b) -> LineSegment (Open a) (Closed b)) downs' + + -- Given an edge, compute the intersection point (if a point) with + -- the line through the query point, and test if it lies strictly + -- right of q. + -- + -- See http://geomalgorithms.com/a03-_inclusion.html for more information. + intersectionPoint = F.find (\p -> p^.xCoord > q^.xCoord) . asA @(Point 2 r) . (`intersect` l) + l = horizontalLine $ q^.yCoord + + +-- | Test if a point lies strictly inside the polgyon. +insidePolygon :: (Fractional r, Ord r) => Point 2 r -> Polygon t p r -> Bool +q `insidePolygon` pg = q `inPolygon` pg == Inside + + +-- testQ = map (`inPolygon` testPoly) [ Point2 1 1 -- Inside +-- , Point2 0 0 -- OnBoundary +-- , Point2 5 14 -- Inside +-- , Point2 5 10 -- Inside +-- , Point2 10 5 -- OnBoundary +-- , Point2 20 5 -- Outside +-- ] + +-- testPoly :: SimplePolygon () Rational +-- testPoly = fromPoints . map ext $ [ Point2 0 0 +-- , Point2 10 0 +-- , Point2 10 10 +-- , Point2 5 15 +-- , Point2 1 11 +-- ] diff --git a/src/Algorithms/Geometry/LineSegmentIntersection.hs b/src/Algorithms/Geometry/LineSegmentIntersection.hs --- a/src/Algorithms/Geometry/LineSegmentIntersection.hs +++ b/src/Algorithms/Geometry/LineSegmentIntersection.hs @@ -1,6 +1,23 @@ -module Algorithms.Geometry.LineSegmentIntersection where +-------------------------------------------------------------------------------- +-- | +-- Module : Algorithms.Geometry.LineSegmentIntersection +-- Copyright : (C) Frank Staals +-- License : see the LICENSE file +-- Maintainer : Frank Staals +-------------------------------------------------------------------------------- +module Algorithms.Geometry.LineSegmentIntersection + ( hasInteriorIntersections + , hasSelfIntersections + , Intersections + , Associated(..) + , IntersectionPoint(..) + , isEndPointIntersection + , associated + , Compare + ) where import qualified Algorithms.Geometry.LineSegmentIntersection.BentleyOttmann as BO +import Algorithms.Geometry.LineSegmentIntersection.Types import Data.Geometry.LineSegment import Data.Geometry.Polygon diff --git a/src/Algorithms/Geometry/LineSegmentIntersection/BentleyOttmann.hs b/src/Algorithms/Geometry/LineSegmentIntersection/BentleyOttmann.hs --- a/src/Algorithms/Geometry/LineSegmentIntersection/BentleyOttmann.hs +++ b/src/Algorithms/Geometry/LineSegmentIntersection/BentleyOttmann.hs @@ -10,7 +10,13 @@ -- and Ottmann. -- -------------------------------------------------------------------------------- -module Algorithms.Geometry.LineSegmentIntersection.BentleyOttmann where +module Algorithms.Geometry.LineSegmentIntersection.BentleyOttmann + ( intersections + , interiorIntersections + -- FIXME: Move ordAt and xCoordAt to Data.Geometry.LineSegment? + , ordAt + , xCoordAt + ) where import Algorithms.Geometry.LineSegmentIntersection.Types import Control.Lens hiding (contains) @@ -194,7 +200,7 @@ where (before, mid1, after') = SS.splitOn (xCoordAt $ p^.yCoord) (p^.xCoord) ss -- Make sure to also select the horizontal segments containing p - (mid2, after) = SS.spanAntitone (\s -> p `onSegment` s) after' + (mid2, after) = SS.spanAntitone (intersects p) after' -- | Given a point and the linesegements that contain it. Create a piece of @@ -230,9 +236,9 @@ => Point 2 r -> LineSegment 2 p r -> LineSegment 2 p r -> Maybe (Event p r) findNewEvent p l r = match (l `intersect` r) $ - (H $ \NoIntersection -> Nothing) - :& (H $ \q -> if ordPoints q p == GT then Just (Event q Intersection) - else Nothing) - :& (H $ \_ -> Nothing) -- full segment intersectsions are handled - -- at insertion time + H (const Nothing) -- NoIntersection + :& H (\q -> if ordPoints q p == GT then Just (Event q Intersection) + else Nothing) + :& H (const Nothing) -- full segment intersectsions are handled + -- at insertion time :& RNil diff --git a/src/Algorithms/Geometry/LineSegmentIntersection/BooleanSweep.hs b/src/Algorithms/Geometry/LineSegmentIntersection/BooleanSweep.hs new file mode 100644 --- /dev/null +++ b/src/Algorithms/Geometry/LineSegmentIntersection/BooleanSweep.hs @@ -0,0 +1,171 @@ +{-# LANGUAGE ScopedTypeVariables #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Algorithms.Geometry.LineSegmentIntersection.BooleanSweep +-- Copyright : (C) Frank Staals, David Himmelstrup +-- License : see the LICENSE file +-- Maintainer : David Himmelstrup +-- +-- \( O(n \log n) \) algorithm for determining if any two line segments overlap. +-- +-- Shamos and Hoey. +-- +-------------------------------------------------------------------------------- +module Algorithms.Geometry.LineSegmentIntersection.BooleanSweep + ( hasIntersections + , segmentsOverlap + ) where + +import Control.Lens hiding (contains) +import Data.Ext +import Data.Geometry.Interval +import Data.Geometry.Line +import Data.Geometry.LineSegment +import Data.Geometry.Point +import Data.Geometry.Triangle +import qualified Data.List as L +import Data.Maybe +import Data.Ord (Down (..), comparing) +import qualified Data.Set as SS +import qualified Data.Set.Util as SS + +-- import Data.RealNumber.Rational +-- import Debug.Trace + +-------------------------------------------------------------------------------- + +-- | Tests if there are any intersections. +-- +-- \(O(n\log n)\) +hasIntersections :: (Ord r, Num r) + => [LineSegment 2 p r] -> Bool +hasIntersections ss = sweep pts SS.empty + where + pts = L.sortBy ordEvents . concatMap asEventPts $ ss + +-- | Computes the event points for a given line segment +asEventPts :: Ord r => LineSegment 2 p r -> [Event p r] +asEventPts s = + case ordPoints (s^.start.core) (s^.end.core) of + LT -> [Insert s, Delete s] + _ -> let LineSegment a b = s + s' = LineSegment b a + in [Insert s', Delete s'] + +-------------------------------------------------------------------------------- +-- * Data type for Events + +-- | The actual event consists of a point and its type +data Event p r = Insert (LineSegment 2 p r) | Delete (LineSegment 2 p r) + +eventPoint :: Event p r -> Point 2 r +eventPoint (Insert l) = l^.start.core +eventPoint (Delete l) = l^.end.core + +-- Sort order: +-- 1. Y-coord. Larger Ys before smaller. +-- 2. X-coord. Smaller Xs before larger. +-- 3. Type: Inserts before deletions +ordEvents :: (Num r, Ord r) => Event p r -> Event p r -> Ordering +ordEvents e1 e2 = ordPoints (eventPoint e1) (eventPoint e2) <> cmpType e1 e2 + where + cmpType Insert{} Delete{} = LT + cmpType Delete{} Insert{} = GT + cmpType _ _ = EQ + +-- | An ordering that is decreasing on y, increasing on x +ordPoints :: Ord r => Point 2 r -> Point 2 r -> Ordering +ordPoints a b = let f p = (Down $ p^.yCoord, p^.xCoord) in comparing f a b + +-------------------------------------------------------------------------------- +-- * The Main Sweep + +type StatusStructure p r = SS.Set (LineSegment 2 p r) + +-- | Run the sweep handling all events +sweep :: forall r p. (Ord r, Num r) + => [Event p r] -> StatusStructure p r + -> Bool +sweep [] _ = False +sweep (Delete l:eq) ss = + overlaps || sweep eq ss' + where + p = l^.end.core + (before,_contains,after) = splitBeforeAfter p ss + overlaps = fromMaybe False (segmentsOverlap <$> sl <*> sr) + sl = SS.lookupMax before + sr = SS.lookupMin after + ss' = before `SS.join` after +sweep (Insert l@(LineSegment startPoint _endPoint):eq) ss = + endOverlap || overlaps || sweep eq ss' + where + p = l^.start.core + (before,contains,after) = splitBeforeAfter p ss + endOverlap = + (not (null contains) && isClosed startPoint) + overlaps = or [ fromMaybe False (segmentsOverlap l <$> sl) + , fromMaybe False (segmentsOverlap l <$> sr) ] + sl = SS.lookupMax before + sr = SS.lookupMin after + ss' = before `SS.join` SS.singleton l `SS.join` after + +-- | split the status structure around p. +-- the result is (before,contains,after) +splitBeforeAfter :: (Num r, Ord r) + => Point 2 r -> StatusStructure p r + -> (StatusStructure p r, [LineSegment 2 p r],StatusStructure p r) +splitBeforeAfter p ss = (before, filter (not . endsAt p) $ SS.toList contains, after) + where + (before,contains,after) = SS.splitBy cmpLine ss + cmpLine line + | isHorizontal line = + let [_top,bot] = L.sortBy ordPoints [line^.start.core,line^.end.core] in + (bot^.xCoord) `compare` (p^.xCoord) + cmpLine line = + let [top,bot] = L.sortBy ordPoints [line^.start.core,line^.end.core] in + case ccw bot top p of + CW -> LT + CoLinear -> EQ + CCW -> GT + + +isHorizontal :: Eq r => LineSegment 2 p r -> Bool +isHorizontal s = s^.start.core.yCoord == s^.end.core.yCoord + +-- | Test if a segment ends at p +endsAt :: Ord r => Point 2 r -> LineSegment 2 p r -> Bool +endsAt p (LineSegment _ b) = fmap (view core) b == Open p + +-------------------------------------------------------------------------------- +-- * Finding New events + +segmentsOverlap :: (Num r, Ord r) => LineSegment 2 p r -> LineSegment 2 p r -> Bool +segmentsOverlap a@(LineSegment aStart aEnd) b = + (isClosed aStart && (aStart^.unEndPoint.core) `onSegment2` b) || + (isClosed aEnd && (aEnd^.unEndPoint.core) `onSegment2` b) || + (opposite (ccw' (a^.start) (b^.start) (a^.end)) (ccw' (a^.start) (b^.end) (a^.end)) && + not (onTriangleRelaxed (a^.end.core) t1) && + not (onTriangleRelaxed (a^.start.core) t2)) + where + opposite CW CCW = True + opposite CCW CW = True + opposite _ _ = False + t1 = Triangle (a^.start) (b^.start) (b^.end) + t2 = Triangle (a^.end) (b^.start) (b^.end) + +-- Copied from Data.Geometry.LineSegment.Internal. Delete when PR#62 is merged. +onSegment2 :: (Ord r, Num r) + => Point 2 r -> LineSegment 2 p r -> Bool +p `onSegment2` s@(LineSegment u v) = case ccw' (ext p) (u^.unEndPoint) (v^.unEndPoint) of + CoLinear -> let su = p `onSide` lu + sv = p `onSide` lv + in su /= sv + && ((su == OnLine) `implies` isClosed u) + && ((sv == OnLine) `implies` isClosed v) + _ -> False + where + (Line _ w) = perpendicularTo $ supportingLine s + lu = Line (u^.unEndPoint.core) w + lv = Line (v^.unEndPoint.core) w + + a `implies` b = b || not a diff --git a/src/Algorithms/Geometry/LineSegmentIntersection/Naive.hs b/src/Algorithms/Geometry/LineSegmentIntersection/Naive.hs --- a/src/Algorithms/Geometry/LineSegmentIntersection/Naive.hs +++ b/src/Algorithms/Geometry/LineSegmentIntersection/Naive.hs @@ -1,5 +1,9 @@ {-# LANGUAGE ScopedTypeVariables #-} -module Algorithms.Geometry.LineSegmentIntersection.Naive where +-- | Line segment intersections in \(O(n^2)\) by checking +-- all pairs. +module Algorithms.Geometry.LineSegmentIntersection.Naive + ( intersections + ) where import Algorithms.Geometry.LineSegmentIntersection.Types import Control.Lens @@ -25,9 +29,9 @@ => (LineSegment 2 p r, LineSegment 2 p r) -> Intersections p r -> Intersections p r collect (s,s') m = match (s `intersect` s') $ - (H $ \NoIntersection -> m) - :& (H $ \p -> handlePoint s s' p $ m) - :& (H $ \s'' -> foldr (handlePoint s s') m [s''^.start.core, s''^.end.core]) + H (\NoIntersection -> m) + :& H (\p -> handlePoint s s' p m) + :& H (\s'' -> foldr (handlePoint s s') m [s''^.start.core, s''^.end.core]) :& RNil -- | Add s and s' to the map with key p diff --git a/src/Algorithms/Geometry/LineSegmentIntersection/Types.hs b/src/Algorithms/Geometry/LineSegmentIntersection/Types.hs --- a/src/Algorithms/Geometry/LineSegmentIntersection/Types.hs +++ b/src/Algorithms/Geometry/LineSegmentIntersection/Types.hs @@ -1,4 +1,11 @@ {-# LANGUAGE TemplateHaskell #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Algorithms.Geometry.LineSegmentIntersection.Types +-- Copyright : (C) Frank Staals +-- License : see the LICENSE file +-- Maintainer : Frank Staals +-------------------------------------------------------------------------------- module Algorithms.Geometry.LineSegmentIntersection.Types where import Control.DeepSeq diff --git a/src/Algorithms/Geometry/LinearProgramming/LP2DRIC.hs b/src/Algorithms/Geometry/LinearProgramming/LP2DRIC.hs --- a/src/Algorithms/Geometry/LinearProgramming/LP2DRIC.hs +++ b/src/Algorithms/Geometry/LinearProgramming/LP2DRIC.hs @@ -1,4 +1,5 @@ {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE PackageImports #-} -------------------------------------------------------------------------------- -- | -- Module : Algorithms.Geometry.LinearProgramming.LP2DRIC @@ -37,13 +38,13 @@ import Data.Util import Data.Vinyl import Data.Vinyl.CoRec -import System.Random.Shuffle +import "hgeometry-combinatorial" System.Random.Shuffle -------------------------------------------------------------------------------- -- | Solve a linear program -solveLinearProgram :: MonadRandom m => LinearProgram 2 r -> m (LPSolution 2 r) -solveLinearProgram = undefined +_solveLinearProgram :: MonadRandom m => LinearProgram 2 r -> m (LPSolution 2 r) +_solveLinearProgram = undefined -- | Solves a bounded linear program in 2d. Returns Nothing if there is no @@ -115,20 +116,20 @@ => Line 2 r -> [HalfSpace 2 r] -> Maybe [HalfLine 2 r] -collectOn l = sequence . mapMaybe collect . map (l `intersect`) +collectOn l = sequence . mapMaybe (collect . (l `intersect`)) where collect :: Intersection (Line 2 r) (HalfSpace 2 r) -> Maybe (Maybe (HalfLine 2 r)) collect r = match r $ - (H $ \NoIntersection -> Just Nothing) - :& (H $ \hl -> Just $ Just hl) - :& (H $ \_ -> Nothing) + H (const $ Just Nothing) -- NoIntersection + :& H (Just . Just) -- HalfLine + :& H (const Nothing) -- Line :& RNil -- | Given a vector v and two points a and b, determine which is smaller in direction v. cmpHalfPlane :: (Ord r, Num r, Arity d) => Vector d r -> Point d r -> Point d r -> Ordering -cmpHalfPlane v a b = case a `inHalfSpace` (HalfSpace $ HyperPlane b $ v) of +cmpHalfPlane v a b = case a `inHalfSpace` HalfSpace (HyperPlane b v) of Inside -> GT OnBoundary -> EQ Outside -> LT @@ -147,7 +148,7 @@ commonIntersection :: (Ord r, Num r, Arity d) => Line d r -> NonEmpty.NonEmpty (HalfLine d r :+ a) - -> Either (Two ((HalfLine d r :+ a))) + -> Either (Two (HalfLine d r :+ a)) (OneOrTwo (Point d r :+ a)) commonIntersection (Line _ v) hls = case (nh,ph) of (Nothing,Nothing) -> error "absurd; this case cannot occur" @@ -159,7 +160,7 @@ GT -> Right . Right $ Two (extract p) (extract n) where extract = over core (^.startPoint) - (pos,neg) = NonEmpty.partition (\hl -> hl^.core.halfLineDirection == v) $ hls + (pos,neg) = NonEmpty.partition (\hl -> hl^.core.halfLineDirection == v) hls ph = maximumBy' (cmpHalfPlane' v) pos nh = maximumBy' (flip $ cmpHalfPlane' v) neg @@ -219,7 +220,9 @@ where Just p = asA @(Point 2 r) $ (m1^.boundingPlane._asLine) `intersect` (m2^.boundingPlane._asLine) - +initialize _ = error + "Algorithms.Geometry.LinearProgramming.LP2DRIC.initialize requires \ + \at least two constraints." -------------------------------------------------------------------------------- @@ -234,13 +237,13 @@ -- - \(c \cdot d > 0\), and -- - \(d \cdot n(h) \geq 0\), wherefor every half space \(h\). -- -findD :: (Ord r, Fractional r) +_findD :: (Ord r, Fractional r) => LinearProgram 2 r -> Maybe (Vector 2 r) -findD (LinearProgram c hs) = do hls <- collectOn nl hs' - d <- toVec <$> oneDLinearProgramming v nl hls - -- the direction v here does not really matter - if c `dot` d > 0 then pure d - else Nothing +_findD (LinearProgram c hs) = do hls <- collectOn nl hs' + d <- toVec <$> oneDLinearProgramming v nl hls + -- the direction v here does not really matter + if c `dot` d > 0 then pure d + else Nothing where -- we interpret the points on nl as directions w.r.t the origin nl@(Line _ v) = perpendicularTo (Line (origin .+^ c) c) @@ -248,14 +251,14 @@ -- every halfspace creates an allowed set of directions, modelled by a -- half-line on nl - toHL h = let n = h^.boundingPlane.normalVec + toHL h = let _n = h^.boundingPlane.normalVec in undefined -- | Either finds an unbounded Haflline, or evidence the two halfspaces that provide -- evidence that no solution exists -findUnBoundedHalfLine :: LinearProgram 2 r -> Either (Two (HalfSpace 2 r)) (HalfLine 2 r) -findUnBoundedHalfLine = undefined -- use findD then find the starting point +_findUnBoundedHalfLine :: LinearProgram 2 r -> Either (Two (HalfSpace 2 r)) (HalfLine 2 r) +_findUnBoundedHalfLine = undefined -- use findD then find the starting point diff --git a/src/Algorithms/Geometry/LowerEnvelope/DualCH.hs b/src/Algorithms/Geometry/LowerEnvelope/DualCH.hs --- a/src/Algorithms/Geometry/LowerEnvelope/DualCH.hs +++ b/src/Algorithms/Geometry/LowerEnvelope/DualCH.hs @@ -1,4 +1,11 @@ {-# LANGUAGE ScopedTypeVariables #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Algorithms.Geometry.LowerEnvelope.DualCH +-- Copyright : (C) Frank Staals +-- License : see the LICENSE file +-- Maintainer : Frank Staals +-------------------------------------------------------------------------------- module Algorithms.Geometry.LowerEnvelope.DualCH where import Data.Maybe(fromJust) diff --git a/src/Algorithms/Geometry/PolyLineSimplification/DouglasPeucker.hs b/src/Algorithms/Geometry/PolyLineSimplification/DouglasPeucker.hs --- a/src/Algorithms/Geometry/PolyLineSimplification/DouglasPeucker.hs +++ b/src/Algorithms/Geometry/PolyLineSimplification/DouglasPeucker.hs @@ -1,3 +1,10 @@ +-------------------------------------------------------------------------------- +-- | +-- Module : Algorithms.Geometry.PolyLineSimplification.DouglasPeucker +-- Copyright : (C) Frank Staals +-- License : see the LICENSE file +-- Maintainer : Frank Staals +-------------------------------------------------------------------------------- module Algorithms.Geometry.PolyLineSimplification.DouglasPeucker where import Control.Lens hiding (only) @@ -18,7 +25,7 @@ -- vertices from pl) s.t. all other vertices are within dist eps to the -- original polyline. -- --- Running time: O(n^2) worst case, O(n log n) expected. +-- Running time: \( O(n^2) \) worst case, \( O(n log n) \) expected. douglasPeucker :: (Ord r, Fractional r, Arity d) => r -> PolyLine d p r -> PolyLine d p r douglasPeucker eps pl diff --git a/src/Algorithms/Geometry/PolygonTriangulation/EarClip.hs b/src/Algorithms/Geometry/PolygonTriangulation/EarClip.hs new file mode 100644 --- /dev/null +++ b/src/Algorithms/Geometry/PolygonTriangulation/EarClip.hs @@ -0,0 +1,525 @@ +{-# LANGUAGE RecordWildCards #-} +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Algorithms.Geometry.PolygonTriangulation.EarClip +-- Copyright : (C) David Himmelstrup +-- License : see the LICENSE file +-- Maintainer : David Himmelstrup +-- +-- Ear clipping triangulation algorithms. The baseline algorithm runs in \( O(n^2) \) +-- but has a low constant factor overhead. The z-order hashed variant runs in +-- \( O(n \log n) \). +-- +-- References: +-- +-- 1. https://en.wikipedia.org/wiki/Polygon_triangulation#Ear_clipping_method +-- 2. https://en.wikipedia.org/wiki/Z-order_curve +-- +-------------------------------------------------------------------------------- +module Algorithms.Geometry.PolygonTriangulation.EarClip + ( earClip + , earClipRandom + , earClipHashed + , earClipRandomHashed + , zHash + , zUnHash + ) where + +import Control.Lens ((^.)) +import Control.Monad.Identity +import Control.Monad.ST (ST, runST) +import Control.Monad.ST.Unsafe (unsafeInterleaveST) +import Data.Bits +import Data.Ext +import Data.Geometry.Boundary (PointLocationResult (Outside)) +import Data.Geometry.Point (Point (Point2), ccw', pattern CCW) +import Data.Geometry.Polygon +import Data.Geometry.Box +import Data.Geometry.Triangle (Triangle (Triangle), inTriangleRelaxed) +import Data.STRef +import Data.Vector (Vector) +import qualified Data.Vector as V +import qualified Data.Vector.Algorithms.Intro as Algo +import qualified Data.Vector.Circular as CV +import qualified Data.Vector.NonEmpty as NE +import qualified Data.Vector.Unboxed as U +import qualified Data.Vector.Unboxed.Mutable as MU +import GHC.Exts (build) +import Linear.V2 +import System.Random (mkStdGen, randomR) + +{- + We can check if a vertex is an ear in O(n) time. Checking all vertices will definitely + yield at least one ear in O(n^2) time. So, finding N ears will take O(n^3) if done naively. + + Keeping a separate list of possible ears will improve matters. For each possible ear, + we check if the vertex really is an ear or not. If it isn't, it is deleted from the + list of possible ears. If it /is/ an ear, the vertex is cut and the neighbours are + added back to the list of possible ears (if they aren't in the list already). + + So, start with a list of N possible ears, and we might add two vertices to the list + ever time we find an ear. Since there are only N ears to be found, only 2*N vertices + can be added to the list of possible ears in the worst case scenario. The list is + therefore bounded to 3*N and finding all ears is therefore O(n^2). + + Note: When checking if a vertex is an ear, it is sufficient to check against + reflex vertices. Some implementations keep a separate list of reflex + vertices for this reason but it does increase the constant factor + overhead. I think it's better to keep the constant factor low for small values + of N and use the hashed algorithm for larger values of N. +-} +-- | \( O(n^2) \) +-- +-- Returns triangular faces using absolute polygon point indices. +earClip :: (Num r, Ord r) => SimplePolygon p r -> [(Int,Int,Int)] +earClip poly = build gen + where + vs = NE.toVector $ CV.vector $ poly^.outerBoundaryVector + gen :: ((Int,Int,Int) -> b -> b) -> b -> b + gen cons nil = runST $ do + vertices <- mutListFromVector vs + possibleEars <- mutListClone vertices + let worker len focus = do + prev <- mutListPrev vertices focus + next <- mutListNext vertices focus + if len == 3 + then + return $ cons (prev, focus, next) nil + else do + prevEar <- mutListPrev possibleEars focus + nextEar <- mutListNext possibleEars focus + isEar <- earCheck vertices prev focus next + if isEar + then do + mutListDelete possibleEars prevEar nextEar + mutListDelete vertices prev next -- remove ear + + case (prevEar /= prev, nextEar /= next) of + (True, True) -> do + mutListInsert possibleEars prevEar nextEar prev + mutListInsert possibleEars prev nextEar next + (True, False) -> do + mutListInsert possibleEars prevEar nextEar prev + (False, True) -> do + mutListInsert possibleEars prevEar nextEar next + (False, False) -> return () + + cons (prev, focus, next) + <$> unsafeInterleaveST (worker (len-1) nextEar) + else do -- not an ear + mutListDelete possibleEars prevEar nextEar -- remove vertex + worker len nextEar + worker (V.length vs) 0 + +-- | \( O(n^2) \) +-- +-- Returns triangular faces using absolute polygon point indices. +earClipRandom :: (Num r, Ord r) => SimplePolygon p r -> [(Int,Int,Int)] +earClipRandom poly = build gen + where + vs = NE.toVector $ CV.vector $ poly^.outerBoundaryVector + gen :: ((Int,Int,Int) -> b -> b) -> b -> b + gen cons nil = runST $ do + vertices <- mutListFromVector vs + possibleEars <- mutListClone vertices + shuffled <- newShuffled (V.length vs) + let worker len = do + focus <- popShuffled shuffled + prev <- mutListPrev vertices focus + next <- mutListNext vertices focus + if len == 3 + then + return $ cons (prev, focus, next) nil + else do + prevEar <- mutListPrev possibleEars focus + nextEar <- mutListNext possibleEars focus + isEar <- earCheck vertices prev focus next + if isEar + then do + mutListDelete possibleEars prevEar nextEar + mutListDelete vertices prev next -- remove ear + + case (prevEar /= prev, nextEar /= next) of + (True, True) -> do + pushShuffled shuffled prev + pushShuffled shuffled next + mutListInsert possibleEars prevEar nextEar prev + mutListInsert possibleEars prev nextEar next + (True, False) -> do + pushShuffled shuffled prev + mutListInsert possibleEars prevEar nextEar prev + (False, True) -> do + pushShuffled shuffled next + mutListInsert possibleEars prevEar nextEar next + (False, False) -> return () + + cons (prev, focus, next) + <$> unsafeInterleaveST (worker (len-1)) + else do -- not an ear + mutListDelete possibleEars prevEar nextEar -- remove vertex + worker len + worker (V.length vs) + +-- | \( O(n \log n) \) expected time. +-- +-- Returns triangular faces using absolute polygon point indices. +earClipHashed :: Real r => SimplePolygon p r -> [(Int,Int,Int)] +earClipHashed poly = build gen + where + vs = NE.toVector $ CV.vector $ poly^.outerBoundaryVector + n = V.length vs + hasher = zHashGen vs + zHashVec = U.generate n $ \i -> hasher (V.unsafeIndex vs i ^. core) + gen :: ((Int,Int,Int) -> b -> b) -> b -> b + gen cons nil = runST $ do + vertices <- mutListFromVector vs + zHashes <- mutListSort zHashVec + possibleEars <- mutListClone vertices + let worker len focus = do + prev <- mutListPrev vertices focus + next <- mutListNext vertices focus + if len == 3 + then + return $ cons (prev, focus, next) nil + else do + prevEar <- mutListPrev possibleEars focus + nextEar <- mutListNext possibleEars focus + isEar <- earCheckHashed hasher vertices zHashes prev focus next + if isEar + then do + mutListDelete possibleEars prevEar nextEar + mutListDelete vertices prev next -- remove ear + mutListDeleteFocus zHashes focus + + case (prevEar /= prev, nextEar /= next) of + (True, True) -> do + mutListInsert possibleEars prevEar nextEar prev + mutListInsert possibleEars prev nextEar next + (True, False) -> do + mutListInsert possibleEars prevEar nextEar prev + (False, True) -> do + mutListInsert possibleEars prevEar nextEar next + (False, False) -> return () + + cons (prev, focus, next) + <$> unsafeInterleaveST (worker (len-1) nextEar) + else do -- not an ear + mutListDelete possibleEars prevEar nextEar -- remove vertex + worker len nextEar + worker n 0 + +-- | \( O(n \log n) \) expected time. +-- +-- Returns triangular faces using absolute polygon point indices. +earClipRandomHashed :: Real r => SimplePolygon p r -> [(Int,Int,Int)] +earClipRandomHashed poly = build gen + where + vs = NE.toVector $ CV.vector $ poly^.outerBoundaryVector + n = V.length vs + hasher = zHashGen vs + zHashVec = U.generate n $ \i -> hasher (V.unsafeIndex vs i ^. core) + gen :: ((Int,Int,Int) -> b -> b) -> b -> b + gen cons nil = runST $ do + vertices <- mutListFromVector vs + zHashes <- mutListSort zHashVec + possibleEars <- mutListClone vertices + shuffled <- newShuffled (V.length vs) + let worker len = do + focus <- popShuffled shuffled + prev <- mutListPrev vertices focus + next <- mutListNext vertices focus + if len == 3 + then + return $ cons (prev, focus, next) nil + else do + prevEar <- mutListPrev possibleEars focus + nextEar <- mutListNext possibleEars focus + isEar <- earCheckHashed hasher vertices zHashes prev focus next + if isEar + then do + mutListDelete possibleEars prevEar nextEar + mutListDelete vertices prev next -- remove ear + mutListDeleteFocus zHashes focus + + case (prevEar /= prev, nextEar /= next) of + (True, True) -> do + pushShuffled shuffled prev + pushShuffled shuffled next + mutListInsert possibleEars prevEar nextEar prev + mutListInsert possibleEars prev nextEar next + (True, False) -> do + pushShuffled shuffled prev + mutListInsert possibleEars prevEar nextEar prev + (False, True) -> do + pushShuffled shuffled next + mutListInsert possibleEars prevEar nextEar next + (False, False) -> return () + + cons (prev, focus, next) + <$> unsafeInterleaveST (worker (len-1)) + else do -- not an ear + mutListDelete possibleEars prevEar nextEar -- remove vertex + worker len + worker n + +------------------------------------------------------------------------------- +-- Bounding box + +-- Returns (minX, widthX, minY, heightY) +zHashGen :: Real r => V.Vector (Point 2 r :+ p) -> (Point 2 r -> Word) +zHashGen v = zHashPoint bounds + where + bounds = (minX, realToFrac (maxX-minX), minY, realToFrac (maxY-minY)) + bb = V.foldl1' (<>) $ V.map boundingBox v + Point2 minX minY = minPoint bb ^. core + Point2 maxX maxY = minPoint bb ^. core + +------------------------------------------------------------------------------- +-- Z-Order +-- https://en.wikipedia.org/wiki/Z-order_curve + +zHashPoint :: Real r => (r,Double,r,Double) -> Point 2 r -> Word +zHashPoint (minX, widthX, minY, heightY) (Point2 x y) = + zHash (V2 x' y') + where + x' = round (realToFrac (x-minX) / widthX * zHashMax) + y' = round (realToFrac (y-minY) / heightY * zHashMax) + +zHashMax :: Double +zHashMax = realToFrac zHashMaxW + +zHashMaxW :: Word +zHashMaxW = if finiteBitSize zHashMaxW == 32 then 0xFFFF else 0xFFFFFFFF + +-- | O(1) Z-Order hash the first half-world of each coordinate. +zHash :: V2 Word -> Word +zHash (V2 a b) = zHashSingle a .|. (unsafeShiftL (zHashSingle b) 1) + +-- | O(1) Reverse z-order hash. +zUnHash :: Word -> V2 Word +zUnHash z = + V2 (zUnHashSingle z) (zUnHashSingle (unsafeShiftR z 1)) + +zHashSingle :: Word -> Word +zHashSingle w + | finiteBitSize w == 32 = zHashSingle32 w + | otherwise = zHashSingle64 w + +zUnHashSingle :: Word -> Word +zUnHashSingle w + | finiteBitSize w == 32 = zUnHashSingle32 w + | otherwise = zUnHashSingle64 w + +zHashSingle32 :: Word -> Word +zHashSingle32 w = runIdentity $ do + w <- pure $ w .&. 0x0000FFFF + w <- pure $ (w .|. unsafeShiftL w 8) .&. 0x00FF00FF + w <- pure $ (w .|. unsafeShiftL w 4) .&. 0x0F0F0F0F + w <- pure $ (w .|. unsafeShiftL w 2) .&. 0x33333333 + w <- pure $ (w .|. unsafeShiftL w 1) .&. 0x55555555 + pure w + +zUnHashSingle32 :: Word -> Word +zUnHashSingle32 w = runIdentity $ do + w <- pure $ w .&. 0x55555555 + w <- pure $ (w .|. unsafeShiftR w 1) .&. 0x33333333 + w <- pure $ (w .|. unsafeShiftR w 2) .&. 0x0F0F0F0F + w <- pure $ (w .|. unsafeShiftR w 4) .&. 0x00FF00FF + w <- pure $ (w .|. unsafeShiftR w 8) .&. 0x0000FFFF + pure w + +zHashSingle64 :: Word -> Word +zHashSingle64 w = runIdentity $ do + w <- pure $ w .&. 0x00000000FFFFFFFF + w <- pure $ (w .|. unsafeShiftL w 16) .&. 0x0000FFFF0000FFFF + w <- pure $ (w .|. unsafeShiftL w 8) .&. 0x00FF00FF00FF00FF + w <- pure $ (w .|. unsafeShiftL w 4) .&. 0x0F0F0F0F0F0F0F0F + w <- pure $ (w .|. unsafeShiftL w 2) .&. 0x3333333333333333 + w <- pure $ (w .|. unsafeShiftL w 1) .&. 0x5555555555555555 + pure w + +zUnHashSingle64 :: Word -> Word +zUnHashSingle64 w = runIdentity $ do + w <- pure $ w .&. 0x5555555555555555 + w <- pure $ (w .|. unsafeShiftR w 1) .&. 0x3333333333333333 + w <- pure $ (w .|. unsafeShiftR w 2) .&. 0x0F0F0F0F0F0F0F0F + w <- pure $ (w .|. unsafeShiftR w 4) .&. 0x00FF00FF00FF00FF + w <- pure $ (w .|. unsafeShiftR w 8) .&. 0x0000FFFF0000FFFF + w <- pure $ (w .|. unsafeShiftR w 16) .&. 0x00000000FFFFFFFF + pure w + +------------------------------------------------------------------------------- +-- Shuffled + +data Shuffled s = Shuffled + { shuffleCount :: STRef s Int + , shuffleVector :: MU.MVector s Int } + +newShuffled :: Int -> ST s (Shuffled s) +newShuffled len = Shuffled <$> newSTRef len <*> U.unsafeThaw (U.enumFromN 0 len) + +popShuffled :: Shuffled s -> ST s Int +popShuffled Shuffled{..} = do + count <- readSTRef shuffleCount + writeSTRef shuffleCount (count-1) + let idx = fst $ randomR (0, count-1) (mkStdGen count) + val <- MU.unsafeRead shuffleVector idx + MU.unsafeWrite shuffleVector idx =<< MU.unsafeRead shuffleVector (count-1) + pure val + +pushShuffled :: Shuffled s -> Int -> ST s () +pushShuffled (Shuffled ref vector) val = do + count <- readSTRef ref + writeSTRef ref (count+1) + MU.unsafeWrite vector count val + +------------------------------------------------------------------------------- +-- MutList + +data MutList s a = MutList + { mutListIndex :: (Int -> a) + , mutListNextVec :: MU.MVector s Int + , mutListPrevVec :: MU.MVector s Int + } + +-- O(n) +mutListFromVector :: Vector a -> ST s (MutList s a) +mutListFromVector vec = MutList (V.unsafeIndex vec) + <$> do + arr <- U.unsafeThaw (U.enumFromN 1 (V.length vec)) + MU.unsafeWrite arr (V.length vec-1) 0 + pure arr + <*> do + arr <- U.unsafeThaw (U.enumFromN (-1) (V.length vec)) + MU.unsafeWrite arr 0 (V.length vec-1) + pure arr + +mutListClone :: MutList s a -> ST s (MutList s a) +mutListClone (MutList vec nextVec prevVec) = MutList vec + <$> MU.clone nextVec + <*> MU.clone prevVec + +mutListNext :: MutList s a -> Int -> ST s Int +mutListNext m idx = MU.unsafeRead (mutListNextVec m) idx + +mutListPrev :: MutList s a -> Int -> ST s Int +mutListPrev m idx = MU.unsafeRead (mutListPrevVec m) idx + +mutListDelete :: MutList s a -> Int -> Int -> ST s () +mutListDelete m prev next = do + MU.unsafeWrite (mutListNextVec m) prev next + MU.unsafeWrite (mutListPrevVec m) next prev + +mutListDeleteFocus :: MutList s a -> Int -> ST s () +mutListDeleteFocus m focus = do + prev <- mutListPrev m focus + next <- mutListNext m focus + unless (prev == -1) $ + MU.unsafeWrite (mutListNextVec m) prev next + unless (next == -1) $ + MU.unsafeWrite (mutListPrevVec m) next prev + +mutListInsert :: MutList s a -> Int -> Int -> Int -> ST s () +mutListInsert m before after elt = do + MU.unsafeWrite (mutListNextVec m) before elt -- before.next = elt + MU.unsafeWrite (mutListNextVec m) elt after -- elt.next = after + MU.unsafeWrite (mutListPrevVec m) after elt -- after.prev = elt + MU.unsafeWrite (mutListPrevVec m) elt before -- elt.prev = before + +mutListSort :: (Ord a, MU.Unbox a) => U.Vector a -> ST s (MutList s a) +mutListSort vec = do + sorted <- do + arr <- U.unsafeThaw $ (U.enumFromN 0 n :: U.Vector Int) + Algo.sortBy (\a b -> compare (U.unsafeIndex vec a) (U.unsafeIndex vec b)) arr + U.unsafeFreeze arr + + next <- MU.new n + prev <- MU.new n + MU.write next + (U.unsafeIndex sorted (n-1)) + (-1) + forM_ [0..n-2] $ \i -> do + MU.write next + (U.unsafeIndex sorted i) + (U.unsafeIndex sorted (i+1)) + MU.write prev + (U.unsafeIndex sorted 0) + (-1) + forM_ [1..n-1] $ \i -> do + MU.write prev + (U.unsafeIndex sorted i) + (U.unsafeIndex sorted (i-1)) + pure $ MutList (U.unsafeIndex vec) next prev + where + n = U.length vec + +------------------------------------------------------------------------------- +-- Ear checking + +-- O(n) +earCheck :: (Num r, Ord r) => MutList s (Point 2 r :+ p) -> Int -> Int -> Int -> ST s Bool +earCheck vertices a b c = do + let pointA = mutListIndex vertices a + pointB = mutListIndex vertices b + pointC = mutListIndex vertices c + trig = Triangle pointA pointB pointC + + let loop elt | elt == a = pure True + loop elt = do + let point = mutListIndex vertices elt ^. core + case inTriangleRelaxed point trig of + Outside -> loop =<< mutListNext vertices elt + _ -> pure False + if ccw' pointA pointB pointC == CCW + then loop =<< mutListNext vertices c + else pure False + +-- showBinary :: (Integral a, Show a) => a -> String +-- showBinary i = showIntAtBase 2 intToDigit i "" + +earCheckHashed :: Real r => (Point 2 r -> Word) -> MutList s (Point 2 r :+ p) -> MutList s Word -> Int -> Int -> Int -> ST s Bool +earCheckHashed hasher vertices zHashes a b c = do + let pointA = mutListIndex vertices a + pointB = mutListIndex vertices b + pointC = mutListIndex vertices c + trig = Triangle pointA pointB pointC + trigBB = boundingBox trig + lowPt = minPoint trigBB ^. core + highPt = maxPoint trigBB ^. core + -- (lowPt, highPt) = triangleBoundingBox trig + + minZ = hasher lowPt + maxZ = hasher highPt + + let upwards up + | up == -1 || upZ > maxZ = pure True + | inTriangleRelaxed pointUp trig /= Outside = pure False + | otherwise = upwards =<< mutListNext zHashes up + where + upZ = mutListIndex zHashes up + pointUp = mutListIndex vertices up ^. core + downwards down + | down == -1 || downZ < minZ = pure True + | inTriangleRelaxed pointDown trig /= Outside = pure False + | otherwise = downwards =<< mutListPrev zHashes down + where + downZ = mutListIndex zHashes down + pointDown = mutListIndex vertices down ^. core + bidirectional up down + | up == -1 || upZ > maxZ = downwards down + | down == -1 || downZ < minZ = upwards up + | up /= a && up /= b && inTriangleRelaxed pointUp trig /= Outside = pure False + | down /= a && down /= b && inTriangleRelaxed pointDown trig /= Outside = pure False + | otherwise = do + up' <- mutListNext zHashes up + down' <- mutListPrev zHashes down + bidirectional up' down' + where + upZ = mutListIndex zHashes up + downZ = mutListIndex zHashes down + pointUp = mutListIndex vertices up ^. core + pointDown = mutListIndex vertices down ^. core + if ccw' pointA pointB pointC == CCW + then bidirectional b b + else pure False diff --git a/src/Algorithms/Geometry/PolygonTriangulation/MakeMonotone.hs b/src/Algorithms/Geometry/PolygonTriangulation/MakeMonotone.hs --- a/src/Algorithms/Geometry/PolygonTriangulation/MakeMonotone.hs +++ b/src/Algorithms/Geometry/PolygonTriangulation/MakeMonotone.hs @@ -1,5 +1,12 @@ -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Algorithms.Geometry.PolygonTriangulation.MakeMonotone +-- Copyright : (C) Frank Staals +-- License : see the LICENSE file +-- Maintainer : Frank Staals +-------------------------------------------------------------------------------- module Algorithms.Geometry.PolygonTriangulation.MakeMonotone( makeMonotone , computeDiagonals @@ -8,35 +15,33 @@ , classifyVertices ) where -import Algorithms.Geometry.LineSegmentIntersection.BentleyOttmann ( xCoordAt - , ordAt) -import Algorithms.Geometry.PolygonTriangulation.Types +import Algorithms.Geometry.LineSegmentIntersection.BentleyOttmann (ordAt, xCoordAt) +import Algorithms.Geometry.PolygonTriangulation.Types + import Control.Lens -import Control.Monad (forM_, when) import Control.Monad.Reader import Control.Monad.State.Strict -import Control.Monad.Writer (WriterT, execWriterT,tell) +import Control.Monad.Writer (WriterT, execWriterT, tell) import Data.Bifunctor -import Data.CircularSeq (rotateL, rotateR, zip3LWith) -import qualified Data.DList as DList +import qualified Data.DList as DList import Data.Ext -import qualified Data.Foldable as F +import qualified Data.Foldable as F import Data.Geometry.LineSegment import Data.Geometry.PlanarSubdivision.Basic import Data.Geometry.Point import Data.Geometry.Polygon -import qualified Data.IntMap as IntMap -import qualified Data.List.NonEmpty as NonEmpty -import Data.Ord (comparing, Down(..)) -import qualified Data.Set as SS -import qualified Data.Set.Util as SS +import qualified Data.IntMap as IntMap +import qualified Data.List.NonEmpty as NonEmpty +import Data.Ord (Down (..), comparing) +import qualified Data.Set as SS +import qualified Data.Set.Util as SS import Data.Util -import qualified Data.Vector as V -import qualified Data.Vector.Mutable as MV +import qualified Data.Vector as V +import qualified Data.Vector.Circular as CV +import qualified Data.Vector.Mutable as MV -- import Debug.Trace --- import qualified Data.CircularSeq as CC ---------------------------------------------------------------------------------- data VertexType = Start | Merge | Split | End | Regular deriving (Show,Read,Eq) @@ -49,10 +54,10 @@ classifyVertices :: (Num r, Ord r) => Polygon t p r -> Polygon t (p :+ VertexType) r -classifyVertices p@(SimplePolygon _) = classifyVertices' p +classifyVertices p@SimplePolygon{} = classifyVertices' p classifyVertices (MultiPolygon vs h) = MultiPolygon vs' h' where - (SimplePolygon vs') = classifyVertices' $ SimplePolygon vs + vs' = classifyVertices' vs h' = map (first (&extra %~ onHole) . classifyVertices') h -- the roles on hole vertices are slightly different @@ -70,9 +75,10 @@ classifyVertices' :: (Num r, Ord r) => SimplePolygon p r -> SimplePolygon (p :+ VertexType) r -classifyVertices' (SimplePolygon vs) = - SimplePolygon $ zip3LWith f (rotateL vs) vs (rotateR vs) +classifyVertices' poly = + unsafeFromCircularVector $ CV.zipWith3 f (CV.rotateLeft 1 vs) vs (CV.rotateRight 1 vs) where + vs = poly ^. outerBoundaryVector -- is the angle larger than > 180 degrees largeInteriorAngle p c n = case ccw (p^.core) (c^.core) (n^.core) of CCW -> False @@ -98,7 +104,7 @@ -------------------------------------------------------------------------------- -type Event r = Point 2 r :+ (Two (LineSegment 2 Int r)) +type Event r = Point 2 r :+ Two (LineSegment 2 Int r) data StatusStruct r = SS { _statusStruct :: !(SS.Set (LineSegment 2 Int r)) , _helper :: !(IntMap.IntMap Int) @@ -109,6 +115,7 @@ ix' :: Int -> Lens' (V.Vector a) a ix' i = singular (ix i) +{- HLINT ignore computeDiagonals -} -- | Given a polygon, find a set of non-intersecting diagonals that partition -- the polygon into y-monotone pieces. -- diff --git a/src/Algorithms/Geometry/PolygonTriangulation/Triangulate.hs b/src/Algorithms/Geometry/PolygonTriangulation/Triangulate.hs --- a/src/Algorithms/Geometry/PolygonTriangulation/Triangulate.hs +++ b/src/Algorithms/Geometry/PolygonTriangulation/Triangulate.hs @@ -1,3 +1,10 @@ +-------------------------------------------------------------------------------- +-- | +-- Module : Algorithms.Geometry.PolygonTriangulation.Triangulate +-- Copyright : (C) Frank Staals +-- License : see the LICENSE file +-- Maintainer : Frank Staals +-------------------------------------------------------------------------------- module Algorithms.Geometry.PolygonTriangulation.Triangulate where @@ -11,7 +18,6 @@ import Data.Geometry.LineSegment import Data.Geometry.PlanarSubdivision.Basic import Data.Geometry.Polygon -import Data.PlaneGraph (PlaneGraph) -------------------------------------------------------------------------------- diff --git a/src/Algorithms/Geometry/PolygonTriangulation/TriangulateMonotone.hs b/src/Algorithms/Geometry/PolygonTriangulation/TriangulateMonotone.hs --- a/src/Algorithms/Geometry/PolygonTriangulation/TriangulateMonotone.hs +++ b/src/Algorithms/Geometry/PolygonTriangulation/TriangulateMonotone.hs @@ -1,23 +1,45 @@ -module Algorithms.Geometry.PolygonTriangulation.TriangulateMonotone where +-------------------------------------------------------------------------------- +-- | +-- Module : Algorithms.Geometry.PolygonTriangulation.TriangulateMonotone +-- Copyright : (C) Frank Staals +-- License : see the LICENSE file +-- Maintainer : Frank Staals +-------------------------------------------------------------------------------- +module Algorithms.Geometry.PolygonTriangulation.TriangulateMonotone + ( MonotonePolygon + , triangulate + , triangulate' + , computeDiagonals + -- , LR(..) + -- , P + -- , Stack + -- , chainOf + -- , toVtx + -- , seg + -- , process + -- , isInside + -- , mergeBy + -- , splitPolygon + ) where +import Algorithms.Geometry.PolygonTriangulation.Types import Control.Lens -import Data.Bifunctor -import qualified Data.CircularSeq as C import Data.Ext -import qualified Data.Foldable as F +import qualified Data.Foldable as F import Data.Geometry.LineSegment +import Data.Geometry.PlanarSubdivision.Basic (PlanarSubdivision, PolygonFaceData) import Data.Geometry.Point import Data.Geometry.Polygon -import qualified Data.List as L -import Data.Ord (comparing, Down(..)) +import qualified Data.List as L +import Data.Ord (Down (..), comparing) +import Data.PlaneGraph (PlaneGraph) import Data.Util -import Algorithms.Geometry.PolygonTriangulation.Types -import Data.PlaneGraph (PlaneGraph) -import Data.Geometry.PlanarSubdivision.Basic(PolygonFaceData, PlanarSubdivision) +import qualified Data.Vector.Circular.Util as CV -------------------------------------------------------------------------------- --- +-- | Y-monotone polygon. All straight horizontal lines intersects the polygon +-- no more than twice. type MonotonePolygon p r = SimplePolygon p r data LR = L | R deriving (Show,Eq) @@ -126,19 +148,18 @@ -- running time: \(O(n)\) splitPolygon :: Ord r => MonotonePolygon p r -> ([Point 2 r :+ (LR :+ p)], [Point 2 r :+ (LR :+ p)]) -splitPolygon pg = bimap (f L) (f R) - . second reverse +splitPolygon pg = bimap (f L) (f R . reverse) . L.break (\v -> v^.core == vMinY) - . F.toList . C.rightElements $ vs' + . F.toList . CV.rightElements $ vs' where f x = map (&extra %~ (x :+)) -- rotates the list to the vtx with max ycoord - Just vs' = C.findRotateTo (\v -> v^.core == vMaxY) - $ pg^.outerBoundary + Just vs' = CV.findRotateTo (\v -> v^.core == vMaxY) + $ pg^.outerBoundaryVector vMaxY = getY F.maximumBy vMinY = getY F.minimumBy swap' (Point2 x y) = Point2 y x - getY ff = let p = ff (comparing (^.core.to swap')) $ pg^.outerBoundary + getY ff = let p = ff (comparing (^.core.to swap')) $ pg^.outerBoundaryVector in p^.core @@ -156,15 +177,15 @@ -testPoly5 :: SimplePolygon () Rational -testPoly5 = toCounterClockWiseOrder . fromPoints $ map ext $ [ Point2 176 736 - , Point2 240 688 - , Point2 240 608 - , Point2 128 576 - , Point2 64 640 - , Point2 80 720 - , Point2 128 752 - ] +-- testPoly5 :: SimplePolygon () Rational +-- testPoly5 = toCounterClockWiseOrder . fromPoints $ map ext [ Point2 176 736 +-- , Point2 240 688 +-- , Point2 240 608 +-- , Point2 128 576 +-- , Point2 64 640 +-- , Point2 80 720 +-- , Point2 128 752 +-- ] -- testPoly5 :: SimplePolygon () Rational diff --git a/src/Algorithms/Geometry/PolygonTriangulation/Types.hs b/src/Algorithms/Geometry/PolygonTriangulation/Types.hs --- a/src/Algorithms/Geometry/PolygonTriangulation/Types.hs +++ b/src/Algorithms/Geometry/PolygonTriangulation/Types.hs @@ -1,4 +1,11 @@ {-# LANGUAGE ScopedTypeVariables #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Algorithms.Geometry.PolygonTriangulation.Types +-- Copyright : (C) Frank Staals +-- License : see the LICENSE file +-- Maintainer : Frank Staals +-------------------------------------------------------------------------------- module Algorithms.Geometry.PolygonTriangulation.Types where import Control.Lens @@ -15,6 +22,7 @@ -------------------------------------------------------------------------------- +-- | After triangulation, edges are either from the original polygon or a new diagonal. data PolygonEdgeType = Original | Diagonal deriving (Show,Read,Eq) diff --git a/src/Algorithms/Geometry/RedBlueSeparator/RIC.hs b/src/Algorithms/Geometry/RedBlueSeparator/RIC.hs --- a/src/Algorithms/Geometry/RedBlueSeparator/RIC.hs +++ b/src/Algorithms/Geometry/RedBlueSeparator/RIC.hs @@ -65,11 +65,11 @@ -> g (Point 2 r :+ blueData) -> m (Maybe (Line 2 r)) separatingLine' reds blues = case verticalSeparatingLine reds blues of - SP Nothing ((r:+_),(b :+ _)) -> separatingLine'' r b reds blues + SP Nothing (r:+_,b :+ _) -> separatingLine'' r b reds blues -- observe that if r and b were vertically above each other then we would -- have found a separating line. So r and b are not vertically -- aligned. Hence we satisfy the precondition. - SP ml@(Just _) _ -> pure ml -- already found a line + SP ml@(Just _) _ -> pure ml -- already found a line -- | given a red and blue point that are *NOT* vertically alligned, and all red diff --git a/src/Algorithms/Geometry/SSSP.hs b/src/Algorithms/Geometry/SSSP.hs new file mode 100644 --- /dev/null +++ b/src/Algorithms/Geometry/SSSP.hs @@ -0,0 +1,454 @@ +{-# LANGUAGE RecordWildCards #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Algorithms.Geometry.SSSP +-- Copyright : (C) David Himmelstrup +-- License : see the LICENSE file +-- Maintainer : David Himmelstrup +-------------------------------------------------------------------------------- +module Algorithms.Geometry.SSSP + ( SSSP + , triangulate + , sssp + , visibilityDual + , visibilityFinger + , visibilitySensitive + ) where + +import Algorithms.Geometry.PolygonTriangulation.Triangulate (triangulate') +import Algorithms.Geometry.PolygonTriangulation.Types (PolygonEdgeType) + +import Algorithms.Graph.DFS (adjacencyLists, dfs', dfsSensitive) +import Control.Lens ((^.)) +import Data.Bitraversable +import Data.Either +import Data.Ext (ext, extra, type (:+) (..)) +import qualified Data.FingerTree as F +import Data.Geometry.Line (lineThrough) +import Data.Geometry.LineSegment (LineSegment (ClosedLineSegment, LineSegment)) +import Data.Geometry.PlanarSubdivision (PolygonFaceData (..)) +import Data.Geometry.Point (Point, ccw, pattern CCW, pattern CW) +import Data.Geometry.Polygon +import Data.Intersection +import Data.List (sortOn, (\\)) +import Data.Maybe (fromMaybe) +import Data.PlanarGraph (PlanarGraph) +import qualified Data.PlanarGraph as Graph +import Data.PlaneGraph (FaceId (..), PlaneGraph, VertexData (..), + VertexId, VertexId', dual, graph, incidentEdges, + leftFace, vertices) +import qualified Data.PlaneGraph as PlaneGraph +import Data.Proxy +import Data.Tree (Tree (Node)) +import qualified Data.Vector as V +import qualified Data.Vector.Circular as CV +import qualified Data.Vector.Circular.Util as CV +import Data.Vector.Unboxed (Vector) +import qualified Data.Vector.Unboxed as VU +import Data.Vinyl +import Data.Vinyl.CoRec + +{- +type AbsOffset = Int + +data TriangulatedPolygon t p r = TriangulatedPolygon + { triangulatedMap :: Map AbsOffset (VertexId () Primal) + , triangulatedGraph :: PlaneGraph () AbsOffset PolygonEdgeType PolygonFaceData r + , triangulatedPolygon :: Polygon t p r + } +-} + + + +-- | Single-source shortest paths tree. Both keys and values are vertex offset ints. +-- +-- @parentOf(i) = sssp[i]@ +type SSSP = Vector Int + +-- FIXME: The code for generating the dual cannot deal with offsets so +-- we're running 'unsafeFromPoints . toPoints' to reset the polygon. +-- Super silly. Please fix. +-- | \( O(n \log n) \) +triangulate :: (Ord r, Fractional r) => SimplePolygon p r -> PlaneGraph s Int PolygonEdgeType PolygonFaceData r +triangulate p = + let poly' = snd $ bimapAccumL (\a _ -> (a+1,a)) (,) 0 $ unsafeFromPoints $ toPoints p + in triangulate' Proxy poly' + +-- | \( O(n) \) Single-Source shortest path. +sssp :: (Ord r, Fractional r) + => PlaneGraph s Int PolygonEdgeType PolygonFaceData r + -> SSSP +sssp trig = + ssspFinger d + where + Just v0 = fst <$> V.find (\(_vid, VertexData _ idx) -> idx == 0) (vertices trig) + v0i = incidentEdges v0 trig + Just (FaceId firstFace) = V.find (/= FaceId outer) $ V.map (`leftFace` trig) v0i + FaceId outer = PlaneGraph.outerFaceId trig + dualGraph = trig^.graph.dual + dualTree' = dfs' (V.map (filter (/= outer)) $ adjacencyLists dualGraph) firstFace + dualVS = fmap (\v -> toCCW $ PlaneGraph.boundaryVertices (FaceId v) trig) dualTree' + trigTree = toTrigTree trig dualVS + d = mkDual trigTree + + toCCW v = + let cv = CV.reverse $ CV.unsafeFromVector v + in CV.toVector $ fromMaybe cv $ CV.findRotateTo (== v0) cv + +{- +1. Find the starting face. +-} +visibilitySensitive :: forall s r. (Ord r, Fractional r, Show r) + => PlaneGraph s Int PolygonEdgeType PolygonFaceData r + -> SimplePolygon () r +visibilitySensitive = fromPoints . map ext . rights . visibilityFinger . visibilityDual + + +visibilityDual :: forall s r. (Ord r, Fractional r) + => PlaneGraph s Int PolygonEdgeType PolygonFaceData r + -> Dual r +visibilityDual trig = d + where + Just v0 = fst <$> V.find (\(_vid, VertexData _ idx) -> idx == 0) (vertices trig) + v0i = incidentEdges v0 trig + + outer :: VertexId s Graph.Dual + FaceId outer = PlaneGraph.outerFaceId trig + + firstFace :: VertexId s Graph.Dual + Just (FaceId firstFace) = V.find (/= FaceId outer) $ V.map (`leftFace` trig) v0i + + dualGraph :: PlanarGraph s Graph.Dual PolygonFaceData PolygonEdgeType (VertexData r Int) + dualGraph = trig^.graph.dual + + dualTree' :: Tree (VertexId s Graph.Dual) + dualTree' = dfsSensitive neigh firstFace + + neigh :: VertexId s Graph.Dual -> [VertexId s Graph.Dual] + neigh v = V.toList $ V.filter (/=outer) $ Graph.neighboursOf v dualGraph + + dualVS :: Tree (V.Vector (VertexId' s)) + dualVS = fmap (\v -> toCCW $ PlaneGraph.boundaryVertices (FaceId v) trig) dualTree' + + trigTree :: Tree (Index r, Index r, Index r) + trigTree = toTrigTree trig dualVS + + d :: Dual r + d = mkDual trigTree + + toCCW v = + let cv = CV.reverse $ CV.unsafeFromVector v + in CV.toVector $ fromMaybe cv $ CV.findRotateTo (== v0) cv + + + +visibilityFinger :: forall r. (Fractional r, Ord r, Show r) => Dual r -> [Either (Int, Int, Int) (Point 2 r)] +visibilityFinger d = + case d of + Dual (a,b,c) ab bc ca -> + Left (indexExtra a, indexExtra b, indexExtra c) : + worker (Funnel (F.singleton b) a F.empty) ab ++ + worker (Funnel (F.singleton c) a (F.singleton b)) bc ++ + worker (Funnel F.empty a (F.singleton c)) ca + where + -- Final edge is the leftmost of each funnel. + -- The most visible are the rightmost of each funnel. + -- Cut line segment. + worker f EmptyDual = + let edgeA = ringAccess $ funnelRightTop f + edgeB = ringAccess $ funnelLeftTop f + edge = ClosedLineSegment (ext edgeA) (ext edgeB) + coneA = ringAccess $ funnelRightBottom f + coneB = ringAccess $ funnelLeftBottom f + lineA = lineThrough (ringAccess $ funnelCusp f) coneA + lineB = lineThrough (ringAccess $ funnelCusp f) coneB + -- findIntersection :: Line 2 r -> Point 2 r + findIntersection line = + match (edge `intersect` line) $ + H (\NoIntersection -> error "no intersection") + :& H (\pt -> Right pt) + :& H (\LineSegment{} -> error "line intersection") + :& RNil + in [if edgeA == coneA then Right coneA else findIntersection lineA] ++ + if edgeB == coneB then [] else [findIntersection lineB] + worker f (NodeDual x l r) = + Left (indexExtra $ fromMaybe (funnelCusp f) $ chainTop (funnelRight f) + ,indexExtra x + ,indexExtra $ fromMaybe (funnelCusp f) $ chainTop (funnelLeft f)) : + case splitFunnel x f of + (_v, fL, fR, dir) -> case dir of + -- 'x' is to the left of the visibility cone. Everything further to the left cannot + -- be visible to just go right. + SplitLeft -> worker fR r -- assert cusp of fR == cusp of f + -- 'x' is visible from our cusp. Add it to the output and go both to the left and right. + NoSplit -> worker fR r ++ [Right (ringAccess x)] ++ worker fL l + -- 'x' is to the right of the visibility cone. Everything further to the right cannot + -- be visible to just go left. + SplitRight -> worker fL l -- assert cusp of fL == cusp of f + + +-------------------------------------------------------------------------------- +-- SSSP (with fingertree) implementation + + + + + +data MinMax r = MinMax (Index r) (Index r) | MinMaxEmpty deriving (Show) +instance Semigroup (MinMax r) where + MinMaxEmpty <> b = b + a <> MinMaxEmpty = a + MinMax a _b <> MinMax _c d + = MinMax a d +instance Monoid (MinMax r) where + mempty = MinMaxEmpty + +-- Including the 'Point 2 r' here means we don't have to look it up. +-- This mattered since lookups used to be O(log n) rather than O(1). +newtype Index r = Index (Point 2 r :+ Int) -- deriving (Show) + +instance Show (Index r) where + show = show . indexExtra + +indexExtra :: Index r -> Int +indexExtra (Index p) = p^.extra + +instance Eq (Index r) where + Index (_ :+ a) == Index (_ :+ b) = a == b + +type Chain r = F.FingerTree (MinMax r) (Index r) +data Funnel r = Funnel + { funnelLeft :: Chain r -- Left-most element is furthest away from cusp. + , funnelCusp :: Index r + , funnelRight :: Chain r -- Left-most element is furthest away from cusp. + } deriving (Show) + +-- Left side of the funnel, furthest away from the cusp. +funnelLeftTop :: Funnel r -> Index r +funnelLeftTop f = fromMaybe (funnelCusp f) $ chainTop (funnelLeft f) + +-- Left side of the funnel, closest to the cusp. +funnelLeftBottom :: Funnel r -> Index r +funnelLeftBottom f = fromMaybe (funnelCusp f) $ chainBottom (funnelLeft f) + +-- Right side of the funnel, furthest away from the cusp. +funnelRightTop :: Funnel r -> Index r +funnelRightTop f = fromMaybe (funnelCusp f) $ chainTop (funnelRight f) + +-- Right side of the funnel, closest to the cusp. +funnelRightBottom :: Funnel r -> Index r +funnelRightBottom f = fromMaybe (funnelCusp f) $ chainBottom (funnelRight f) + +-- Element closest to the cusp. +chainBottom :: Chain r -> Maybe (Index r) +chainBottom chain = case F.viewl chain of + F.EmptyL -> Nothing + elt F.:< _ -> Just elt + +-- Element furthest away from the cusp. +chainTop :: Chain r -> Maybe (Index r) +chainTop chain = case F.viewr chain of + F.EmptyR -> Nothing + _ F.:> elt -> Just elt + +instance F.Measured (MinMax r) (Index r) where + measure i = MinMax i i + +data SplitDirection = SplitLeft | NoSplit | SplitRight + deriving (Show) + +-- Split a funnel w.r.t. a point 'x'. There are three cases: +-- 1. 'x' is visible from the cusp. +-- 2. the path to 'x' hits the left side of the funnel. +-- 3. the path to 'x' hits the right side of the funnel. +-- +-- ******************************************************** +-- Drawing guide: +-- \ / +-- left side of funnel -> \ / <- right side of funnel +-- \ / +-- * <- cusp +-- ******************************************************** +-- +-- Case 1: +-- x +-- \ / +-- \ / +-- \ / +-- * +-- +-- Case 2: +-- +-- x +-- \ / +-- \ / +-- \ / +-- * +-- +-- Case 3: +-- +-- x +-- \ / +-- \ / +-- \ / +-- * +-- +-- If 'x' is visible from the cusp, then the shortest path is a straight line and we're done. +-- If 'x' is not visible from the cusp, then we find the first point up the funnel where +-- 'x' becomes visible. We'll use a fingertree to find the point in O(log(min(n,m))). Because +-- of math, this adds up to O(n) for the entire SSSP tree. +-- +-- Once we've found the first point that can see 'x', we split the funnel in two: One funnel +-- that will be used for points to the left of 'x' and one funnel for points to the right of +-- 'x'. Oh, "left" and "right" here are used to indicate branches in the dual tree. +splitFunnel :: (Fractional r, Ord r) => Index r -> Funnel r -> (Index r, Funnel r, Funnel r, SplitDirection) +splitFunnel x Funnel{..} + | isOnLeftChain = + case doSearch isRightTurn funnelLeft of + (lower, t, upper) -> + ( t + , Funnel upper t (F.singleton x) + , Funnel (lower F.|> t F.|> x) funnelCusp funnelRight + , SplitLeft) + | isOnRightChain = + case doSearch isLeftTurn funnelRight of + (lower, t, upper) -> + ( t + , Funnel funnelLeft funnelCusp (lower F.|> t F.|> x) + , Funnel (F.singleton x) t upper + , SplitRight) + | otherwise = + ( funnelCusp + , Funnel funnelLeft funnelCusp (F.singleton x) + , Funnel (F.singleton x) funnelCusp funnelRight + , NoSplit) + where + isOnLeftChain = fromMaybe False $ + isLeftTurnOrLinear cuspElt <$> leftElt <*> pure targetElt + isOnRightChain = fromMaybe False $ + isRightTurnOrLinear cuspElt <$> rightElt <*> pure targetElt + doSearch fn chain = + case F.search (searchChain fn) chain of + F.Position lower t upper -> (lower, t, upper) + F.OnLeft -> error "cannot happen" + F.OnRight -> error "cannot happen" + F.Nowhere -> error "cannot happen" + searchChain _ MinMaxEmpty _ = False + searchChain _ _ MinMaxEmpty = True + searchChain check (MinMax _ l) (MinMax r _) = + check (ringAccess l) (ringAccess r) targetElt + cuspElt = ringAccess funnelCusp + targetElt = ringAccess x + leftElt = ringAccess <$> chainBottom funnelLeft + rightElt = ringAccess <$> chainBottom funnelRight + +-- FIXME: Turning a list of pairs into a vector is incredibly inefficient. +-- Would be much faster to write directly into a mutable vector and +-- then freeze it at the end. +-- \( O(n) \) +ssspFinger :: (Fractional r, Ord r) => Dual r -> SSSP +ssspFinger d = toSSSP $ + case d of + Dual (a,b,c) ab bc ca -> + (a, a) : + (b, a) : + (c, a) : + loopLeft a c ca ++ + worker (Funnel (F.singleton c) a (F.singleton b)) bc ++ + loopRight a b ab + where + toSSSP :: [(Index r,Index r)] -> SSSP + toSSSP lst = + VU.fromList . map snd . sortOn fst $ + [ (a,b) | (Index (_ :+ a), Index (_ :+ b)) <- lst ] + loopLeft a outer l = + case l of + EmptyDual -> [] + NodeDual x l' r' -> + (x,a) : + worker (Funnel (F.singleton x) a (F.singleton outer)) r' ++ + loopLeft a x l' + loopRight a outer r = + case r of + EmptyDual -> [] + NodeDual x l' r' -> + (x, a) : + worker (Funnel (F.singleton outer) a (F.singleton x)) l' ++ + loopRight a x r' + worker _ EmptyDual = [] + worker f (NodeDual x l r) = + case splitFunnel x f of + (v, fL, fR, _) -> + (x, v) : + worker fL l ++ + worker fR r + + +-------------------------------------------------------------------------------- +-- Duals + + + +data Dual r = Dual (Index r, Index r, Index r) -- (a,b,c) + (DualTree r) -- borders ab + (DualTree r) -- borders bc + (DualTree r) -- borders ca + deriving (Show) + +data DualTree r + = EmptyDual + | NodeDual (Index r) -- axb triangle, a and b are from parent. + (DualTree r) -- borders xb + (DualTree r) -- borders ax + deriving (Show) + +toTrigTree :: PlaneGraph s Int PolygonEdgeType PolygonFaceData r + -> Tree (V.Vector (VertexId' s)) + -> Tree (Index r,Index r,Index r) +toTrigTree trig = fmap toTrig . fmap (fmap toDat) + where + toTrig v = case V.toList v of + [a,b,c] -> (a,b,c) + _ -> error "Algorithms.Geometry.SSSP: Invalid triangulation." + toDat v = Index $ PlaneGraph.vtxDataToExt (trig ^. PlaneGraph.vertexDataOf v) + +-- pp :: Show a => Tree a -> IO () +-- pp = putStrLn . drawTree . fmap show + +mkDual :: Tree (Index r,Index r,Index r) -> Dual r +mkDual (Node (a,b,c) forest) = + Dual (a, b, c) + (dualTree a b forest) + (dualTree b c forest) + (dualTree c a forest) + +dualTree :: Index r -> Index r -> [Tree (Index r,Index r,Index r)] -> DualTree r +dualTree p1 p2 (Node (a,b,c) sub:xs) = + case [a,b,c] \\ [p1,p2] of + [x] -> NodeDual x (dualTree x p2 sub) (dualTree p1 x sub) + _ -> dualTree p1 p2 xs +dualTree _p1 _p2 [] = EmptyDual + + + + + +-------------------------------------------------------------------------------- +-- Helpers + +ringAccess :: Index r -> Point 2 r +ringAccess (Index (pt :+ _idx)) = pt + +isRightTurnOrLinear :: (Ord r, Num r) => Point 2 r -> Point 2 r -> Point 2 r -> Bool +isRightTurnOrLinear p1 p2 p3 = not $ isLeftTurn p1 p2 p3 + +isLeftTurnOrLinear :: (Ord r, Num r) => Point 2 r -> Point 2 r -> Point 2 r -> Bool +isLeftTurnOrLinear p1 p2 p3 = not $ isRightTurn p1 p2 p3 + +isLeftTurn :: (Ord r, Num r) => Point 2 r -> Point 2 r -> Point 2 r -> Bool +isLeftTurn p1 p2 p3 = + ccw p1 p2 p3 == CCW + +isRightTurn :: (Ord r, Num r) => Point 2 r -> Point 2 r -> Point 2 r -> Bool +isRightTurn p1 p2 p3 = + ccw p1 p2 p3 == CW diff --git a/src/Algorithms/Geometry/SSSP/Naive.hs b/src/Algorithms/Geometry/SSSP/Naive.hs new file mode 100644 --- /dev/null +++ b/src/Algorithms/Geometry/SSSP/Naive.hs @@ -0,0 +1,90 @@ +{-# LANGUAGE ParallelListComp #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Algorithms.Geometry.SSSP.Naive +-- Copyright : (C) David Himmelstrup +-- License : see the LICENSE file +-- Maintainer : David Himmelstrup +-------------------------------------------------------------------------------- +module Algorithms.Geometry.SSSP.Naive + ( sssp + , sssp' + ) where + +import Algorithms.FloydWarshall (floydWarshall, mkGraph, mkIndex) +import Control.Lens +import Control.Monad.ST (runST) +import Data.Ext (_core, core) +import qualified Data.Foldable as F +import Data.Geometry.Interval (EndPoint (Closed, Open), end, start) +import Data.Geometry.LineSegment (LineSegment (..), sqSegmentLength) +import Data.Geometry.Point (ccwCmpAroundWith') +import Data.Geometry.Polygon (SimplePolygon, listEdges, outerBoundaryVector) +import Data.Intersection (IsIntersectableWith (intersect), + NoIntersection (NoIntersection)) +import Data.Vector (Vector) +import qualified Data.Vector as V +import qualified Data.Vector.Circular as CV +import qualified Data.Vector.Unboxed as VU +import Data.Vinyl (Rec (RNil, (:&))) +import Data.Vinyl.CoRec (Handler (H), match) +import Linear.Affine ((.-.)) + +type SSSP = VU.Vector Int + +-- | \( O(n^3) \) Single-Source Shortest Path. +sssp :: (Real r, Fractional r) => SimplePolygon p r -> SSSP +sssp p = V.head . sssp' $ p + +-- | \( O(n^3) \) Single-Source Shortest Path from all vertices. +sssp' :: (Real r, Fractional r) => SimplePolygon p r -> Vector SSSP +sssp' p = runST $ do + -- Create an n*n matrix containing paths and distances between vertices. + graph <- mkGraph n infinity (visibleEdges p) + -- Use FloydWarshall O(n^3) to complete the matrix. + floydWarshall n graph + -- Create a tree describing the shortest path from any node to the 0th node. + g <- VU.unsafeFreeze graph + pure $ V.generate n $ \origin -> + VU.generate n $ \i -> + let (_dist, next) = g VU.! mkIndex n (i, origin) + in next + where + infinity = read "Infinity" :: Double + n = F.length (p ^. outerBoundaryVector) + +-- \( O(n^3) \) +visibleEdges :: (Real r, Fractional r) => SimplePolygon p r -> [(Int, Int, Double)] +visibleEdges p = concat + [ + [ (i, j, sqrt (realToFrac (sqSegmentLength line))) + | j <- [i+2 .. n-1] + , let endPt = CV.index vs j + , let line = LineSegment (Closed pt) (Open endPt) + -- Check if the line goes through the inside of the polygon. + , ccwCmpAroundWith' ((_core prev) .-. (_core pt)) pt endPt next == GT + -- Check if there are any intersections not the line end points. + , not (interiorIntersection line edges) + ] + | i <- [0 .. n-1] + , let pt = CV.index vs i + prev = CV.index vs (i-1) + next = CV.index vs (i+1) + ] ++ + [ (i,(i+1)`mod`n,sqrt (realToFrac (sqSegmentLength edge))) + | (i, edge) <- zip [0..] edges + ] + where + vs = p^.outerBoundaryVector + n = F.length vs + edges = listEdges p + +interiorIntersection :: (Ord r, Fractional r) => LineSegment 2 p r -> [LineSegment 2 p r] -> Bool +interiorIntersection _ [] = False +interiorIntersection l (x:xs) = + match (l `intersect` x) ( + H (\NoIntersection -> False) + :& H (\pt -> pt /= l^.start.core && pt /= l^.end.core) + :& H (\line -> sqSegmentLength line /= 0) + :& RNil) + || interiorIntersection l xs diff --git a/src/Algorithms/Geometry/SmallestEnclosingBall.hs b/src/Algorithms/Geometry/SmallestEnclosingBall.hs new file mode 100644 --- /dev/null +++ b/src/Algorithms/Geometry/SmallestEnclosingBall.hs @@ -0,0 +1,20 @@ +-------------------------------------------------------------------------------- +-- | +-- Module : Algorithms.Geometry.SmallestEnclosingBall +-- Copyright : (C) Frank Staals +-- License : see the LICENSE file +-- Maintainer : Frank Staals +-- +-- Types to represent the smallest enclosing disk of a set of points in +-- \(\mathbb{R}^2\) +-- +-------------------------------------------------------------------------------- +module Algorithms.Geometry.SmallestEnclosingBall + ( DiskResult(..) + , enclosingDisk + , definingPoints + , TwoOrThree(..) + , twoOrThreeFromList + ) where + +import Algorithms.Geometry.SmallestEnclosingBall.Types diff --git a/src/Algorithms/Geometry/SmallestEnclosingBall/Naive.hs b/src/Algorithms/Geometry/SmallestEnclosingBall/Naive.hs --- a/src/Algorithms/Geometry/SmallestEnclosingBall/Naive.hs +++ b/src/Algorithms/Geometry/SmallestEnclosingBall/Naive.hs @@ -9,9 +9,10 @@ -- points in \(\mathbb{R}^2\) -- -------------------------------------------------------------------------------- -module Algorithms.Geometry.SmallestEnclosingBall.Naive( smallestEnclosingDisk - , enclosesAll - ) where +module Algorithms.Geometry.SmallestEnclosingBall.Naive + ( smallestEnclosingDisk + , enclosesAll + ) where -- just for the types import Control.Lens @@ -26,7 +27,7 @@ import qualified Data.Util as Util -------------------------------------------------------------------------------- --- | Horrible O(n^4) implementation that simply tries all disks, checks if they +-- | Horrible \( O(n^4) \) implementation that simply tries all disks, checks if they -- enclose all points, and takes the largest one. Basically, this is only useful -- to check correctness of the other algorithm(s) smallestEnclosingDisk :: (Ord r, Fractional r) @@ -44,6 +45,7 @@ triplets pts = [DiskResult (disk' a b c) (Three a b c) | Util.Three a b c <- uniqueTriplets pts] +{- HLINT ignore disk' -} disk' :: (Ord r, Fractional r) => Point 2 r :+ p -> Point 2 r :+ p -> Point 2 r :+ p -> Disk () r disk' a b c = fromMaybe degen $ disk (a^.core) (b^.core) (c^.core) @@ -56,7 +58,7 @@ smallestEnclosingDisk' :: (Ord r, Num r) => [Point 2 r :+ p] -> [DiskResult p r] -> DiskResult p r smallestEnclosingDisk' pts = minimumBy (compare `on` (^.enclosingDisk.squaredRadius)) - . filter (flip enclosesAll pts) + . filter (`enclosesAll` pts) -- | check if a disk encloses all points enclosesAll :: (Num r, Ord r) => DiskResult p r -> [Point 2 r :+ q] -> Bool diff --git a/src/Algorithms/Geometry/SmallestEnclosingBall/RIC.hs b/src/Algorithms/Geometry/SmallestEnclosingBall/RIC.hs --- a/src/Algorithms/Geometry/SmallestEnclosingBall/RIC.hs +++ b/src/Algorithms/Geometry/SmallestEnclosingBall/RIC.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE TemplateHaskell #-} -------------------------------------------------------------------------------- -- | -- Module : Algorithms.Geometry.SmallestEnclosingBall.RIC @@ -31,8 +29,8 @@ import Data.Ord (comparing) import System.Random.Shuffle (shuffle) -import Data.RealNumber.Rational -import Debug.Trace +-- import Data.RealNumber.Rational +-- import Debug.Trace -------------------------------------------------------------------------------- @@ -48,8 +46,8 @@ => [Point 2 r :+ p] -> m (DiskResult p r) -smallestEnclosingDisk pts@(_:_:_) = ((\(p:q:pts') -> smallestEnclosingDisk' p q pts') - . F.toList) <$> shuffle pts +smallestEnclosingDisk pts@(_:_:_) = (\(p:q:pts') -> smallestEnclosingDisk' p q pts') + . F.toList <$> shuffle pts smallestEnclosingDisk _ = error "smallestEnclosingDisk: Too few points" -- | Smallest enclosing disk. diff --git a/src/Algorithms/Geometry/SmallestEnclosingBall/Types.hs b/src/Algorithms/Geometry/SmallestEnclosingBall/Types.hs --- a/src/Algorithms/Geometry/SmallestEnclosingBall/Types.hs +++ b/src/Algorithms/Geometry/SmallestEnclosingBall/Types.hs @@ -27,11 +27,11 @@ foldMap f (Two a b) = f a <> f b foldMap f (Three a b c) = f a <> f b <> f c - -fromList :: [a] -> Either String (TwoOrThree a) -fromList [a,b] = Right $ Two a b -fromList [a,b,c] = Right $ Three a b c -fromList _ = Left "Wrong number of elements" +-- | Construct datatype from list with exactly two or three elements. +twoOrThreeFromList :: [a] -> Either String (TwoOrThree a) +twoOrThreeFromList [a,b] = Right $ Two a b +twoOrThreeFromList [a,b,c] = Right $ Three a b c +twoOrThreeFromList _ = Left "Wrong number of elements" diff --git a/src/Algorithms/Geometry/SoS.hs b/src/Algorithms/Geometry/SoS.hs --- a/src/Algorithms/Geometry/SoS.hs +++ b/src/Algorithms/Geometry/SoS.hs @@ -22,12 +22,6 @@ import Algorithms.Geometry.SoS.Orientation import Algorithms.Geometry.SoS.Determinant import Algorithms.Geometry.SoS.Sign -import Control.CanAquire -import Control.Lens -import Data.Ext -import Data.Geometry.Point.Internal -import Data.Geometry.Properties -import Data.Geometry.Vector -------------------------------------------------------------------------------- diff --git a/src/Algorithms/Geometry/SoS/AsPoint.hs b/src/Algorithms/Geometry/SoS/AsPoint.hs --- a/src/Algorithms/Geometry/SoS/AsPoint.hs +++ b/src/Algorithms/Geometry/SoS/AsPoint.hs @@ -1,9 +1,7 @@ module Algorithms.Geometry.SoS.AsPoint where import Control.CanAquire -import Control.Lens import Data.Ext -import Data.Geometry.Point.Class import Data.Geometry.Point.Internal import Data.Geometry.Properties import Data.Geometry.Vector @@ -18,7 +16,7 @@ instance HasIndex (P i d r) i where indexOf (P i) = i -instance Int `CanAquire` (Point d r) => (P Int d r) `CanAquire` (Point d r) where +instance Int `CanAquire` Point d r => P Int d r `CanAquire` Point d r where aquire (P i) = aquire i type instance NumType (P i d r) = r @@ -26,4 +24,4 @@ asPointWithIndex :: (Arity d, i `CanAquire` Point d r) => P i d r -> Point d r :+ SoSIndex i -asPointWithIndex (P i) = aquire i :+ (SoSIndex i) +asPointWithIndex (P i) = aquire i :+ SoSIndex i diff --git a/src/Algorithms/Geometry/SoS/Expr.hs b/src/Algorithms/Geometry/SoS/Expr.hs --- a/src/Algorithms/Geometry/SoS/Expr.hs +++ b/src/Algorithms/Geometry/SoS/Expr.hs @@ -3,7 +3,6 @@ import Control.Lens import qualified Data.List as List -import Data.List.NonEmpty (NonEmpty(..),nonEmpty) -------------------------------------------------------------------------------- @@ -36,6 +35,8 @@ instance (Num r) => Num (Expr i r) where fromInteger = Constant . fromInteger + abs _ = error "'abs' not defined for Algorithms.Geometry.SoS.Expr.Expr" + signum _ = error "'signum' not defined for Algorithms.Geometry.SoS.Expr.Expr" negate = \case Negate e -> e e -> Negate e diff --git a/src/Algorithms/Geometry/SoS/Orientation.hs b/src/Algorithms/Geometry/SoS/Orientation.hs --- a/src/Algorithms/Geometry/SoS/Orientation.hs +++ b/src/Algorithms/Geometry/SoS/Orientation.hs @@ -59,7 +59,7 @@ -- | Given an input point, transform its number type to include -- symbolic $\varepsilon$ expressions so that we can use SoS. toSymbolic :: (Ord i, Arity d) => Point d r :+ i -> Point d (Symbolic (i,Int) r) -toSymbolic (p :+ i) = p&vector' %~ imap (\j x -> symbolic x (i,j)) +toSymbolic (p :+ i) = p&vector %~ imap (\j x -> symbolic x (i,j)) -- | Given a point q and a vector of d points defining a hyperplane, -- test on which side of the hyperplane q lies. @@ -80,4 +80,4 @@ -- in a homogeneous matrix represetnation. I.e. we add a 1 as an -- additonal column at the end. mkLambdaRow :: (Num r, Arity d, Arity (d+1)) => Point d r -> Vector (d+1) r -mkLambdaRow = flip snoc 1 . view vector' +mkLambdaRow = flip snoc 1 . view vector diff --git a/src/Algorithms/Geometry/SoS/Sign.hs b/src/Algorithms/Geometry/SoS/Sign.hs --- a/src/Algorithms/Geometry/SoS/Sign.hs +++ b/src/Algorithms/Geometry/SoS/Sign.hs @@ -8,6 +8,7 @@ -- | The sign of an expression data Sign = Negative | Positive deriving (Show,Eq,Ord,Enum,Bounded) +-- | Flip Positive <=> Negative. flipSign :: Sign -> Sign flipSign = \case Negative -> Positive diff --git a/src/Algorithms/Geometry/SoS/Symbolic.hs b/src/Algorithms/Geometry/SoS/Symbolic.hs --- a/src/Algorithms/Geometry/SoS/Symbolic.hs +++ b/src/Algorithms/Geometry/SoS/Symbolic.hs @@ -1,3 +1,11 @@ +-------------------------------------------------------------------------------- +-- | +-- Module : Algorithms.Geometry.SoS.Symbolic +-- Copyright : (C) Frank Staals +-- License : see the LICENSE file +-- Maintainer : Frank Staals +-- +-------------------------------------------------------------------------------- module Algorithms.Geometry.SoS.Symbolic( EpsFold , eps, mkEpsFold @@ -21,8 +29,7 @@ import qualified Data.Map as Map import qualified Data.Map.Merge.Strict as Map import Data.Maybe (isNothing) -import Data.Word -import Test.QuickCheck (Arbitrary(..), listOf, suchThat) +import Test.QuickCheck (Arbitrary(..), listOf) import Test.QuickCheck.Instances () -------------------------------------------------------------------------------- @@ -150,7 +157,7 @@ -- biggest of those terms is the pair whose indices comes first. instance (Arbitrary i, Ord i) => Arbitrary (EpsFold i) where - arbitrary = (mkEpsFold . take 4) <$> listOf arbitrary + arbitrary = mkEpsFold . take 4 <$> listOf arbitrary -- | Test if the epsfold has no pertubation at all (i.e. if it is \(\Pi_{\emptyset}\) @@ -332,7 +339,7 @@ (Bag m) <> (Bag m') = Bag $ Map.unionWith (\d d' -> d + d' + 1) m m' instance Ord k => Monoid (Bag k) where - mempty = Bag $ Map.empty + mempty = Bag Map.empty -- | Computes the difference of the two maps difference :: Ord a => Bag a -> Bag a -> Bag a diff --git a/src/Algorithms/Geometry/VisibilityPolygon/Lee.hs b/src/Algorithms/Geometry/VisibilityPolygon/Lee.hs new file mode 100644 --- /dev/null +++ b/src/Algorithms/Geometry/VisibilityPolygon/Lee.hs @@ -0,0 +1,537 @@ +{-# LANGUAGE TemplateHaskell #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Algorithms.Geometry.VisibilityPolygon.Lee +-- Copyright : (C) Frank Staals +-- License : see the LICENSE file +-- Maintainer : Frank Staals +-- +-- \(O(n\log n)\) time algorithm to compute the visibility polygon of +-- a point inside a polygon (possibly containing holes) with \(n\) +-- vertices, or among a set of \(n\) disjoint segments. The alogirhtm +-- used is the the rotational sweepline algorithm by Lee, described +-- in: +-- +-- D. T. Lee. Proximity and reachability in the plane. Report R-831, Dept. Elect. +-- Engrg., Univ. Illinois, Urbana, IL, 1978. +-- +-------------------------------------------------------------------------------- +module Algorithms.Geometry.VisibilityPolygon.Lee + ( visibilityPolygon + , visibilitySweep + , VisibilityPolygon + , Definer, StarShapedPolygon + , compareAroundEndPoint + ) where + +import Control.Lens +import Control.Monad ((<=<)) +import Data.Bifunctor (first) +import Data.Ext +import qualified Data.Foldable as F +import Data.Function (on) +import Data.Geometry.HalfLine +import Data.Geometry.Line +import Data.Geometry.LineSegment +import Data.Geometry.Point +import Data.Geometry.Polygon +import Data.Geometry.Vector +import Data.Intersection +import qualified Data.List as List +import qualified Data.List.Util as List +import Data.List.NonEmpty (NonEmpty(..)) +import qualified Data.List.NonEmpty as NonEmpty +import Data.Maybe (mapMaybe, isJust) +import Data.Ord (comparing) +import Data.RealNumber.Rational +import Data.Semigroup.Foldable +import qualified Data.Set as Set +import qualified Data.Set.Util as Set +import Data.Util +import Data.Vinyl.CoRec +import Debug.Trace + +type R = RealNumber 5 + +-------------------------------------------------------------------------------- + +type StarShapedPolygon p r = SimplePolygon p r + +-- | Vertices of the visibility polgyon are either original vertices +-- or defined by some vertex and an edge +type Definer p e r = Either p (Point 2 r :+ p,LineSegment 2 p r :+ e) + +type VisibilityPolygon p e r = StarShapedPolygon (Definer p e r) r + +-- | We either insert or delete segments +data Action a = Insert a | Delete a deriving (Show,Eq,Ord) + +isInsert :: Action a -> Bool +isInsert = \case + Insert _ -> True + Delete _ -> False + +extract :: Action a -> a +extract = \case + Insert x -> x + Delete x -> x + +-- | An event corresponds to some orientation at which the set of segments +-- intersected by the ray changes (this orientation is defined by a point) +data Event p e r = Event { _eventVtx :: Point 2 r :+ p + , _actions :: NonEmpty (Action (LineSegment 2 p r :+ e)) + } deriving Show +makeLenses ''Event + +-- | The status structure maintains the subset of segments currently +-- intersected by the ray that starts in the query point q, in order +-- of increasing distance along the ray. +type Status p e r = Set.Set (LineSegment 2 p r :+ e) + + + +-------------------------------------------------------------------------------- + + + + +-- | Computes the visibility polygon of a point q in a polygon with +-- \(n\) vertices. +-- +-- pre: q lies strictly inside the polygon +-- +-- running time: \(O(n\log n)\) +visibilityPolygon :: forall p t r. (Ord r, Fractional r) + => Point 2 r + -> Polygon t p r + -> StarShapedPolygon (Definer p () r) r +visibilityPolygon q pg = + fromPoints . visibilitySweep v Nothing q . map ext . closedEdges $ pg + where + v = uncurry (startingDirection q) . consecutive q . polygonVertices $ pg + + + + + + + + + + + + + + + + + + + + + + + +-- | Computes the visibility polgyon from a vertex +visibilityPolygonFromVertex :: forall p t r. (Ord r, Fractional r, Show r, Show p) + => Polygon t p r + -> Int -- ^ from the i^th vertex on the outer boundary + -> VisibilityPolygon p () r +visibilityPolygonFromVertex pg i = + fromPoints . visibilitySweep sv (Just w) v . map ext $ segs + where + (v :+ _) = pg^.outerVertex i + (w :+ _) = pg^.outerVertex (i-1) + (u :+ _) = pg^.outerVertex (i+1) + + -- rotates the polygon so that u becomes the focus, and gets all + -- other vertices. Takes the next CCW vertex around v, starting + -- form the direction indicated by v. + z = let u' :| rest = traceShowIdWith "vertices" + $ polygonVertices $ pg&outerBoundary %~ rotateRight (i+1) + in traceShowIdWith "z" $ consecutiveFrom (u .-. v) v (List.init rest) + -- the last vertex in rest is v; so kill that + + sv = startingDirection v u z + + segs = map (first (^._2)) + . filter (not . incidentTo i) + . closedEdges $ numberVertices pg + +visibilityPolygonFromVertex' q sv mt segs = sweep q statusStruct (traceShowIdWith "events" events) + where + v = undefined + + -- lazily test if the segment intersects the initial ray + segs' = labelWithDistances q initialRay segs + + events = computeEvents q sv (untilEnd q sv mt) segs' + -- take only until the end of the range (if defined) + + initialRay = traceShowIdWith "ray" $ HalfLine q sv + statusStruct = traceShowIdWith "initialSS" $ mkInitialSS segs' + + +-- | Test if the line segment is incident to a point with the given +-- index. +incidentTo :: Int -> LineSegment 2 (SP Int a) r -> Bool +incidentTo i s = s^.start.extra._1 == i || s^.end.extra._1 == i + + + + + + + + + +-- | computes a (partial) visibility polygon of a set of \(n\) +-- disjoint segments. The input segments are allowed to share +-- endpoints, but no intersections or no endpoints in the interior of +-- other segments. The input vector indicates the starting direction, +-- the Maybe point indicates up to which point/dicrection (CCW) of the +-- starting vector we should compute the visibility polygon. +-- +-- pre : - all line segments are considered closed. +-- - no singleton linesegments exactly pointing away from q. +-- - for every orientattion the visibility is blocked somewhere, i.e. +-- no rays starting in the query point q that are disjoint from all segments. +-- - no vertices at staring direction sv +-- +-- running time: \(O(n\log n)\) +visibilitySweep :: forall p r e. (Ord r, Fractional r) + => Vector 2 r -- ^ starting direction of the sweep + -> Maybe (Point 2 r) + -- ^ -- point indicating the last point to sweep to + -> Point 2 r -- ^ the point form which we compute the visibility polgyon + -> [LineSegment 2 p r :+ e] + -> [Point 2 r :+ Definer p e r] +visibilitySweep sv mt q segs = sweep q statusStruct events + where + -- lazily test if the segment intersects the initial ray + segs' = labelWithDistances q initialRay segs + events = computeEvents q sv (untilEnd q sv mt) segs' + + initialRay = HalfLine q sv + statusStruct = mkInitialSS segs' + +-- | Take until the ending point if defined. We can use that the list +-- of events appears in sorted order in the cyclic orientation around +-- the query point q +untilEnd :: (Ord r, Num r) + => Point 2 r -- ^ query point + -> Vector 2 r -- ^ starting direction + -> Maybe (Point 2 r) -- ^ possible ending point + -> [Event a e r] -> [Event a e r] +untilEnd q sv = \case + Nothing -> id + Just t -> List.takeWhile (\e -> ccwCmpAroundWith' sv (ext q) (e^.eventVtx) (ext t) == LT) + +-- | Runs the actual sweep +sweep :: (Foldable t, Ord r, Fractional r) + => Point 2 r -- ^ query point + -> Status p e r -- ^ initial status structure + -> t (Event p e r) -- ^ events to handle + -> [Point 2 r :+ Definer p e r] +sweep q statusStruct = snd . List.foldl' (handleEvent q) (statusStruct,[]) + + +-- | Computes the events in the sweep +computeEvents :: (Ord r, Num r, Foldable t) + => Point 2 r -- ^ query point + -> Vector 2 r -- ^ starting direction + -> ([Event p1 e1 r] -> [Event p2 e2 r]) -- ^ until where to take the vents + -> t (LineSegment 2 p1 r :+ (Maybe r, e1)) + -> [Event p2 e2 r] +computeEvents q sv takeUntil = + map (combine q) + . List.groupBy' (\a b -> ccwCmpAroundWith' sv (ext q) (a^.eventVtx) (b^.eventVtx)) + . takeUntil + . List.sortBy (cmp `on` (^.eventVtx)) + . concatMap (mkEvent sv q) + where + cmp = ccwCmpAroundWith' sv (ext q) <> cmpByDistanceTo' (ext q) + +-- | Given multiple events happening at the same orientation, combine +-- them into a single event. +combine :: (Ord r, Num r) => Point 2 r -> NonEmpty (Event p e r) -> Event p e r +combine q es = Event p acts + where + acts = foldMap1 (^.actions) es + p = F.minimumBy (cmpByDistanceTo' (ext q)) . fmap (^.eventVtx) $ es + +-- | Constructs the at most two events resulting from this segement. +mkEvent :: (Ord r, Num r) + => Vector 2 r -- ^ starting direction + -> Point 2 r -- ^ query point + -> LineSegment 2 p r :+ (Maybe r, e) + -> [Event p e r] +mkEvent sv q (s@(LineSegment' u v) :+ (d,e)) = case cmp u v of + LT -> [ Event u insert + , Event v delete + ] + GT -> [ Event v insert + , Event u delete + ] + EQ -> [] -- zero length segment, just skip + where + cmp = ccwCmpAroundWith' sv (ext q) <> cmpByDistanceTo' (ext q) + s' = s :+ e + + insert = (if isJust d then Delete s' else Insert s') :| [] + delete = (if isJust d then Insert s' else Delete s') :| [] + + +-- | Handles an event, computes the new status structure and output polygon. +handleEvent :: (Ord r, Fractional r) + => Point 2 r + -> (Status p e r, [Point 2 r :+ Definer p e r]) + -> Event p e r + -> (Status p e r, [Point 2 r :+ Definer p e r]) +handleEvent q (ss,out) (Event (p :+ z) acts) = (ss', newVtx <> out) + where + (ins,dels) = bimap (map extract) (map extract) . NonEmpty.partition isInsert $ acts + + ss' = flip (foldr (insertAt q p)) ins + . flip (foldr (deleteAt q p)) dels + $ ss + + newVtx = let (a :+ sa) = firstHitAt' q p ss + (b :+ sb) = firstHitAt' q p ss' + ae = valOf a sa + be = valOf b sb + in case (a /= b, a == p) of + (True, _) -> -- new window of the output polygon discovered + -- figure out who is the closest vertex, (the reflex vtx) + -- and add the appropriate two vertices + case squaredEuclideanDist q a < squaredEuclideanDist q b of + True -> [ b :+ Right (a :+ ae, sb) + , a :+ Left ae -- a must be a vertex! + ] + False -> [ b :+ Left be + , a :+ Right (b :+ be, sa) + ] + (False,True) -> [ p :+ Left z] + -- sweeping over a regular vertex of the visibility polygon + (False,False) -> [] -- sweeping over a vertex not in output + + valOf a (LineSegment' (b :+ be) (_ :+ ce) :+ _ ) | a == b = be + | otherwise = ce + + + +-------------------------------------------------------------------------------- + +-- | Given two points q and p, and a status structure retrieve the +-- first segment in the status structure intersected by the ray from q +-- through p. +-- +-- pre: all segments in the status structure should intersect the ray +-- from q through p (in a point), in that order. +-- +-- running time: \(O(\log n)\) +firstHitAt :: forall p r e. (Ord r, Fractional r) + => Point 2 r -> Point 2 r + -> Status p e r + -> Maybe (Point 2 r :+ LineSegment 2 p r :+ e) +firstHitAt q p = computeIntersectionPoint <=< Set.lookupMin + where + computeIntersectionPoint s = fmap (:+ s) . asA @(Point 2 r) + $ supportingLine (s^.core) `intersect` lineThrough p q + +-- | Given two points q and p, and a status structure retrieve the +-- first segment in the status structure intersected by the ray from q +-- through p. +-- +-- pre: - all segments in the status structure should intersect the ray +-- from q through p (in a point), in that order. +-- - the status structure is non-empty +-- +-- running time: \(O(\log n)\) +firstHitAt' :: forall p r e. (Ord r, Fractional r) + => Point 2 r -> Point 2 r + -> Status p e r + -> Point 2 r :+ LineSegment 2 p r :+ e +firstHitAt' q p s = case firstHitAt q p s of + Just x -> x + Nothing -> error "firstHitAt: precondition failed!" + +-------------------------------------------------------------------------------- +-- * Status Structure Operations + +-- | Insert a new segment into the status structure, depending on the +-- (distance from q to to the) intersection point with the ray from q +-- through p +-- +-- pre: all segments in the status structure should intersect the ray +-- from q through p, in that order. +-- +-- \(O(\log n)\) +insertAt :: (Ord r, Fractional r) + => Point 2 r -> Point 2 r -> LineSegment 2 p r :+ e + -> Status p e r -> Status p e r +insertAt q p = Set.insertBy (compareByDistanceToAt q p <> flip (compareAroundEndPoint q)) + -- if two segments have the same distance, they must share and endpoint + -- so we use the CCW ordering around this common endpoint to determine + -- the order. + +-- | Delete a segment from the status structure, depending on the +-- (distance from q to to the) intersection point with the ray from q +-- through p +-- +-- pre: all segments in the status structure should intersect the ray +-- from q through p, in that order. +-- +-- \(O(\log n)\) +deleteAt :: (Ord r, Fractional r) + => Point 2 r -> Point 2 r -> LineSegment 2 p r :+ e + -> Status p e r -> Status p e r +deleteAt q p = Set.deleteAllBy (compareByDistanceToAt q p <> compareAroundEndPoint q) + -- if two segments have the same distance, we use the ccw order around their common + -- (end) point. + +-- FIXME: If there are somehow segmetns that would continue at p as +-- well, they are also deleted. + + +-- | Given a list of line segments, each labeled with the distance +-- from their intersection point with the initial ray to the query +-- point, build the initial status structure. +mkInitialSS :: forall r p e. (Ord r, Fractional r) + => [ LineSegment 2 p r :+ (Maybe r, e)] -> Status p e r +mkInitialSS = Set.mapMonotonic (^.extra) + . foldr (Set.insertBy $ comparing (^.core)) Set.empty + . mapMaybe (\(s :+ (md,e)) -> (:+ (s :+ e)) <$> md) + +-- | Given q, the initial ray, and a segment s, computes if the +-- segment intersects the initial, rightward ray starting in q, and if +-- so returns the (squared) distance from q to that point together +-- with the segment. +initialIntersection :: forall r p. (Ord r, Fractional r) + => Point 2 r -> HalfLine 2 r -> LineSegment 2 p r + -> Maybe r +initialIntersection q ray s = + case asA @(Point 2 r) $ seg `intersect` ray of + Nothing -> Nothing + Just z -> Just $ squaredEuclideanDist q z + where + seg = first (const ()) s + +-- | Labels the segments with the distance from q to their +-- intersection point with the ray. +labelWithDistances :: (Ord r, Fractional r) + => Point 2 r -> HalfLine 2 r -> [LineSegment 2 p r :+ b] + -> [LineSegment 2 p r :+ (Maybe r, b)] +labelWithDistances q ray = map (\(s :+ e) -> s :+ (initialIntersection q ray s, e)) + +-------------------------------------------------------------------------------- +-- * Comparators for the rotating ray + +-- | Given two points q and p, and two segments a and b that are guaranteed to +-- intersect the ray from q through p once, order the segments by their +-- intersection point +compareByDistanceToAt :: forall p r e. (Ord r, Fractional r) + => Point 2 r -> Point 2 r + -> LineSegment 2 p r :+ e + -> LineSegment 2 p r :+ e + -> Ordering +compareByDistanceToAt q p = comparing f + where + f (s :+ _) = fmap (squaredEuclideanDist q) + . asA @(Point 2 r) + $ supportingLine s `intersect` lineThrough p q + +-- | Given two segments that share an endpoint, order them by their +-- order around this common endpoint. I.e. if uv and uw share endpoint +-- u we uv is considered smaller iff v is smaller than w in the +-- counterclockwise order around u (treating the direction from q to +-- the common endpoint as zero). +compareAroundEndPoint :: forall p r e. (Ord r, Fractional r) + => Point 2 r + -> LineSegment 2 p r :+ e + -> LineSegment 2 p r :+ e + -> Ordering +compareAroundEndPoint q + (LineSegment' a b :+ _) + (LineSegment' s t :+ _) + -- traceshow ("comapreAroundEndPoint ", sa, sb) False = undefined + | a^.core == s^.core = ccwCmpAroundWith' (a^.core .-. q) a b t + | a^.core == t^.core = ccwCmpAroundWith' (a^.core .-. q) a b s + | b^.core == s^.core = ccwCmpAroundWith' (b^.core .-. q) b a t + | b^.core == t^.core = ccwCmpAroundWith' (b^.core .-. q) b a s + | otherwise = error "compareAroundEndPoint: precondition failed!" + +-------------------------------------------------------------------------------- +-- * Helper functions for polygon operations + +-- | Given q, and two consecutive points u and v, Computes a direction +-- for the initial ray, i.e. a "generic" ray that does not go through +-- any vertices. +startingDirection :: Fractional r => Point 2 r -> Point 2 r -> Point 2 r -> Vector 2 r +startingDirection q u w = v .-. q + where + v = u .+^ ((w .-. u) ^/ 2) -- point in the middle between u and w + -- note: the segment between u and w could pass on the wrong side of q + -- (i.e. so that does not "cover" the CCW but the CW range between u and w) + -- however, in that case there is apparently nothing on the CCW side opposite + -- to v, as u and w are supposed to be the first two events. This means the + -- precondition does not hold. + +-- | finds two consecutive vertices in the clockwise order around the +-- given point q. I.e. there are no other points in between the two +-- returned points. +consecutive :: (Ord r, Num r) => Point 2 r -> NonEmpty (Point 2 r :+ p) + -> (Point 2 r, Point 2 r) +consecutive q ((p :+ _):|pts) = (p,consecutiveFrom (p .-. q) q pts) + +-- | pre: input list is non-empty +consecutiveFrom :: (Ord r, Num r) + => Vector 2 r -- ^ starting vector + -> Point 2 r -- ^ query point + -> [Point 2 r :+ p] -> Point 2 r +consecutiveFrom v q = view core . List.minimumBy (ccwCmpAroundWith' v (ext q)) + +-- | Gets the edges of the polygon as closed line segments. +closedEdges :: Polygon t p r -> [LineSegment 2 p r] +closedEdges = map asClosed . listEdges + where + asClosed (LineSegment' u v) = ClosedLineSegment u v + + +-------------------------------------------------------------------------------- +-- * Generic Helper functions + + + +-------------------------------------------------------------------------------- + +test :: StarShapedPolygon (Definer Int () R) R +test = visibilityPolygon origin testPg + +testVtx = visibilityPolygonFromVertex testPg 0 + +testPg :: SimplePolygon Int R +testPg = fromPoints $ zipWith (:+) [ Point2 3 1 + , Point2 3 2 + , Point2 4 2 + , Point2 2 4 + , Point2 (-1) 4 + , Point2 1 2 + , Point2 (-3) (-1) + , Point2 4 (-1) + ] [1..] + +testPg2 :: SimplePolygon Int R +testPg2 = fromPoints $ zipWith (:+) [ Point2 3 1 + , Point2 3 2 + , Point2 4 2 + , Point2 2 4 + , Point2 (-1) 4 + , Point2 1 2.1 + , Point2 (-3) (-1) + , Point2 4 (-1) + ] [1..] + + + +traceShowIdWith x y = traceShow (show x,y) y diff --git a/src/Algorithms/Geometry/WSPD.hs b/src/Algorithms/Geometry/WSPD.hs new file mode 100644 --- /dev/null +++ b/src/Algorithms/Geometry/WSPD.hs @@ -0,0 +1,474 @@ +-------------------------------------------------------------------------------- +-- | +-- Module : Algorithms.Geometry.WSPD +-- Copyright : (C) Frank Staals +-- License : see the LICENSE file +-- Maintainer : Frank Staals +-- +-- Algorithm to construct a well separated pair decomposition (wspd). +-- +-------------------------------------------------------------------------------- +module Algorithms.Geometry.WSPD + ( fairSplitTree + , wellSeparatedPairs + , NodeData(NodeData) + , WSP + , SplitTree + , nodeData + , Level(..) + , reIndexPoints + , distributePoints + , distributePoints' + ) where + +import Algorithms.Geometry.WSPD.Types +import Control.Lens hiding (Level, levels) +import Control.Monad.Reader +import Control.Monad.ST (ST,runST) +import Data.BinaryTree +import Data.Ext +import qualified Data.Foldable as F +import Data.Geometry.Box +import Data.Geometry.Point +-- import Data.Geometry.Properties +-- import Data.Geometry.Transformation +import Data.Geometry.Vector +import qualified Data.Geometry.Vector as GV +import qualified Data.IntMap.Strict as IntMap +import qualified Data.LSeq as LSeq +import Data.LSeq (LSeq, toSeq,pattern (:<|)) +import qualified Data.List as L +import qualified Data.List.NonEmpty as NonEmpty +import Data.Maybe +import Data.Ord (comparing) +import Data.Range +import qualified Data.Range as Range +import qualified Data.Sequence as S +import qualified Data.Vector as V +import qualified Data.Vector.Mutable as MV +import GHC.TypeLits + +-- import Debug.Trace + +-------------------------------------------------------------------------------- + +-- | Construct a split tree +-- +-- running time: \(O(n \log n)\) +fairSplitTree :: (Fractional r, Ord r, Arity d, 1 <= d + , Show r, Show p + ) + => NonEmpty.NonEmpty (Point d r :+ p) -> SplitTree d p r () +fairSplitTree pts = foldUp node' Leaf $ fairSplitTree' n pts' + where + pts' = imap sortOn . pure . g $ pts + n = length $ pts'^.GV.element (C :: C 0) + + sortOn' i = NonEmpty.sortWith (^.core.unsafeCoord i) + sortOn i = LSeq.fromNonEmpty . sortOn' (i + 1) + -- sorts the points on the first coordinate, and then associates each point + -- with an index,; its rank in terms of this first coordinate. + g = NonEmpty.zipWith (\i (p :+ e) -> p :+ (i :+ e)) (NonEmpty.fromList [0..]) + . sortOn' 1 + + -- node' :: b -> a -> b -> b + -- node' :: SplitTree d p r () -> Int -> SplitTree d p r () -> SplitTree d p r () + node' l j r = Node l (NodeData j (bbOf l <> bbOf r) ()) r + + +-- | Given a split tree, generate the Well separated pairs +-- +-- running time: \(O(s^d n)\) +wellSeparatedPairs :: (Floating r, Ord r, Arity d, Arity (d + 1)) + => r -> SplitTree d p r a -> [WSP d p r a] +wellSeparatedPairs s = f + where + f (Leaf _) = [] + f (Node l _ r) = findPairs s l r ++ f l ++ f r + + + +-- -- | Given a split tree, generate the well separated pairs such that one set is +-- -- a singleton. +-- -- running time: \(O(s^d n\log n)\) +-- wellSeparatedPairSingletons :: (Fractional r, Ord r, AlwaysTrueWSPD d) +-- => r -> SplitTree d p r a -> [(Point d r :+ p, PointSet d p r (Sized a))] +-- wellSeparatedPairSingletons s t = concatMap split $ wellSeparatedPairs s t' +-- where +-- split (l,r) = undefined +-- -- | measure l <= measure r = map (,r) $ F.toList l +-- -- | otherwise = map (,l) $ F.toList r +-- t' = foldUpData (\l nd r -> ) + +-- t + + +-------------------------------------------------------------------------------- +-- * Building the split tree + +-- | Given the points, sorted in every dimension, recursively build a split tree +-- +-- The algorithm works in rounds. Each round takes \( O(n) \) time, and halves the +-- number of points. Thus, the total running time is \( O(n log n) \). +-- +-- The algorithm essentially builds a path in the split tree; at every node on +-- the path that we construct, we split the point set into two sets (L,R) +-- according to the longest side of the bounding box. +-- +-- The smaller set is "assigned" to the current node and set asside. We +-- continue to build the path with the larger set until the total number of +-- items remaining is less than n/2. +-- +-- To start the next round, each node on the path needs to have the points +-- assigned to that node, sorted in each dimension (i.e. the Vector +-- (PointSeq))'s. Since we have the level assignment, we can compute these +-- lists by traversing each original input list (i.e. one for every dimension) +-- once, and partition the points based on their level assignment. +fairSplitTree' :: (Fractional r, Ord r, Arity d, 1 <= d + , Show r, Show p + ) + => Int -> GV.Vector d (PointSeq d (Idx :+ p) r) + -> BinLeafTree Int (Point d r :+ p) +fairSplitTree' n pts + | n <= 1 = let p = LSeq.head $ pts^.GV.element (C :: C 0) in Leaf (dropIdx p) + | otherwise = foldr node' (V.last path) $ V.zip nodeLevels (V.init path) + where + -- note that points may also be assigned level 'Nothing'. + (levels, nodeLevels'@(maxLvl NonEmpty.:| _)) = runST $ do + lvls <- MV.replicate n Nothing + ls <- runReaderT (assignLevels (n `div` 2) 0 pts (Level 0 Nothing) []) lvls + lvls' <- V.unsafeFreeze lvls + pure (lvls',ls) + + -- TODO: We also need to report the levels in the order in which they are + -- assigned to nodes + + nodeLevels = V.fromList . L.reverse . NonEmpty.toList $ nodeLevels' + + -- levels = traceShow ("Levels",levels',maxLvl) levels' + + -- path = traceShow ("path", path',nodeLevels) path' + distrPts = distributePoints (1 + maxLvl^.unLevel) levels pts + + path = recurse <$> distrPts -- (traceShow ("distributed pts",distrPts) distrPts) + + -- node' (lvl,lc) rc | traceShow ("node' ",lvl,lc,rc) False = undefined + node' (lvl,lc) rc = case lvl^?widestDim._Just of + Nothing -> error "Unknown widest dimension" + Just j -> Node lc j rc + recurse pts' = fairSplitTree' (length $ pts'^.GV.element (C :: C 0)) + (reIndexPoints pts') + +-- | Assign the points to their the correct class. The 'Nothing' class is +-- considered the last class +distributePoints :: (Arity d , Show r, Show p) + => Int -> V.Vector (Maybe Level) + -> GV.Vector d (PointSeq d (Idx :+ p) r) + -> V.Vector (GV.Vector d (PointSeq d (Idx :+ p) r)) +distributePoints k levels = transpose . fmap (distributePoints' k levels) + +transpose :: Arity d => GV.Vector d (V.Vector a) -> V.Vector (GV.Vector d a) +transpose = V.fromList . map GV.vectorFromListUnsafe . L.transpose + . map V.toList . F.toList + +-- | Assign the points to their the correct class. The 'Nothing' class is +-- considered the last class +distributePoints' :: Int -- ^ number of classes + -> V.Vector (Maybe Level) -- ^ level assignment + -> PointSeq d (Idx :+ p) r -- ^ input points + -> V.Vector (PointSeq d (Idx :+ p) r) +distributePoints' k levels pts + = fmap fromSeqUnsafe $ V.create $ do + v <- MV.replicate k mempty + forM_ pts $ \p -> + append v (level p) p + pure v + where + level p = maybe (k-1) _unLevel $ levels V.! (p^.extra.core) + append v i p = MV.read v i >>= MV.write v i . (S.|> p) + +fromSeqUnsafe :: S.Seq a -> LSeq n a +fromSeqUnsafe = LSeq.promise . LSeq.fromSeq + +-- | Given a sequence of points, whose index is increasing in the first +-- dimension, i.e. if idx p < idx q, then p[0] < q[0]. +-- Reindex the points so that they again have an index +-- in the range [0,..,n'], where n' is the new number of points. +-- +-- running time: O(n' * d) (more or less; we are actually using an intmap for +-- the lookups) +-- +-- alternatively: I can unsafe freeze and thaw an existing vector to pass it +-- along to use as mapping. Except then I would have to force the evaluation +-- order, i.e. we cannot be in 'reIndexPoints' for two of the nodes at the same +-- time. +-- +-- so, basically, run reIndex points in ST as well. +reIndexPoints :: (Arity d, 1 <= d) + => GV.Vector d (PointSeq d (Idx :+ p) r) + -> GV.Vector d (PointSeq d (Idx :+ p) r) +reIndexPoints ptsV = fmap reIndex ptsV + where + pts = ptsV^.GV.element (C :: C 0) + + reIndex = fmap (\p -> p&extra.core %~ fromJust . flip IntMap.lookup mapping') + mapping' = IntMap.fromAscList $ zip (map (^.extra.core) . F.toList $ pts) [0..] + +-- | ST monad with access to the vector storign the level of the points. +type RST s = ReaderT (MV.MVector s (Maybe Level)) (ST s) + +{- HLINT ignore assignLevels -} +-- | Assigns the points to a level. Returns the list of levels used. The first +-- level in the list is the level assigned to the rest of the nodes. Their +-- level is actually still set to Nothing in the underlying array. +assignLevels :: (Fractional r, Ord r, Arity d + , Show r, Show p + ) + => Int -- ^ Number of items we need to collect + -> Int -- ^ Number of items we collected so far + -> GV.Vector d (PointSeq d (Idx :+ p) r) + -> Level -- ^ next level to use + -> [Level] -- ^ Levels used so far + -> RST s (NonEmpty.NonEmpty Level) +assignLevels h m pts l prevLvls + | m >= h = pure (l NonEmpty.:| prevLvls) + | otherwise = do + pts' <- compactEnds pts + -- find the widest dimension j = i+1 + let j = widestDimension pts' + i = j - 1 -- traceShow ("i",j,pts') j - 1 + extJ = (extends pts')^.ix' i + mid = midPoint extJ + + -- find the set of points that we have to delete, by looking at the sorted + -- list L_j. As a side effect, this will remove previously assigned points + -- from L_j. + (lvlJPts,deletePts) <- findAndCompact j (pts'^.ix' i) mid + let pts'' = pts'&ix' i .~ lvlJPts + l' = l&widestDim ?~ j + forM_ deletePts $ \p -> + assignLevel p l' + assignLevels h (m + length deletePts) pts'' (nextLevel l) (l' : prevLvls) + +-- | Remove already assigned pts from the ends of all vectors. +compactEnds :: Arity d + => GV.Vector d (PointSeq d (Idx :+ p) r) + -> RST s (GV.Vector d (PointSeq d (Idx :+ p) r)) +compactEnds = traverse compactEnds' + +-- | Assign level l to point p +assignLevel :: (c :+ (Idx :+ p)) -> Level -> RST s () +assignLevel p l = ask >>= \levels -> lift $ MV.write levels (p^.extra.core) (Just l) + +-- | Get the level of a point +levelOf :: (c :+ (Idx :+ p)) -> RST s (Maybe Level) +levelOf p = ask >>= \levels -> lift $ MV.read levels (p^.extra.core) + +-- | Test if the point already has a level assigned to it. +hasLevel :: c :+ (Idx :+ p) -> RST s Bool +hasLevel = fmap isJust . levelOf + +-- | Remove allready assigned points from the sequence +-- +-- pre: there are points remaining +compactEnds' :: PointSeq d (Idx :+ p) r + -> RST s (PointSeq d (Idx :+ p) r) +compactEnds' (l0 :<| s0) = fmap fromSeqUnsafe . goL $ l0 S.<| toSeq s0 + where + goL s@(S.viewl -> l S.:< s') = hasLevel l >>= \case + False -> goR s + True -> goL s' + goL _ = error "Unreachable, but cannot prove it in Haskell" + goR s@(S.viewr -> s' S.:> r) = hasLevel r >>= \case + False -> pure s + True -> goR s' + goR _ = error "Unreachable, but cannot prove it in Haskell" + + +-- | Given the points, ordered by their j^th coordinate, split the point set +-- into a "left" and a "right" half, i.e. the points whose j^th coordinate is +-- at most the given mid point m, and the points whose j^th coordinate is +-- larger than m. +-- +-- We return a pair (Largest set, Smallest set) +-- +-- +--fi ndAndCompact works by simultaneously traversing the points from left to +-- right, and from right to left. As soon as we find a point crossing the mid +-- point we stop and return. Thus, in principle this takes only O(|Smallest +-- set|) time. +-- +-- running time: O(|Smallest set|) + R, where R is the number of *old* points +-- (i.e. points that should have been removed) in the list. +findAndCompact :: (Ord r, Arity d + , Show r, Show p + ) + => Int + -- ^ the dimension we are in, i.e. so that we know + -- which coordinate of the point to compare + -> PointSeq d (Idx :+ p) r + -> r -- ^ the mid point + -> RST s ( PointSeq d (Idx :+ p) r + , PointSeq d (Idx :+ p) r + ) +findAndCompact j (l0 :<| s0) m = fmap select . stepL $ l0 S.<| toSeq s0 + where + -- stepL and stepR together build a data structure (FAC l r S) that + -- contains the left part of the list, i.e. the points before midpoint, and + -- the right part of the list., and a value S that indicates which part is + -- the short side. + + -- stepL takes a step on the left side of the list; if the left point l + -- already has been assigned, we continue waling along (and "ignore" the + -- point). If it has not been assigned, and is before the mid point, we + -- take a step from the right, and add l onto the left part. If it is + -- larger than the mid point, we have found our split. + -- stepL :: S.Seq (Point d r :+ (Idx :+ p)) -> ST s (FindAndCompact d r (Idx :+ p)) + stepL s = case S.viewl s of + S.EmptyL -> pure $ FAC mempty mempty L + l S.:< s' -> hasLevel l >>= \case + False -> if l^.core.unsafeCoord j <= m + then addL l <$> stepR s' + else pure $ FAC mempty s L + True -> stepL s' -- delete, continue left + + -- stepR :: S.Seq (Point d r :+ (Idx :+ p)) -> ST s (FindAndCompact d r (Idx :+ p)) + stepR s = case S.viewr s of + S.EmptyR -> pure $ FAC mempty mempty R + s' S.:> r -> hasLevel r >>= \case + False -> if r^.core.unsafeCoord j >= m + then addR r <$> stepL s' + else pure $ FAC s mempty R + True -> stepR s' + + + addL l x = x&leftPart %~ (l S.<|) + addR r x = x&rightPart %~ (S.|> r) + + select = over both fromSeqUnsafe . select' + + -- select' f | traceShow ("select'", f) False = undefined + select' (FAC l r L) = (r, l) + select' (FAC l r R) = (l, r) + + +-- | Find the widest dimension of the point set +-- +-- pre: points are sorted according to their dimension +widestDimension :: (Num r, Ord r, Arity d) => GV.Vector d (PointSeq d p r) -> Int +widestDimension = fst . L.maximumBy (comparing snd) . zip [1..] . F.toList . widths + +widths :: (Num r, Arity d) => GV.Vector d (PointSeq d p r) -> GV.Vector d r +widths = fmap Range.width . extends + + +{- HLINT ignore extends -} +-- | get the extends of the set of points in every dimension, i.e. the left and +-- right boundaries. +-- +-- pre: points are sorted according to their dimension +extends :: Arity d => GV.Vector d (PointSeq d p r) -> GV.Vector d (Range r) +extends = imap (\i pts -> + ClosedRange ((LSeq.head pts)^.core.unsafeCoord (i + 1)) + ((LSeq.last pts)^.core.unsafeCoord (i + 1))) + + +-------------------------------------------------------------------------------- +-- * Finding Well Separated Pairs + +findPairs :: (Floating r, Ord r, Arity d, Arity (d + 1)) + => r -> SplitTree d p r a -> SplitTree d p r a + -> [WSP d p r a] +findPairs s l r + | areWellSeparated' s l r = [(l,r)] + | maxWidth l <= maxWidth r = concatMap (findPairs s l) $ children' r + | otherwise = concatMap (findPairs s r) $ children' l + + +-- -- | Test if the two sets are well separated with param s +-- areWellSeparated :: (Arity d, Arity (d + 1), Fractional r, Ord r) +-- => r -- ^ separation factor +-- -> SplitTree d p r a +-- -> SplitTree d p r a -> Bool +-- areWellSeparated _ (Leaf _) (Leaf _) = True +-- areWellSeparated s l r = boxBox s (bbOf l) (bbOf r) + + +-- areWellSeparated s (Leaf p) (Node _ nd _) = pointBox s (p^.core) (nd^.bBox) +-- areWellSeparated s (Node _ nd _) (Leaf p) = pointBox s (p^.core) (nd^.bBox) +-- areWellSeparated s (Node _ ld _) (Node _ rd _) = boxBox s (ld^.bBox) (rd^.bBox) + +{- HLINT ignore boxBox -} +-- -- | Test if the point and the box are far enough appart +-- pointBox :: (Fractional r, Ord r, AlwaysTruePFT d, AlwaysTrueTransformation d) +-- => r -> Point d r -> Box d p r -> Bool +-- pointBox s p b = not $ p `inBox` b' +-- where +-- v = (centerPoint b)^.vector +-- b' = translateBy v . scaleUniformlyBy s . translateBy ((-1) *^ v) $ b + +-- -- | Test if the two boxes are sufficiently far appart +-- boxBox :: (Fractional r, Ord r, Arity d, Arity (d + 1)) +-- => r -> Box d p r -> Box d p r -> Bool +-- boxBox s lb rb = boxBox' lb rb && boxBox' rb lb +-- where +-- boxBox' b' b = not $ b' `intersects` bOut +-- where +-- v = (centerPoint b)^.vector +-- bOut = translateBy v . scaleUniformlyBy s . translateBy ((-1) *^ v) $ b + +-------------------------------------------------------------------------------- +-- * Alternative def if wellSeparated that uses fractional + + +areWellSeparated' :: (Floating r, Ord r, Arity d) + => r + -> SplitTree d p r a + -> SplitTree d p r a + -> Bool +areWellSeparated' _ (Leaf _) (Leaf _) = True +areWellSeparated' s l r = boxBox1 s (bbOf l) (bbOf r) + +-- (Leaf p) (Node _ nd _) = pointBox' s (p^.core) (nd^.bBox) +-- areWellSeparated' s (Node _ nd _) (Leaf p) = pointBox' s (p^.core) (nd^.bBox) +-- areWellSeparated' s (Node _ ld _) (Node _ rd _) = boxBox' s (ld^.bBox) (rd^.bBox) + +boxBox1 :: (Floating r, Ord r, Arity d) => r -> Box d p r -> Box d p r -> Bool +boxBox1 s lb rb = euclideanDist (centerPoint lb) (centerPoint rb) >= (s+1)*d + where + diam b = euclideanDist (b^.minP.core.cwMin) (b^.maxP.core.cwMax) + d = max (diam lb) (diam rb) + + + + +-------------------------------------------------------------------------------- +-- * Helper stuff + + +-- | Computes the maximum width of a splitTree +maxWidth :: (Arity d, Num r) + => SplitTree d p r a -> r +maxWidth (Leaf _) = 0 +maxWidth (Node _ (NodeData i b _) _) = fromJust $ widthIn' i b + +-- | 'Computes' the bounding box of a split tree +bbOf :: Ord r => SplitTree d p r a -> Box d () r +bbOf (Leaf p) = boundingBox $ p^.core +bbOf (Node _ (NodeData _ b _) _) = b + + +children' :: BinLeafTree v a -> [BinLeafTree v a] +children' (Leaf _) = [] +children' (Node l _ r) = [l,r] + + +-- | Turn a traversal into lens +ix' :: (Arity d, KnownNat d) => Int -> Lens' (GV.Vector d a) a +ix' i = singular (GV.element' i) + + +dropIdx :: core :+ (t :+ extra) -> core :+ extra +dropIdx (p :+ (_ :+ e)) = p :+ e + +-------------------------------------------------------------------------------- diff --git a/src/Algorithms/Geometry/WSPD/Types.hs b/src/Algorithms/Geometry/WSPD/Types.hs new file mode 100644 --- /dev/null +++ b/src/Algorithms/Geometry/WSPD/Types.hs @@ -0,0 +1,85 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE UndecidableInstances #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Algorithms.Geometry.WSPD.Types +-- Copyright : (C) Frank Staals +-- License : see the LICENSE file +-- Maintainer : Frank Staals +-- +-- Data types that can represent a well separated pair decomposition (wspd). +-- +-------------------------------------------------------------------------------- +module Algorithms.Geometry.WSPD.Types + where + +import Control.Lens hiding (Level) +import Data.BinaryTree +import Data.Ext +import Data.Geometry.Box +import Data.Geometry.Point +import Data.Geometry.Vector +import qualified Data.LSeq as LSeq +import Data.Measured.Class +import qualified Data.Sequence as S +import qualified Data.Traversable as Tr + +-------------------------------------------------------------------------------- + +type SplitTree d p r a = BinLeafTree (NodeData d r a) (Point d r :+ p) + +type PointSet d p r a = SplitTree d p r a + +type WSP d p r a = (PointSet d p r a, PointSet d p r a) + +-- | Data that we store in the split tree +data NodeData d r a = NodeData { _splitDim :: !Int + , _bBox :: !(Box d () r) + , _nodeData :: !a + } +deriving instance (Arity d, Show r, Show a) => Show (NodeData d r a) +deriving instance (Arity d, Eq r, Eq a) => Eq (NodeData d r a) + +makeLenses ''NodeData + +instance Semigroup v => Measured v (NodeData d r v) where + measure = _nodeData + +instance Functor (NodeData d r) where + fmap = Tr.fmapDefault + +instance Foldable (NodeData d r) where + foldMap = Tr.foldMapDefault + +instance Traversable (NodeData d r) where + traverse f (NodeData d b x) = NodeData d b <$> f x + +-------------------------------------------------------------------------------- +-- * Implementation types + +-- | Non-empty sequence of points. +type PointSeq d p r = LSeq.LSeq 1 (Point d r :+ p) + + +data Level = Level { _unLevel :: Int + , _widestDim :: Maybe Int + } deriving (Show,Eq,Ord) +makeLenses ''Level + +nextLevel :: Level -> Level +nextLevel (Level i _) = Level (i+1) Nothing + + +type Idx = Int + + +data ShortSide = L | R deriving (Show,Eq) + +data FindAndCompact d r p = FAC { _leftPart :: !(S.Seq (Point d r :+ p)) + , _rightPart :: !(S.Seq (Point d r :+ p)) + , _shortSide :: !ShortSide + } +deriving instance (Arity d, Show r, Show p) => Show (FindAndCompact d r p) +deriving instance (Arity d, Eq r, Eq p) => Eq (FindAndCompact d r p) + +makeLenses ''FindAndCompact diff --git a/src/Algorithms/Geometry/WellSeparatedPairDecomposition/Types.hs b/src/Algorithms/Geometry/WellSeparatedPairDecomposition/Types.hs --- a/src/Algorithms/Geometry/WellSeparatedPairDecomposition/Types.hs +++ b/src/Algorithms/Geometry/WellSeparatedPairDecomposition/Types.hs @@ -10,75 +10,11 @@ -- Data types that can represent a well separated pair decomposition (wspd). -- -------------------------------------------------------------------------------- -module Algorithms.Geometry.WellSeparatedPairDecomposition.Types where - -import Control.Lens hiding (Level) -import Data.BinaryTree -import Data.Ext -import Data.Geometry.Box -import Data.Geometry.Point -import Data.Geometry.Vector -import qualified Data.LSeq as LSeq -import Data.Measured.Class -import qualified Data.Sequence as S -import qualified Data.Traversable as Tr - --------------------------------------------------------------------------------- - -type SplitTree d p r a = BinLeafTree (NodeData d r a) (Point d r :+ p) - -type PointSet d p r a = SplitTree d p r a - -type WSP d p r a = (PointSet d p r a, PointSet d p r a) - --- | Data that we store in the split tree -data NodeData d r a = NodeData { _splitDim :: !Int - , _bBox :: !(Box d () r) - , _nodeData :: !a - } -deriving instance (Arity d, Show r, Show a) => Show (NodeData d r a) -deriving instance (Arity d, Eq r, Eq a) => Eq (NodeData d r a) - -makeLenses ''NodeData - -instance Semigroup v => Measured v (NodeData d r v) where - measure = _nodeData - -instance Functor (NodeData d r) where - fmap = Tr.fmapDefault - -instance Foldable (NodeData d r) where - foldMap = Tr.foldMapDefault - -instance Traversable (NodeData d r) where - traverse f (NodeData d b x) = NodeData d b <$> f x - --------------------------------------------------------------------------------- --- * Implementation types - -type PointSeq d p r = LSeq.LSeq 1 (Point d r :+ p) - - -data Level = Level { _unLevel :: Int - , _widestDim :: Maybe Int - } deriving (Show,Eq,Ord) -makeLenses ''Level - -nextLevel :: Level -> Level -nextLevel (Level i _) = Level (i+1) Nothing - - - -type Idx = Int - - -data ShortSide = L | R deriving (Show,Eq) - -data FindAndCompact d r p = FAC { _leftPart :: !(S.Seq (Point d r :+ p)) - , _rightPart :: !(S.Seq (Point d r :+ p)) - , _shortSide :: !ShortSide - } -deriving instance (Arity d, Show r, Show p) => Show (FindAndCompact d r p) -deriving instance (Arity d, Eq r, Eq p) => Eq (FindAndCompact d r p) +-- FIXME: This module should be internal and not exposed. Fix after 2021-06-01. +module Algorithms.Geometry.WellSeparatedPairDecomposition.Types + {-# DEPRECATED "This module will be deleted after 2021-06-01. \ + \Use Algorithms.Geometry.WSPD instead." #-} + ( module Algorithms.Geometry.WSPD.Types ) + where -makeLenses ''FindAndCompact +import Algorithms.Geometry.WSPD.Types diff --git a/src/Algorithms/Geometry/WellSeparatedPairDecomposition/WSPD.hs b/src/Algorithms/Geometry/WellSeparatedPairDecomposition/WSPD.hs --- a/src/Algorithms/Geometry/WellSeparatedPairDecomposition/WSPD.hs +++ b/src/Algorithms/Geometry/WellSeparatedPairDecomposition/WSPD.hs @@ -8,453 +8,10 @@ -- Algorithm to construct a well separated pair decomposition (wspd). -- -------------------------------------------------------------------------------- -module Algorithms.Geometry.WellSeparatedPairDecomposition.WSPD where - -import Algorithms.Geometry.WellSeparatedPairDecomposition.Types -import Control.Lens hiding (Level, levels) -import Control.Monad.Reader -import Control.Monad.ST (ST,runST) -import Data.BinaryTree -import Data.Ext -import qualified Data.Foldable as F -import Data.Geometry.Box -import Data.Geometry.Point -import Data.Geometry.Properties -import Data.Geometry.Transformation -import Data.Geometry.Vector -import qualified Data.Geometry.Vector as GV -import qualified Data.IntMap.Strict as IntMap -import qualified Data.LSeq as LSeq -import Data.LSeq (LSeq,toSeq,ViewL(..),ViewR(..),pattern (:<|)) -import qualified Data.List as L -import qualified Data.List.NonEmpty as NonEmpty -import Data.Maybe -import Data.Ord (comparing) -import Data.Range -import qualified Data.Range as Range -import qualified Data.Sequence as S -import qualified Data.Vector as V -import qualified Data.Vector.Mutable as MV -import GHC.TypeLits - -import Debug.Trace - --------------------------------------------------------------------------------- - --- | Construct a split tree --- --- running time: \(O(n \log n)\) -fairSplitTree :: (Fractional r, Ord r, Arity d, 1 <= d - , Show r, Show p - ) - => NonEmpty.NonEmpty (Point d r :+ p) -> SplitTree d p r () -fairSplitTree pts = foldUp node' Leaf $ fairSplitTree' n pts' +module Algorithms.Geometry.WellSeparatedPairDecomposition.WSPD + {-# DEPRECATED "This module will be deleted after 2021-06-01. \ + \Use Algorithms.Geometry.WSPD instead." #-} + ( module Algorithms.Geometry.WSPD ) where - pts' = imap sortOn . pure . g $ pts - n = length $ pts'^.GV.element (C :: C 0) - sortOn' i = NonEmpty.sortWith (^.core.unsafeCoord i) - sortOn i = LSeq.fromNonEmpty . sortOn' (i + 1) - -- sorts the points on the first coordinate, and then associates each point - -- with an index,; its rank in terms of this first coordinate. - g = NonEmpty.zipWith (\i (p :+ e) -> p :+ (i :+ e)) (NonEmpty.fromList [0..]) - . sortOn' 1 - - -- node' :: b -> a -> b -> b - -- node' :: SplitTree d p r () -> Int -> SplitTree d p r () -> SplitTree d p r () - node' l j r = Node l (NodeData j (bbOf l <> bbOf r) ()) r - - --- | Given a split tree, generate the Well separated pairs --- --- running time: \(O(s^d n)\) -wellSeparatedPairs :: (Floating r, Ord r, Arity d, Arity (d + 1)) - => r -> SplitTree d p r a -> [WSP d p r a] -wellSeparatedPairs s = f - where - f (Leaf _) = [] - f (Node l _ r) = findPairs s l r ++ f l ++ f r - - - --- -- | Given a split tree, generate the well separated pairs such that one set is --- -- a singleton. --- -- running time: \(O(s^d n\log n)\) --- wellSeparatedPairSingletons :: (Fractional r, Ord r, AlwaysTrueWSPD d) --- => r -> SplitTree d p r a -> [(Point d r :+ p, PointSet d p r (Sized a))] --- wellSeparatedPairSingletons s t = concatMap split $ wellSeparatedPairs s t' --- where --- split (l,r) = undefined --- -- | measure l <= measure r = map (,r) $ F.toList l --- -- | otherwise = map (,l) $ F.toList r --- t' = foldUpData (\l nd r -> ) - --- t - - --------------------------------------------------------------------------------- --- * Building the split tree - --- | Given the points, sorted in every dimension, recursively build a split tree --- --- The algorithm works in rounds. Each round takes O(n) time, and halves the --- number of points. Thus, the total running time is O(n log n). --- --- The algorithm essentially builds a path in the split tree; at every node on --- the path that we construct, we split the point set into two sets (L,R) --- according to the longest side of the bounding box. --- --- The smaller set is "assigned" to the current node and set asside. We --- continue to build the path with the larger set until the total number of --- items remaining is less than n/2. --- --- To start the next round, each node on the path needs to have the points --- assigned to that node, sorted in each dimension (i.e. the Vector --- (PointSeq))'s. Since we have the level assignment, we can compute these --- lists by traversing each original input list (i.e. one for every dimension) --- once, and partition the points based on their level assignment. -fairSplitTree' :: (Fractional r, Ord r, Arity d, 1 <= d - , Show r, Show p - ) - => Int -> GV.Vector d (PointSeq d (Idx :+ p) r) - -> BinLeafTree Int (Point d r :+ p) -fairSplitTree' n pts - | n <= 1 = let p = LSeq.head $ pts^.GV.element (C :: C 0) in Leaf (dropIdx p) - | otherwise = foldr node' (V.last path) $ V.zip nodeLevels (V.init path) - where - -- note that points may also be assigned level 'Nothing'. - (levels, nodeLevels'@(maxLvl NonEmpty.:| _)) = runST $ do - lvls <- MV.replicate n Nothing - ls <- runReaderT (assignLevels (n `div` 2) 0 pts (Level 0 Nothing) []) lvls - lvls' <- V.unsafeFreeze lvls - pure (lvls',ls) - - -- TODO: We also need to report the levels in the order in which they are - -- assigned to nodes - - nodeLevels = V.fromList . L.reverse . NonEmpty.toList $ nodeLevels' - - -- levels = traceShow ("Levels",levels',maxLvl) levels' - - -- path = traceShow ("path", path',nodeLevels) path' - distrPts = distributePoints (1 + maxLvl^.unLevel) levels pts - - path = recurse <$> distrPts -- (traceShow ("distributed pts",distrPts) distrPts) - - -- node' (lvl,lc) rc | traceShow ("node' ",lvl,lc,rc) False = undefined - node' (lvl,lc) rc = case lvl^?widestDim._Just of - Nothing -> error "Unknown widest dimension" - Just j -> Node lc j rc - recurse pts' = fairSplitTree' (length $ pts'^.GV.element (C :: C 0)) - (reIndexPoints pts') - --- | Assign the points to their the correct class. The 'Nothing' class is --- considered the last class -distributePoints :: (Arity d , Show r, Show p) - => Int -> V.Vector (Maybe Level) - -> GV.Vector d (PointSeq d (Idx :+ p) r) - -> V.Vector (GV.Vector d (PointSeq d (Idx :+ p) r)) -distributePoints k levels = transpose . fmap (distributePoints' k levels) - -transpose :: Arity d => GV.Vector d (V.Vector a) -> V.Vector (GV.Vector d a) -transpose = V.fromList . map GV.vectorFromListUnsafe . L.transpose - . map V.toList . F.toList - --- | Assign the points to their the correct class. The 'Nothing' class is --- considered the last class -distributePoints' :: Int -- ^ number of classes - -> V.Vector (Maybe Level) -- ^ level assignment - -> PointSeq d (Idx :+ p) r -- ^ input points - -> V.Vector (PointSeq d (Idx :+ p) r) -distributePoints' k levels pts - | otherwise - = fmap fromSeqUnsafe $ V.create $ do - v <- MV.replicate k mempty - forM_ pts $ \p -> - append v (level p) p - pure v - where - level p = maybe (k-1) _unLevel $ levels V.! (p^.extra.core) - append v i p = MV.read v i >>= MV.write v i . (S.|> p) - -fromSeqUnsafe = LSeq.promise . LSeq.fromSeq - --- | Given a sequence of points, whose index is increasing in the first --- dimension, i.e. if idx p < idx q, then p[0] < q[0]. --- Reindex the points so that they again have an index --- in the range [0,..,n'], where n' is the new number of points. --- --- running time: O(n' * d) (more or less; we are actually using an intmap for --- the lookups) --- --- alternatively: I can unsafe freeze and thaw an existing vector to pass it --- along to use as mapping. Except then I would have to force the evaluation --- order, i.e. we cannot be in 'reIndexPoints' for two of the nodes at the same --- time. --- --- so, basically, run reIndex points in ST as well. -reIndexPoints :: (Arity d, 1 <= d) - => GV.Vector d (PointSeq d (Idx :+ p) r) - -> GV.Vector d (PointSeq d (Idx :+ p) r) -reIndexPoints ptsV = fmap reIndex ptsV - where - pts = ptsV^.GV.element (C :: C 0) - - reIndex = fmap (\p -> p&extra.core %~ fromJust . flip IntMap.lookup mapping') - mapping' = IntMap.fromAscList $ zip (map (^.extra.core) . F.toList $ pts) [0..] - --- | ST monad with access to the vector storign the level of the points. -type RST s = ReaderT (MV.MVector s (Maybe Level)) (ST s) - --- | Assigns the points to a level. Returns the list of levels used. The first --- level in the list is the level assigned to the rest of the nodes. Their --- level is actually still set to Nothing in the underlying array. -assignLevels :: (Fractional r, Ord r, Arity d - , Show r, Show p - ) - => Int -- ^ Number of items we need to collect - -> Int -- ^ Number of items we collected so far - -> GV.Vector d (PointSeq d (Idx :+ p) r) - -> Level -- ^ next level to use - -> [Level] -- ^ Levels used so far - -> RST s (NonEmpty.NonEmpty Level) -assignLevels h m pts l prevLvls - | m >= h = pure (l NonEmpty.:| prevLvls) - | otherwise = do - pts' <- compactEnds pts - -- find the widest dimension j = i+1 - let j = widestDimension pts' - i = j - 1 -- traceShow ("i",j,pts') j - 1 - extJ = (extends pts')^.ix' i - mid = midPoint extJ - - -- find the set of points that we have to delete, by looking at the sorted - -- list L_j. As a side effect, this will remove previously assigned points - -- from L_j. - (lvlJPts,deletePts) <- findAndCompact j (pts'^.ix' i) mid - let pts'' = pts'&ix' i .~ lvlJPts - l' = l&widestDim .~ Just j - forM_ deletePts $ \p -> - assignLevel p l' - assignLevels h (m + length deletePts) pts'' (nextLevel l) (l' : prevLvls) - --- | Remove already assigned pts from the ends of all vectors. -compactEnds :: Arity d - => GV.Vector d (PointSeq d (Idx :+ p) r) - -> RST s (GV.Vector d (PointSeq d (Idx :+ p) r)) -compactEnds = traverse compactEnds' - --- | Assign level l to point p -assignLevel :: (c :+ (Idx :+ p)) -> Level -> RST s () -assignLevel p l = ask >>= \levels -> lift $ MV.write levels (p^.extra.core) (Just l) - --- | Get the level of a point -levelOf :: (c :+ (Idx :+ p)) -> RST s (Maybe Level) -levelOf p = ask >>= \levels -> lift $ MV.read levels (p^.extra.core) - --- | Test if the point already has a level assigned to it. -hasLevel :: c :+ (Idx :+ p) -> RST s Bool -hasLevel = fmap isJust . levelOf - --- | Remove allready assigned points from the sequence --- --- pre: there are points remaining -compactEnds' :: PointSeq d (Idx :+ p) r - -> RST s (PointSeq d (Idx :+ p) r) -compactEnds' (l0 :<| s0) = fmap fromSeqUnsafe . goL $ l0 S.<| toSeq s0 - where - goL s@(S.viewl -> l S.:< s') = hasLevel l >>= \case - False -> goR s - True -> goL s' - goR s@(S.viewr -> s' S.:> r) = hasLevel r >>= \case - False -> pure s - True -> goR s' - - --- | Given the points, ordered by their j^th coordinate, split the point set --- into a "left" and a "right" half, i.e. the points whose j^th coordinate is --- at most the given mid point m, and the points whose j^th coordinate is --- larger than m. --- --- We return a pair (Largest set, Smallest set) --- --- ---fi ndAndCompact works by simultaneously traversing the points from left to --- right, and from right to left. As soon as we find a point crossing the mid --- point we stop and return. Thus, in principle this takes only O(|Smallest --- set|) time. --- --- running time: O(|Smallest set|) + R, where R is the number of *old* points --- (i.e. points that should have been removed) in the list. -findAndCompact :: (Ord r, Arity d - , Show r, Show p - ) - => Int - -- ^ the dimension we are in, i.e. so that we know - -- which coordinate of the point to compare - -> PointSeq d (Idx :+ p) r - -> r -- ^ the mid point - -> RST s ( PointSeq d (Idx :+ p) r - , PointSeq d (Idx :+ p) r - ) -findAndCompact j (l0 :<| s0) m = fmap select . stepL $ l0 S.<| toSeq s0 - where - -- stepL and stepR together build a data structure (FAC l r S) that - -- contains the left part of the list, i.e. the points before midpoint, and - -- the right part of the list., and a value S that indicates which part is - -- the short side. - - -- stepL takes a step on the left side of the list; if the left point l - -- already has been assigned, we continue waling along (and "ignore" the - -- point). If it has not been assigned, and is before the mid point, we - -- take a step from the right, and add l onto the left part. If it is - -- larger than the mid point, we have found our split. - -- stepL :: S.Seq (Point d r :+ (Idx :+ p)) -> ST s (FindAndCompact d r (Idx :+ p)) - stepL s = case S.viewl s of - S.EmptyL -> pure $ FAC mempty mempty L - l S.:< s' -> hasLevel l >>= \case - False -> if l^.core.unsafeCoord j <= m - then addL l <$> stepR s' - else pure $ FAC mempty s L - True -> stepL s' -- delete, continue left - - -- stepR :: S.Seq (Point d r :+ (Idx :+ p)) -> ST s (FindAndCompact d r (Idx :+ p)) - stepR s = case S.viewr s of - S.EmptyR -> pure $ FAC mempty mempty R - s' S.:> r -> hasLevel r >>= \case - False -> if r^.core.unsafeCoord j >= m - then addR r <$> stepL s' - else pure $ FAC s mempty R - True -> stepR s' - - - addL l x = x&leftPart %~ (l S.<|) - addR r x = x&rightPart %~ (S.|> r) - - select = over both fromSeqUnsafe . select' - - -- select' f | traceShow ("select'", f) False = undefined - select' (FAC l r L) = (r, l) - select' (FAC l r R) = (l, r) - - --- | Find the widest dimension of the point set --- --- pre: points are sorted according to their dimension -widestDimension :: (Num r, Ord r, Arity d) => GV.Vector d (PointSeq d p r) -> Int -widestDimension = fst . L.maximumBy (comparing snd) . zip [1..] . F.toList . widths - -widths :: (Num r, Arity d) => GV.Vector d (PointSeq d p r) -> GV.Vector d r -widths = fmap Range.width . extends - - - --- | get the extends of the set of points in every dimension, i.e. the left and --- right boundaries. --- --- pre: points are sorted according to their dimension -extends :: Arity d => GV.Vector d (PointSeq d p r) -> GV.Vector d (Range r) -extends = imap (\i pts -> - ClosedRange ((LSeq.head pts)^.core.unsafeCoord (i + 1)) - ((LSeq.last pts)^.core.unsafeCoord (i + 1))) - - --------------------------------------------------------------------------------- --- * Finding Well Separated Pairs - -findPairs :: (Floating r, Ord r, Arity d, Arity (d + 1)) - => r -> SplitTree d p r a -> SplitTree d p r a - -> [WSP d p r a] -findPairs s l r - | areWellSeparated' s l r = [(l,r)] - | maxWidth l <= maxWidth r = concatMap (findPairs s l) $ children' r - | otherwise = concatMap (findPairs s r) $ children' l - - --- | Test if the two sets are well separated with param s -areWellSeparated :: (Arity d, Arity (d + 1), Fractional r, Ord r) - => r -- ^ separation factor - -> SplitTree d p r a - -> SplitTree d p r a -> Bool -areWellSeparated _ (Leaf _) (Leaf _) = True -areWellSeparated s l r = boxBox s (bbOf l) (bbOf r) - - --- areWellSeparated s (Leaf p) (Node _ nd _) = pointBox s (p^.core) (nd^.bBox) --- areWellSeparated s (Node _ nd _) (Leaf p) = pointBox s (p^.core) (nd^.bBox) --- areWellSeparated s (Node _ ld _) (Node _ rd _) = boxBox s (ld^.bBox) (rd^.bBox) - - --- -- | Test if the point and the box are far enough appart --- pointBox :: (Fractional r, Ord r, AlwaysTruePFT d, AlwaysTrueTransformation d) --- => r -> Point d r -> Box d p r -> Bool --- pointBox s p b = not $ p `inBox` b' --- where --- v = (centerPoint b)^.vector --- b' = translateBy v . scaleUniformlyBy s . translateBy ((-1) *^ v) $ b - --- | Test if the two boxes are sufficiently far appart -boxBox :: (Fractional r, Ord r, Arity d, Arity (d + 1)) - => r -> Box d p r -> Box d p r -> Bool -boxBox s lb rb = boxBox' lb rb && boxBox' rb lb - where - boxBox' b' b = not $ b' `intersects` bOut - where - v = (centerPoint b)^.vector - bOut = translateBy v . scaleUniformlyBy s . translateBy ((-1) *^ v) $ b - --------------------------------------------------------------------------------- --- * Alternative def if wellSeparated that uses fractional - - -areWellSeparated' :: (Floating r, Ord r, Arity d) - => r - -> SplitTree d p r a - -> SplitTree d p r a - -> Bool -areWellSeparated' _ (Leaf _) (Leaf _) = True -areWellSeparated' s l r = boxBox1 s (bbOf l) (bbOf r) - --- (Leaf p) (Node _ nd _) = pointBox' s (p^.core) (nd^.bBox) --- areWellSeparated' s (Node _ nd _) (Leaf p) = pointBox' s (p^.core) (nd^.bBox) --- areWellSeparated' s (Node _ ld _) (Node _ rd _) = boxBox' s (ld^.bBox) (rd^.bBox) - -boxBox1 :: (Floating r, Ord r, Arity d) => r -> Box d p r -> Box d p r -> Bool -boxBox1 s lb rb = euclideanDist (centerPoint lb) (centerPoint rb) >= (s+1)*d - where - diam b = euclideanDist (b^.minP.core.cwMin) (b^.maxP.core.cwMax) - d = max (diam lb) (diam rb) - - - - --------------------------------------------------------------------------------- --- * Helper stuff - - --- | Computes the maximum width of a splitTree -maxWidth :: (Arity d, Num r) - => SplitTree d p r a -> r -maxWidth (Leaf _) = 0 -maxWidth (Node _ (NodeData i b _) _) = fromJust $ widthIn' i b - --- | 'Computes' the bounding box of a split tree -bbOf :: Ord r => SplitTree d p r a -> Box d () r -bbOf (Leaf p) = boundingBox $ p^.core -bbOf (Node _ (NodeData _ b _) _) = b - - -children' :: BinLeafTree v a -> [BinLeafTree v a] -children' (Leaf _) = [] -children' (Node l _ r) = [l,r] - - --- | Turn a traversal into lens -ix' :: (Arity d, KnownNat d) => Int -> Lens' (GV.Vector d a) a -ix' i = singular (GV.element' i) - - -dropIdx :: core :+ (t :+ extra) -> core :+ extra -dropIdx (p :+ (_ :+ e)) = p :+ e - --------------------------------------------------------------------------------- +import Algorithms.Geometry.WSPD diff --git a/src/Data/Geometry.hs b/src/Data/Geometry.hs --- a/src/Data/Geometry.hs +++ b/src/Data/Geometry.hs @@ -26,7 +26,7 @@ import Data.Geometry.LineSegment import Data.Geometry.Point import Data.Geometry.PolyLine hiding (fromPoints) -import Data.Geometry.Polygon hiding (fromPoints) +import Data.Geometry.Polygon hiding (fromPoints, maximumBy, minimumBy) import Data.Geometry.Properties import Data.Geometry.Transformation -- import Linear.Affine hiding (Point, Vector, origin) diff --git a/src/Data/Geometry/Arrangement/Internal.hs b/src/Data/Geometry/Arrangement/Internal.hs --- a/src/Data/Geometry/Arrangement/Internal.hs +++ b/src/Data/Geometry/Arrangement/Internal.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TemplateHaskell #-} -------------------------------------------------------------------------------- -- | -- Module : Data.Geometry.Arrangement.Internal @@ -13,9 +13,10 @@ import Algorithms.BinarySearch import Control.Lens -import qualified Data.CircularSeq as CSeq +import Data.Bifunctor +import qualified Data.CircularSeq as CSeq import Data.Ext -import qualified Data.Foldable as F +import qualified Data.Foldable as F import Data.Geometry.Boundary import Data.Geometry.Box import Data.Geometry.Line @@ -23,10 +24,10 @@ import Data.Geometry.PlanarSubdivision import Data.Geometry.Point import Data.Geometry.Properties -import qualified Data.List as List +import qualified Data.List as List import Data.Maybe -import Data.Ord (Down(..)) -import qualified Data.Vector as V +import Data.Ord (Down (..)) +import qualified Data.Vector as V import Data.Vinyl.CoRec -------------------------------------------------------------------------------- @@ -97,7 +98,7 @@ computeSegsAndParts rect ls = ( segs <> boundarySegs, parts') where segs = map (&extra %~ Just) - . concatMap (\(l,ls') -> perLine rect l ls') $ makePairs ls + . concatMap (uncurry (perLine rect)) $ makePairs ls boundarySegs = map (:+ Nothing) . toSegments . dupFirst $ map fst parts' dupFirst = \case [] -> [] xs@(x:_) -> xs ++ [x] @@ -112,7 +113,7 @@ rmDuplicates = map head . List.group vs = mapMaybe (m `intersectionPoint`) ls vs' = maybe [] (\(p,q) -> [p,q]) . asA @(Point 2 r, Point 2 r) - $ (m^.core) `intersect` (Boundary b) + $ (m^.core) `intersect` Boundary b intersectionPoint :: forall r l. (Ord r, Fractional r) @@ -121,7 +122,7 @@ toSegments :: Ord r => [Point 2 r] -> [LineSegment 2 () r] -toSegments ps = let pts = map ext $ ps in +toSegments ps = let pts = map ext ps in zipWith ClosedLineSegment pts (tail pts) @@ -181,7 +182,7 @@ => [Line 2 r :+ l] -> LineSegment 2 q r -> [(Point 2 r, Line 2 r :+ l)] sideIntersections ls s = let l = supportingLine s :+ undefined - in List.sortOn fst . filter (flip onSegment s . fst) + in List.sortOn fst . filter ((`intersects` s) . fst) . mapMaybe (\m -> (,m) <$> l `intersectionPoint` m) $ ls -- | Constructs the unbounded intersections. Reported in clockwise direction. @@ -192,8 +193,8 @@ unBoundedParts rect ls = [tl] <> t <> [tr] <> reverse r <> [br] <> reverse b <> [bl] <> l where sideIntersections' = over (traverse._2) Just . sideIntersections ls - Sides t r b l = fmap sideIntersections' $ sides rect - Corners tl tr br bl = fmap ((,Nothing) . (^.core)) $ corners rect + Sides t r b l = sideIntersections' <$> sides rect + Corners tl tr br bl = (,Nothing) . (^.core) <$> corners rect -- | Links the vertices of the outer boundary with those in the subdivision @@ -212,10 +213,10 @@ makePairs = go where go [] = [] - go (x:xs) = (x,xs) : map (\(y,ys) -> (y,x:ys)) (go xs) + go (x:xs) = (x,xs) : map (second (x:)) (go xs) -allPairs :: [a] -> [(a,a)] -allPairs ys = go ys +allPairs :: [a] -> [(a,a)] +allPairs = go where go [] = [] go (x:xs) = map (x,) xs ++ go xs @@ -244,7 +245,7 @@ => Line 2 r -> Arrangement s l v (Maybe e) f r -> Maybe (Dart s) findStart l arr = do (p,_) <- asA @(Point 2 r, Point 2 r) $ - l `intersect` (Boundary $ arr^.boundedArea) + l `intersect` Boundary (arr^.boundedArea) (_,v,_) <- findStartVertex p arr findStartDart (arr^.subdivision) v @@ -264,13 +265,13 @@ -> Maybe (Point 2 r, VertexId' s, Maybe (Line 2 r :+ l)) findStartVertex p arr = do ss <- findSide p - i <- binarySearchVec (pred' ss) (arr^.unboundedIntersections) + i <- binarySearchIdxIn (pred' ss) (arr^.unboundedIntersections) pure $ arr^.unboundedIntersections.singular (ix i) where Sides t r b l = sides'' $ arr^.boundedArea sides'' = fmap (\(ClosedLineSegment a c) -> LineSegment (Closed a) (Open c)) . sides - findSide q = fmap fst . List.find (onSegment q . snd) $ zip [1..] [t,r,b,l] + findSide q = fmap fst . List.find (intersects q. snd) $ zip [1..] [t,r,b,l] pred' ss (q,_,_) = let Just j = findSide q x = before (ss,p) (j,q) diff --git a/src/Data/Geometry/Ball.hs b/src/Data/Geometry/Ball.hs --- a/src/Data/Geometry/Ball.hs +++ b/src/Data/Geometry/Ball.hs @@ -75,6 +75,7 @@ -- * Querying if a point lies in a ball +-- | Query location of a point relative to a d-dimensional ball. inBall :: (Arity d, Ord r, Num r) => Point d r -> Ball d p r -> PointLocationResult p `inBall` (Ball c sr) = case qdA p (c^.core) `compare` sr of @@ -148,17 +149,18 @@ pattern Circle c r = Sphere c r {-# COMPLETE Circle #-} +{- HLINT ignore disk -} -- | Given three points, get the disk through the three points. If the three -- input points are colinear we return Nothing -- -- >>> disk (Point2 0 10) (Point2 10 0) (Point2 (-10) 0) --- Just (Ball {_center = Point2 [0.0,0.0] :+ (), _squaredRadius = 100.0}) +-- Just (Ball {_center = Point2 0.0 0.0 :+ (), _squaredRadius = 100.0}) disk :: (Eq r, Fractional r) => Point 2 r -> Point 2 r -> Point 2 r -> Maybe (Disk () r) disk p q r = match (f p `intersect` f q) $ - (H $ \NoIntersection -> Nothing) - :& (H $ \c@(Point _) -> Just $ Ball (ext c) (qdA c p)) - :& (H $ \_ -> Nothing) + H (\NoIntersection -> Nothing) + :& H (\c@Point{} -> Just $ Ball (ext c) (qdA c p)) + :& H (\_ -> Nothing) :& RNil -- If the intersection is not a point, The two lines f p and f q are -- parallel, that means the three input points where colinear. @@ -196,7 +198,7 @@ ] -instance (Ord r, Floating r) => (Line 2 r) `IsIntersectableWith` (Circle p r) where +instance (Ord r, Floating r) => Line 2 r `IsIntersectableWith` Circle p r where nonEmptyIntersection = defaultNonEmptyIntersection @@ -238,16 +240,16 @@ ] -instance (Ord r, Floating r) => (LineSegment 2 p r) `IsIntersectableWith` (Circle q r) where +instance (Ord r, Floating r) => LineSegment 2 p r `IsIntersectableWith` Circle q r where nonEmptyIntersection = defaultNonEmptyIntersection s `intersect` c = match (supportingLine s `intersect` c) $ - (H $ \NoIntersection -> coRec NoIntersection) - :& (H $ \(Touching p) -> if p `onSegment` s then coRec $ Touching p + H (\NoIntersection -> coRec NoIntersection) + :& H (\(Touching p) -> if p `intersects` s then coRec $ Touching p else coRec NoIntersection ) - :& (H $ \(p,q) -> case (p `onSegment` s, q `onSegment` s) of + :& H (\(p,q) -> case (p `intersects` s, q `intersects` s) of (False,False) -> coRec NoIntersection (False,True) -> coRec q (True, False) -> coRec p diff --git a/src/Data/Geometry/BezierSpline.hs b/src/Data/Geometry/BezierSpline.hs --- a/src/Data/Geometry/BezierSpline.hs +++ b/src/Data/Geometry/BezierSpline.hs @@ -1,5 +1,11 @@ {-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE TemplateHaskell #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Data.Geometry.BezierSpline +-- Copyright : (C) Frank Staals +-- License : see the LICENSE file +-- Maintainer : Frank Staals +-------------------------------------------------------------------------------- module Data.Geometry.BezierSpline( BezierSpline (BezierSpline) , controlPoints @@ -34,18 +40,22 @@ -- | Datatype representing a Bezier curve of degree \(n\) in \(d\)-dimensional space. newtype BezierSpline n d r = BezierSpline { _controlPoints :: LSeq (1+n) (Point d r) } -makeLenses ''BezierSpline +-- makeLenses ''BezierSpline +-- | Bezier control points. With n degrees, there are n+1 control points. +controlPoints :: Iso (BezierSpline n1 d1 r1) (BezierSpline n2 d2 r2) (LSeq (1+n1) (Point d1 r1)) (LSeq (1+n2) (Point d2 r2)) +controlPoints = iso _controlPoints BezierSpline + -- | Quadratic Bezier Spline pattern Bezier2 :: Point d r -> Point d r -> Point d r -> BezierSpline 2 d r -pattern Bezier2 p q r <- ((F.toList . LSeq.take 3 . _controlPoints) -> [p,q,r]) +pattern Bezier2 p q r <- (F.toList . LSeq.take 3 . _controlPoints -> [p,q,r]) where Bezier2 p q r = fromPointSeq . Seq.fromList $ [p,q,r] {-# COMPLETE Bezier2 #-} -- | Cubic Bezier Spline pattern Bezier3 :: Point d r -> Point d r -> Point d r -> Point d r -> BezierSpline 3 d r -pattern Bezier3 p q r s <- ((F.toList . LSeq.take 4 . _controlPoints) -> [p,q,r,s]) +pattern Bezier3 p q r s <- (F.toList . LSeq.take 4 . _controlPoints -> [p,q,r,s]) where Bezier3 p q r s = fromPointSeq . Seq.fromList $ [p,q,r,s] {-# COMPLETE Bezier3 #-} @@ -97,7 +107,7 @@ blend p q = p .+^ t *^ (q .-. p) - +-- | Tangent to the bezier spline at the starting point. tangent :: (Arity d, Num r, 1 <= n) => BezierSpline n d r -> Vector d r tangent b = b^?!controlPoints.ix 1 .-. b^?!controlPoints.ix 0 diff --git a/src/Data/Geometry/Boundary.hs b/src/Data/Geometry/Boundary.hs --- a/src/Data/Geometry/Boundary.hs +++ b/src/Data/Geometry/Boundary.hs @@ -1,3 +1,10 @@ +-------------------------------------------------------------------------------- +-- | +-- Module : Data.Geometry.Boundary +-- Copyright : (C) Frank Staals +-- License : see the LICENSE file +-- Maintainer : Frank Staals +-------------------------------------------------------------------------------- module Data.Geometry.Boundary where import Control.Lens (iso,Iso) diff --git a/src/Data/Geometry/Box/Corners.hs b/src/Data/Geometry/Box/Corners.hs --- a/src/Data/Geometry/Box/Corners.hs +++ b/src/Data/Geometry/Box/Corners.hs @@ -1,4 +1,11 @@ {-# LANGUAGE TemplateHaskell #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Data.Geometry.Box.Corners +-- Copyright : (C) Frank Staals +-- License : see the LICENSE file +-- Maintainer : Frank Staals +-------------------------------------------------------------------------------- module Data.Geometry.Box.Corners( Corners(Corners), northWest, northEast, southEast, southWest , corners, cornersInDirection ) where @@ -51,6 +58,7 @@ -------------------------------------------------------------------------------- +{- HLINT ignore corners -} -- | Get the corners of a rectangle, the order is: -- (TopLeft, TopRight, BottomRight, BottomLeft). -- The extra values in the Top points are taken from the Top point, @@ -59,8 +67,8 @@ corners r = let w = width r p = (_maxP r)&core %~ _cwMax q = (_minP r)&core %~ _cwMin - in Corners (p&core.xCoord %~ (subtract w)) p - (q&core.xCoord %~ (+ w)) q + in Corners (p&core.xCoord %~ subtract w) p + (q&core.xCoord %~ (+ w)) q -------------------------------------------------------------------------------- diff --git a/src/Data/Geometry/Box/Internal.hs b/src/Data/Geometry/Box/Internal.hs --- a/src/Data/Geometry/Box/Internal.hs +++ b/src/Data/Geometry/Box/Internal.hs @@ -89,6 +89,7 @@ in fromExtent $ FV.zipWith f (toVec c) ((/2) <$> ws) +{- HLINT ignore centerPoint -} -- | Center of the box centerPoint :: (Arity d, Fractional r) => Box d p r -> Point d r centerPoint b = Point $ w V.^/ 2 @@ -105,7 +106,7 @@ type instance IntersectionOf (Box d p r) (Box d q r) = '[ NoIntersection, Box d () r] -instance (Ord r, Arity d) => (Box d p r) `IsIntersectableWith` (Box d q r) where +instance (Ord r, Arity d) => Box d p r `IsIntersectableWith` Box d q r where nonEmptyIntersection = defaultNonEmptyIntersection bx `intersect` bx' = f . sequence $ FV.zipWith intersect' (extent bx) (extent bx') @@ -144,7 +145,7 @@ type instance IntersectionOf (Point d r) (Box d p r) = '[ NoIntersection, Point d r] -instance (Arity d, Ord r) => (Point d r) `IsIntersectableWith` (Box d p r) where +instance (Arity d, Ord r) => Point d r `IsIntersectableWith` Box d p r where nonEmptyIntersection = defaultNonEmptyIntersection p `intersect` b | not $ p `inBox` b = coRec NoIntersection @@ -187,12 +188,25 @@ inBox :: (Arity d, Ord r) => Point d r -> Box d p r -> Bool p `inBox` b = FV.and . FV.zipWith R.inRange (toVec p) . extent $ b + +-- | Check if a point lies strictly inside a box (i.e. not on its boundary) +-- +-- >>> origin `inBox` (boundingBoxList' [Point3 1 2 3, Point3 10 20 30] :: Box 3 () Int) +-- False +-- >>> origin `inBox` (boundingBoxList' [Point3 (-1) (-2) (-3), Point3 10 20 30] :: Box 3 () Int) +-- True +insideBox :: (Arity d, Ord r) => Point d r -> Box d p r -> Bool +p `insideBox` b = FV.and . FV.zipWith R.inRange (toVec p) . fmap toOpenRange . extent $ b + where + toOpenRange (R.Range' l r) = R.OpenRange l r + + -- | Get a vector with the extent of the box in each dimension. Note that the -- resulting vector is 0 indexed whereas one would normally count dimensions -- starting at zero. -- -- >>> extent (boundingBoxList' [Point3 1 2 3, Point3 10 20 30] :: Box 3 () Int) --- Vector3 [Range (Closed 1) (Closed 10),Range (Closed 2) (Closed 20),Range (Closed 3) (Closed 30)] +-- Vector3 (Range (Closed 1) (Closed 10)) (Range (Closed 2) (Closed 20)) (Range (Closed 3) (Closed 30)) extent :: Arity d => Box d p r -> Vector d (R.Range r) extent (Box (CWMin a :+ _) (CWMax b :+ _)) = FV.zipWith R.ClosedRange (toVec a) (toVec b) @@ -201,7 +215,7 @@ -- whereas one would normally count dimensions starting at zero. -- -- >>> size (boundingBoxList' [origin, Point3 1 2 3] :: Box 3 () Int) --- Vector3 [1,2,3] +-- Vector3 1 2 3 size :: (Arity d, Num r) => Box d p r -> Vector d r size = fmap R.width . extent @@ -233,6 +247,7 @@ type Rectangle = Box 2 +-- | -- >>> width (boundingBoxList' [origin, Point2 1 2] :: Rectangle () Int) -- 1 -- >>> width (boundingBoxList' [origin] :: Rectangle () Int) @@ -240,6 +255,7 @@ width :: Num r => Rectangle p r -> r width = widthIn (C :: C 1) +-- | -- >>> height (boundingBoxList' [origin, Point2 1 2] :: Rectangle () Int) -- 2 -- >>> height (boundingBoxList' [origin] :: Rectangle () Int) @@ -256,7 +272,7 @@ class IsBoxable g where boundingBox :: Ord (NumType g) => g -> Box (Dimension g) () (NumType g) - +-- | Create a bounding box that encapsulates a list of objects. boundingBoxList :: (IsBoxable g, F.Foldable1 c, Ord (NumType g), Arity (Dimension g)) => c g -> Box (Dimension g) () (NumType g) boundingBoxList = F.foldMap1 boundingBox diff --git a/src/Data/Geometry/Box/Sides.hs b/src/Data/Geometry/Box/Sides.hs --- a/src/Data/Geometry/Box/Sides.hs +++ b/src/Data/Geometry/Box/Sides.hs @@ -1,4 +1,11 @@ {-# LANGUAGE TemplateHaskell #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Data.Geometry.Box.Sides +-- Copyright : (C) Frank Staals +-- License : see the LICENSE file +-- Maintainer : Frank Staals +-------------------------------------------------------------------------------- module Data.Geometry.Box.Sides( Sides(Sides), north, east, south, west , topSide, bottomSide, leftSide, rightSide , sides, sides' diff --git a/src/Data/Geometry/Directions.hs b/src/Data/Geometry/Directions.hs --- a/src/Data/Geometry/Directions.hs +++ b/src/Data/Geometry/Directions.hs @@ -1,22 +1,29 @@ -{-# LANGUAGE TemplateHaskell #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Data.Geometry.Directions +-- Copyright : (C) Frank Staals +-- License : see the LICENSE file +-- Maintainer : Frank Staals +-- +-------------------------------------------------------------------------------- module Data.Geometry.Directions( CardinalDirection(..) - , _North, _East, _South, _West + -- , _North, _East, _South, _West , oppositeDirection , InterCardinalDirection(..) - , _NorthWest, _NorthEast, _SouthEast, _SouthWest + -- , _NorthWest, _NorthEast, _SouthEast, _SouthWest , interCardinalsOf ) where -import Control.Lens (makePrisms) import Data.Util import GHC.Generics (Generic) -------------------------------------------------------------------------------- +-- | The four cardinal directions. data CardinalDirection = North | East | South | West deriving (Show,Read,Eq,Ord,Enum,Bounded) -makePrisms ''CardinalDirection +-- makePrisms ''CardinalDirection -------------------------------------------------------------------------------- -- * Functions on Cardinal Directions @@ -34,7 +41,7 @@ -- | Intercardinal directions data InterCardinalDirection = NorthWest | NorthEast | SouthEast | SouthWest deriving (Show,Read,Eq,Ord,Enum,Generic) -makePrisms ''InterCardinalDirection +-- makePrisms ''InterCardinalDirection -------------------------------------------------------------------------------- -- * Functions on InterCardinal Directions diff --git a/src/Data/Geometry/Duality.hs b/src/Data/Geometry/Duality.hs --- a/src/Data/Geometry/Duality.hs +++ b/src/Data/Geometry/Duality.hs @@ -1,3 +1,10 @@ +-------------------------------------------------------------------------------- +-- | +-- Module : Data.Geometry.Duality +-- Copyright : (C) Frank Staals +-- License : see the LICENSE file +-- Maintainer : Frank Staals +-------------------------------------------------------------------------------- module Data.Geometry.Duality where import Data.Geometry.Line diff --git a/src/Data/Geometry/Ellipse.hs b/src/Data/Geometry/Ellipse.hs --- a/src/Data/Geometry/Ellipse.hs +++ b/src/Data/Geometry/Ellipse.hs @@ -1,4 +1,11 @@ {-# LANGUAGE TemplateHaskell #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Data.Geometry.Ellipse +-- Copyright : (C) Frank Staals +-- License : see the LICENSE file +-- Maintainer : Frank Staals +-------------------------------------------------------------------------------- module Data.Geometry.Ellipse( Ellipse(Ellipse) , affineTransformation @@ -18,7 +25,7 @@ -------------------------------------------------------------------------------- --- | A typre representing planar ellipses +-- | A type representing planar ellipses newtype Ellipse r = Ellipse { _affineTransformation :: Transformation 2 r } deriving (Show,Eq,Functor,Foldable,Traversable) makeLenses ''Ellipse diff --git a/src/Data/Geometry/HalfLine.hs b/src/Data/Geometry/HalfLine.hs --- a/src/Data/Geometry/HalfLine.hs +++ b/src/Data/Geometry/HalfLine.hs @@ -1,13 +1,25 @@ -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE DeriveAnyClass #-} -module Data.Geometry.HalfLine where - +-------------------------------------------------------------------------------- +-- | +-- Module : Data.Geometry.HalfLine +-- Copyright : (C) Frank Staals +-- License : see the LICENSE file +-- Maintainer : Frank Staals +-------------------------------------------------------------------------------- +module Data.Geometry.HalfLine( HalfLine(HalfLine) + , startPoint, halfLineDirection + , toHalfLine + , halfLineToSubLine, fromSubLine + ) where import Control.DeepSeq import Control.Lens import Data.Ext import qualified Data.Foldable as F +import Data.Geometry.Boundary +import Data.Geometry.Box import Data.Geometry.Interval import Data.Geometry.Line import Data.Geometry.LineSegment @@ -18,6 +30,9 @@ import Data.Geometry.Vector import qualified Data.Traversable as T import Data.UnBounded +import qualified Data.Vector.Fixed as FV +import Data.Vinyl +import Data.Vinyl.CoRec import GHC.Generics (Generic) import GHC.TypeLits @@ -41,6 +56,14 @@ type instance NumType (HalfLine d r) = r +instance {-# OVERLAPPING #-} (Eq r, Fractional r) => Eq (HalfLine 2 r) where + (HalfLine p u) == (HalfLine q v) = + p == q && -- Same starting point. + isCoLinear p (Point u) (Point v) && -- Directions are on the same line. + sameSigns -- Directions point in the same quadrant. + where + sameSigns = F.and $ FV.zipWith (\a b -> signum a==signum b) u v + instance (Eq r, Fractional r, Arity d) => Eq (HalfLine d r) where (HalfLine p u) == (HalfLine q v) = let lam = scalarMultiple u v in p == q && (signum <$> lam) == Just 1 @@ -77,9 +100,9 @@ (MinInfinity, Val x) -> Just $ HalfLine (pointAt x l) ((-1) *^ l^.direction) _ -> Nothing -type instance IntersectionOf (HalfLine 2 r) (Line 2 r) = [ NoIntersection - , Point 2 r - , HalfLine 2 r +type instance IntersectionOf (HalfLine d r) (Line d r) = [ NoIntersection + , Point d r + , HalfLine d r ] type instance IntersectionOf (HalfLine 2 r) (HalfLine 2 r) = [ NoIntersection @@ -88,88 +111,119 @@ , HalfLine 2 r ] -type instance IntersectionOf (HalfLine 2 r) (LineSegment 2 p r) = [ NoIntersection +type instance IntersectionOf (LineSegment 2 p r) (HalfLine 2 r) = [ NoIntersection , Point 2 r , LineSegment 2 () r ] +type instance IntersectionOf (Point d r) (HalfLine d r) = [ NoIntersection + , Point d r + ] --- instance (Ord r, Fractional r) => (HalfLine 2 r) `IsIntersectableWith` (Line 2 r) where - -- hl `intersect` l = match (halfLineToSubLine hl, l) +instance (Ord r, Fractional r) => HalfLine 2 r `IsIntersectableWith` Line 2 r where + nonEmptyIntersection = defaultNonEmptyIntersection + hl `intersect` l = match (supportingLine hl `intersect` l) $ + H (\NoIntersection -> coRec NoIntersection) + :& H (\p -> if onHalfLine p hl then coRec p else coRec NoIntersection) + :& H (\_l' -> coRec hl) + :& RNil --- instance (Ord r, Fractional r) => (HalfLine 2 r) `IsIntersectableWith` (Line 2 r) where --- data Intersection (HalfLine 2 r) (Line 2 r) = NoHalfLineLineIntersection --- | HalfLineLineIntersection !(Point 2 r) --- | HalfLineLineOverlap !(HalfLine 2 r) --- deriving (Show,Eq) --- nonEmptyIntersection NoHalfLineLineIntersection = False --- nonEmptyIntersection _ = True --- hl `intersect` l = case supportingLine hl `intersect` l of --- SameLine _ -> HalfLineLineOverlap hl --- LineLineIntersection p -> if p `onHalfLine` hl then HalfLineLineIntersection p --- else NoHalfLineLineIntersection --- ParallelLines -> NoHalfLineLineIntersection +instance (Ord r, Fractional r) => HalfLine 2 r `IsIntersectableWith` HalfLine 2 r where + nonEmptyIntersection = defaultNonEmptyIntersection + la@(HalfLine a va) `intersect` lb@(HalfLine b vb) = + match (supportingLine la `intersect` supportingLine lb) $ + H (\NoIntersection -> coRec NoIntersection) + :& H (\p -> if onHalfLine p la && onHalfLine p lb + then coRec p else coRec NoIntersection) + :& H (\_line -> case ( a `onHalfLine ` lb + , b `onHalfLine ` la + , va `sameDirection` vb + ) of + (False,False,_) -> coRec NoIntersection + (True,True,True) -> coRec la -- exact same halfline! + (True,True,False) -> coRec $ ClosedLineSegment (ext a) (ext b) + (True,_,True) -> coRec la + (_,True,True) -> coRec lb + (_,_,False) -> error "HalfLine x Halfline intersection: impossible" + -- it is impossible for a to be on + -- lb, while b does not lie on la, while having different + -- orientations + ) + :& RNil --- instance (Ord r, Fractional r) => (HalfLine 2 r) `IsIntersectableWith` (HalfLine 2 r) where --- data Intersection (HalfLine 2 r) (HalfLine 2 r) = NoHalfLineHalfLineIntersection --- | HLHLIntersectInPoint !(Point 2 r) --- | HLHLIntersectInSegment !(LineSegment 2 () r) --- | HLHLIntersectInHalfLine !(HalfLine 2 r) --- deriving (Show,Eq) +instance (Ord r, Fractional r) => LineSegment 2 () r `IsIntersectableWith` HalfLine 2 r where + nonEmptyIntersection = defaultNonEmptyIntersection --- nonEmptyIntersection NoHalfLineHalfLineIntersection = False --- nonEmptyIntersection _ = True + seg@(LineSegment s t) `intersect` hl@(HalfLine o _) = + match (supportingLine seg `intersect` supportingLine hl) $ + H (\NoIntersection -> coRec NoIntersection) + :& H (\p -> if onHalfLine p hl && p `intersects` seg then coRec p + else coRec NoIntersection + ) + :& H (\_line -> case (o `intersects` seg, onHalfLine (t^.unEndPoint.core) hl) of + (False,False) -> coRec NoIntersection + (False,True) -> coRec seg + (True,True) -> coRec $ LineSegment (Closed $ ext o) t + (True,False) -> coRec $ LineSegment s (Closed $ ext o) + ) + :& RNil --- hl' `intersect` hl = case supportingLine hl' `intersect` supportingLine hl of --- ParallelLines -> NoHalfLineHalfLineIntersection --- LineLineIntersection p -> if p `onHalfLine` hl' && p `onHalfLine` hl then HLHLIntersectInPoint p --- else NoHalfLineHalfLineIntersection --- SameLine _ -> let p = _startPoint hl' --- q = _startPoint hl --- seg = LineSegment (p :+ ()) (q :+ ()) --- in case (p `onHalfLine` hl, q `onHalfLine` hl') of --- (False,False) -> NoHalfLineHalfLineIntersection --- (False,True) -> HLHLIntersectInHalfLine hl --- (True, False) -> HLHLIntersectInHalfLine hl' --- (True, True) -> if hl == hl' then HLHLIntersectInHalfLine hl --- else HLHLIntersectInSegment seg +instance (Ord r, Fractional r, Arity d) => Point d r `IsIntersectableWith` HalfLine d r where + nonEmptyIntersection = defaultNonEmptyIntersection + intersects = onHalfLine + p `intersect` hl | p `intersects` hl = coRec p + | otherwise = coRec NoIntersection --- instance (Ord r, Fractional r) => (LineSegment 2 p r) `IsIntersectableWith` (HalfLine 2 r) where --- data Intersection (LineSegment 2 p r) (HalfLine 2 r) = NoSegmentHalfLineIntersection --- | SegmentHalfLineIntersection !(Point 2 r) --- | SegmentOnHalfLine !(LineSegment 2 () r) --- nonEmptyIntersection NoSegmentHalfLineIntersection = False --- nonEmptyIntersection _ = True +type instance IntersectionOf (HalfLine 2 r) (Boundary (Rectangle p r)) = + [ NoIntersection, Point 2 r, (Point 2 r, Point 2 r) , LineSegment 2 () r] --- s `intersect` hl = case supportingLine s `intersect` supportingLine hl of --- ParallelLines -> NoSegmentHalfLineIntersection --- LineLineIntersection p -> if p `onSegment` s && p `onHalfLine` hl then SegmentHalfLineIntersection p --- else NoSegmentHalfLineIntersection --- SameLine _ -> let p = s ^.start.core --- q = s ^.end.core --- r = hl ^.start.core --- seg a b = LineSegment (a :+ ()) (b :+ ()) --- in case (p `onHalfLine` hl, q `onHalfLine` hl) of --- (False, False) -> NoSegmentHalfLineIntersection --- (False, True) -> SegmentOnHalfLine $ seg r q --- (True, False) -> SegmentOnHalfLine $ seg p r --- (True, True) -> SegmentOnHalfLine $ seg p q +type instance IntersectionOf (HalfLine 2 r) (Rectangle p r) = [ NoIntersection + , Point 2 r + , LineSegment 2 () r + ] +instance (Ord r, Fractional r) + => HalfLine 2 r `IsIntersectableWith` Boundary (Rectangle p r) where + nonEmptyIntersection = defaultNonEmptyIntersection + hl@(HalfLine o v) `intersect` br = match (Line o v `intersect` br) $ + H coRec -- NoIntersection + :& H (\p -> if p `intersects` hl then coRec p else coRec NoIntersection) + :& H (\(p,q) -> case (p `intersects` hl, q `intersects` hl) of + (False,False) -> coRec NoIntersection + (False,True) -> coRec q + (True,False) -> coRec p + (True,True) -> coRec (p,q)) + :& H (\s@(LineSegment' p q) -> case ((p^.core) `intersects` hl, (q^.core) `intersects` hl) of + (False,False) -> coRec NoIntersection + (False,True) -> coRec $ ClosedLineSegment (ext o) q + (True,False) -> coRec $ ClosedLineSegment (ext o) p + (True,True) -> coRec s) + :& RNil +instance (Ord r, Fractional r) + => HalfLine 2 r `IsIntersectableWith` Rectangle p r where + nonEmptyIntersection = defaultNonEmptyIntersection + hl@(HalfLine o _) `intersect` rect = match (hl `intersect` Boundary rect) $ + H coRec -- NoIntersection + :& H (\p -> if o `insideBox` rect then coRec (ClosedLineSegment (ext o) (ext p)) + else coRec p -- p is on the boundary + ) + :& H (\(p,q) -> coRec $ ClosedLineSegment (ext p) (ext q)) + :& H coRec -- LineSegment + :& RNil + -- | Test if a point lies on a half-line onHalfLine :: (Ord r, Fractional r, Arity d) => Point d r -> HalfLine d r -> Bool p `onHalfLine` (HalfLine q v) = maybe False (>= 0) $ scalarMultiple (p .-. q) v - - diff --git a/src/Data/Geometry/HalfSpace.hs b/src/Data/Geometry/HalfSpace.hs --- a/src/Data/Geometry/HalfSpace.hs +++ b/src/Data/Geometry/HalfSpace.hs @@ -59,7 +59,7 @@ instance (Arity d, Eq r, Fractional r) => Eq (HalfSpace d r) where (HalfSpace h) == (HalfSpace h') = let u = h^.normalVec v = h'^.normalVec - d = quadrance (u ^+^ v) - (quadrance u) + d = quadrance (u ^+^ v) - quadrance u in h == h' && signum d == 1 -------------------------------------------------------------------------------- @@ -67,18 +67,18 @@ type HalfPlane = HalfSpace 2 - +{- HLINT ignore leftOf -} -- | Get the halfplane left of a line (i.e. "above") a line -- -- >>> leftOf $ horizontalLine 4 --- HalfSpace {_boundingPlane = HyperPlane {_inPlane = Point2 [0,4], _normalVec = Vector2 [0,1]}} +-- HalfSpace {_boundingPlane = HyperPlane {_inPlane = Point2 0 4, _normalVec = Vector2 0 1}} leftOf :: Num r => Line 2 r -> HalfPlane r leftOf l = (rightOf l)&boundingPlane.normalVec %~ ((-1) *^) -- | Get the halfplane right of a line (i.e. "below") a line -- -- >>> rightOf $ horizontalLine 4 --- HalfSpace {_boundingPlane = HyperPlane {_inPlane = Point2 [0,4], _normalVec = Vector2 [0,-1]}} +-- HalfSpace {_boundingPlane = HyperPlane {_inPlane = Point2 0 4, _normalVec = Vector2 0 (-1)}} rightOf :: Num r => Line 2 r -> HalfPlane r rightOf l = HalfSpace $ l^.re _asLine @@ -116,13 +116,13 @@ nonEmptyIntersection = defaultNonEmptyIntersection l@(Line o v) `intersect` h = match (l `intersect` m) $ - (H $ \NoIntersection -> if o `intersects` h + H (\NoIntersection -> if o `intersects` h then coRec l else coRec NoIntersection) - :& (H $ \p -> if (p .+^ v) `intersects` h + :& H (\p -> if (p .+^ v) `intersects` h then coRec $ HalfLine p v else coRec $ HalfLine p ((-1) *^ v)) - :& (H $ \_l -> coRec l) + :& H (\_l -> coRec l) :& RNil where m = h^.boundingPlane._asLine diff --git a/src/Data/Geometry/HyperPlane.hs b/src/Data/Geometry/HyperPlane.hs --- a/src/Data/Geometry/HyperPlane.hs +++ b/src/Data/Geometry/HyperPlane.hs @@ -1,6 +1,13 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE TemplateHaskell #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Data.Geometry.HyperPlane +-- Copyright : (C) Frank Staals +-- License : see the LICENSE file +-- Maintainer : Frank Staals +-------------------------------------------------------------------------------- module Data.Geometry.HyperPlane where import Control.DeepSeq @@ -77,7 +84,7 @@ -- the normal vector of the resulting plane is pointing "upwards". -- -- >>> from3Points origin (Point3 1 0 0) (Point3 0 1 0) --- HyperPlane {_inPlane = Point3 [0,0,0], _normalVec = Vector3 [0,0,1]} +-- HyperPlane {_inPlane = Point3 0 0 0, _normalVec = Vector3 0 0 1} from3Points :: Num r => Point 3 r -> Point 3 r -> Point 3 r -> HyperPlane 3 r from3Points p q r = let u = q .-. p v = r .-. p @@ -97,7 +104,7 @@ type instance IntersectionOf (Line 3 r) (Plane r) = [NoIntersection, Point 3 r, Line 3 r] -instance (Eq r, Fractional r) => (Line 3 r) `IsIntersectableWith` (Plane r) where +instance (Eq r, Fractional r) => Line 3 r `IsIntersectableWith` Plane r where nonEmptyIntersection = defaultNonEmptyIntersection l@(Line p v) `intersect` (HyperPlane q n) | denum == 0 = if num == 0 then coRec l else coRec NoIntersection @@ -140,7 +147,7 @@ -- y-axis. -- -- >>> planeCoordinatesWith (Plane origin (Vector3 0 0 1)) (Vector3 0 1 0) (Point3 10 10 0) --- Point2 [10.0,10.0] +-- Point2 10.0 10.0 planeCoordinatesWith :: Fractional r => Plane r -> Vector 3 r -> Point 3 r -> Point 2 r planeCoordinatesWith h vup = projectPoint . transformBy (planeCoordinatesTransform h vup) diff --git a/src/Data/Geometry/Interval.hs b/src/Data/Geometry/Interval.hs --- a/src/Data/Geometry/Interval.hs +++ b/src/Data/Geometry/Interval.hs @@ -1,15 +1,17 @@ -{-# LANGUAGE TemplateHaskell #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Data.Geometry.Interval +-- Copyright : (C) Frank Staals +-- License : see the LICENSE file +-- Maintainer : Frank Staals +-------------------------------------------------------------------------------- module Data.Geometry.Interval( - -- * 1 dimensional Intervals - Interval + -- * 1 dimensional Intervals + Interval (Interval, OpenInterval,ClosedInterval) , fromRange, toRange , _Range - , pattern OpenInterval - , pattern ClosedInterval - , pattern Interval - - -- * querying the start and end of intervals + -- * querying the start and end of intervals , HasStart(..), HasEnd(..) -- * Working with intervals , inInterval @@ -21,18 +23,18 @@ ) where import Control.DeepSeq -import Control.Lens (lens, (^.),(%~),(&), Lens') +import Control.Lens (Iso', Lens', iso, (%~), (&), (^.)) import Data.Bifunctor import Data.Bitraversable import Data.Ext -import qualified Data.Foldable as F +import qualified Data.Foldable as F import Data.Geometry.Properties import Data.Range -import Data.Semigroup(Arg(..)) -import qualified Data.Traversable as T +import Data.Semigroup (Arg (..)) +import qualified Data.Traversable as T import Data.Vinyl import Data.Vinyl.CoRec -import GHC.Generics (Generic) +import GHC.Generics (Generic) import Test.QuickCheck -------------------------------------------------------------------------------- @@ -42,11 +44,16 @@ -- We can think of an interval being defined as: -- -- >>> data Interval a r = Interval (EndPoint (r :+ a)) (EndPoint (r :+ a)) -newtype Interval a r = GInterval { toRange :: Range (r :+ a) } +newtype Interval a r = GInterval (Range (r :+ a)) deriving (Eq,Generic,Arbitrary) -_Range :: Lens' (Interval a r) (Range (r :+ a)) -_Range = lens toRange (const GInterval) +-- | Cast an interval to a range. +toRange :: Interval a r -> Range (r :+ a) +toRange (GInterval r) = r + +-- | Intervals and ranges are isomorphic. +_Range :: Iso' (Interval a r) (Range (r :+ a)) +_Range = iso toRange fromRange {-# INLINE _Range #-} -- | Constrct an interval from a Range @@ -78,7 +85,7 @@ -- inInterval and inRange is that the extra value is *not* used in the -- comparison with inInterval, whereas it is in inRange. inInterval :: Ord r => r -> Interval a r -> Bool -x `inInterval` r = x `inRange` (fmap (^.core) $ r^._Range ) +x `inInterval` r = x `inRange` fmap (^.core) (r^._Range ) pattern OpenInterval :: (r :+ a) -> (r :+ a) -> Interval a r @@ -122,14 +129,14 @@ type instance IntersectionOf (Interval a r) (Interval a r) = [NoIntersection, Interval a r] -instance Ord r => (Interval a r) `IsIntersectableWith` (Interval a r) where +instance Ord r => Interval a r `IsIntersectableWith` Interval a r where nonEmptyIntersection = defaultNonEmptyIntersection (GInterval r) `intersect` (GInterval s) = match (r' `intersect` s') $ - (H $ \NoIntersection -> coRec NoIntersection) - :& (H $ \(Range l u) -> coRec . GInterval $ Range (l&unEndPoint %~ g) - (u&unEndPoint %~ g) ) + H (\NoIntersection -> coRec NoIntersection) + :& H (\(Range l u) -> coRec . GInterval $ Range (l&unEndPoint %~ g) + (u&unEndPoint %~ g) ) :& RNil where f x = Arg (x^.core) x diff --git a/src/Data/Geometry/Interval/Util.hs b/src/Data/Geometry/Interval/Util.hs --- a/src/Data/Geometry/Interval/Util.hs +++ b/src/Data/Geometry/Interval/Util.hs @@ -1,4 +1,12 @@ {-# LANGUAGE TemplateHaskell #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Data.Geometry.Interval.Util +-- Copyright : (C) Frank Staals +-- License : see the LICENSE file +-- Maintainer : Frank Staals +-- +-------------------------------------------------------------------------------- module Data.Geometry.Interval.Util where import Control.DeepSeq diff --git a/src/Data/Geometry/IntervalTree.hs b/src/Data/Geometry/IntervalTree.hs --- a/src/Data/Geometry/IntervalTree.hs +++ b/src/Data/Geometry/IntervalTree.hs @@ -1,4 +1,11 @@ {-# LANGUAGE TemplateHaskell #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Data.Geometry.IntervalTree +-- Copyright : (C) Frank Staals +-- License : see the LICENSE file +-- Maintainer : Frank Staals +-------------------------------------------------------------------------------- module Data.Geometry.IntervalTree( NodeData(..) , splitPoint, intervalsLeft, intervalsRight , IntervalTree(..), unIntervalTree @@ -44,8 +51,8 @@ -- -- \(O(n)\) createTree :: Ord r => [r] -> IntervalTree i r -createTree pts = IntervalTree . asBalancedBinTree - . map (\m -> NodeData m mempty mempty) $ pts +createTree = IntervalTree . asBalancedBinTree + . map (\m -> NodeData m mempty mempty) -- | Build an interval tree diff --git a/src/Data/Geometry/KDTree.hs b/src/Data/Geometry/KDTree.hs --- a/src/Data/Geometry/KDTree.hs +++ b/src/Data/Geometry/KDTree.hs @@ -1,25 +1,31 @@ -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE UndecidableInstances #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Data.Geometry.KDTree +-- Copyright : (C) Frank Staals +-- License : see the LICENSE file +-- Maintainer : Frank Staals +-------------------------------------------------------------------------------- module Data.Geometry.KDTree where -import Control.Lens hiding (imap, element, Empty, (:<)) +import Control.Lens hiding (Empty, element, imap, (:<)) import Data.BinaryTree -import Unsafe.Coerce(unsafeCoerce) import Data.Ext -import qualified Data.Foldable as F +import qualified Data.Foldable as F import Data.Geometry.Box import Data.Geometry.Point import Data.Geometry.Properties import Data.Geometry.Vector -import qualified Data.List.NonEmpty as NonEmpty -import Data.Maybe (fromJust) +import Data.LSeq (LSeq, pattern (:<|)) +import qualified Data.LSeq as LSeq +import qualified Data.List.NonEmpty as NonEmpty import Data.Proxy -import Data.LSeq (LSeq, pattern (:<|)) -import qualified Data.LSeq as LSeq import Data.Util -import qualified Data.Vector.Fixed as FV +import qualified Data.Vector.Fixed as FV import GHC.TypeLits -import Prelude hiding (replicate) +import Prelude hiding (replicate) +import Unsafe.Coerce (unsafeCoerce) -------------------------------------------------------------------------------- @@ -165,7 +171,7 @@ where -- i = traceShow (c,j) j - m = let xs = fromJust $ pts^?element' (i-1) + m = let xs = pts^?!element' (i-1) in xs `LSeq.index` (F.length xs `div` 2) -- Since the input seq has >= 2 elems, F.length xs / 2 >= 1. It follows diff --git a/src/Data/Geometry/Line.hs b/src/Data/Geometry/Line.hs --- a/src/Data/Geometry/Line.hs +++ b/src/Data/Geometry/Line.hs @@ -48,14 +48,14 @@ type instance IntersectionOf (Point d r) (Line d r) = [NoIntersection, Point d r] -instance (Eq r, Fractional r, Arity d) => (Point d r) `IsIntersectableWith` (Line d r) where +instance (Eq r, Fractional r, Arity d) => Point d r `IsIntersectableWith` Line d r where nonEmptyIntersection = defaultNonEmptyIntersection intersects = onLine p `intersect` l | p `intersects` l = coRec p | otherwise = coRec NoIntersection instance {-# OVERLAPPING #-} (Ord r, Num r) - => (Point 2 r) `IsIntersectableWith` (Line 2 r) where + => Point 2 r `IsIntersectableWith` Line 2 r where nonEmptyIntersection = defaultNonEmptyIntersection intersects = onLine2 p `intersect` l | p `intersects` l = coRec p @@ -67,7 +67,7 @@ instance (Ord r, Fractional r) - => (Line 2 r) `IsIntersectableWith` (Boundary (Rectangle p r)) where + => Line 2 r `IsIntersectableWith` Boundary (Rectangle p r) where nonEmptyIntersection = defaultNonEmptyIntersection line' `intersect` (Boundary rect) = case asAP segP of @@ -104,12 +104,12 @@ instance (Ord r, Fractional r) - => (Line 2 r) `IsIntersectableWith` (Rectangle p r) where + => Line 2 r `IsIntersectableWith` Rectangle p r where nonEmptyIntersection = defaultNonEmptyIntersection - line' `intersect` rect = match (line' `intersect` (Boundary rect)) $ - (H $ \NoIntersection -> coRec NoIntersection) - :& (H $ \p@(Point2 _ _) -> coRec p) - :& (H $ \(p,q) -> coRec $ ClosedLineSegment (ext p) (ext q)) - :& (H $ \s -> coRec s) + line' `intersect` rect = match (line' `intersect` Boundary rect) $ + H coRec -- NoIntersection + :& H coRec -- Point2 + :& H (\(p,q) -> coRec $ ClosedLineSegment (ext p) (ext q)) + :& H coRec -- LineSegment :& RNil diff --git a/src/Data/Geometry/Line/Internal.hs b/src/Data/Geometry/Line/Internal.hs --- a/src/Data/Geometry/Line/Internal.hs +++ b/src/Data/Geometry/Line/Internal.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE UndecidableInstances #-} -------------------------------------------------------------------------------- @@ -34,8 +33,15 @@ data Line d r = Line { _anchorPoint :: !(Point d r) , _direction :: !(Vector d r) } deriving Generic -makeLenses ''Line +-- | Line anchor point. +anchorPoint :: Lens' (Line d r) (Point d r) +anchorPoint = lens _anchorPoint (\line pt -> line{_anchorPoint=pt}) + +-- | Line direction. +direction :: Lens' (Line d r) (Vector d r) +direction = lens _direction (\line dir -> line{_direction=dir}) + instance (Show r, Arity d) => Show (Line d r) where show (Line p v) = concat [ "Line (", show p, ") (", show v, ")" ] @@ -69,9 +75,11 @@ lineThrough :: (Num r, Arity d) => Point d r -> Point d r -> Line d r lineThrough p q = Line p (q .-. p) +-- | Vertical line with a given X-coordinate. verticalLine :: Num r => r -> Line 2 r verticalLine x = Line (Point2 x 0) (Vector2 0 1) +-- | Horizontal line with a given Y-coordinate. horizontalLine :: Num r => r -> Line 2 r horizontalLine y = Line (Point2 0 y) (Vector2 1 0) @@ -80,7 +88,7 @@ -- oriented such that v points into the left halfplane of m. -- -- >>> perpendicularTo $ Line (Point2 3 4) (Vector2 (-1) 2) --- Line (Point2 [3,4]) (Vector2 [-2,-1]) +-- Line (Point2 3 4) (Vector2 (-2) (-1)) perpendicularTo :: Num r => Line 2 r -> Line 2 r perpendicularTo (Line p ~(Vector2 vx vy)) = Line p (Vector2 (-vy) vx) @@ -137,15 +145,24 @@ toOffset p (Line q v) = scalarMultiple (p .-. q) v --- | Given point p *on* a line (Line q v), Get the scalar lambda s.t. --- p = q + lambda v. (So this is an unsafe version of 'toOffset') +-- | Given point p near a line (Line q v), get the scalar lambda s.t. +-- the distance between 'p' and 'q + lambda v' is minimized. -- --- pre: the input point p lies on the line l. +-- >>> toOffset' (Point2 1 1) (lineThrough origin $ Point2 10 10) +-- 0.1 +-- +-- >>> toOffset' (Point2 5 5) (lineThrough origin $ Point2 10 10) +-- 0.5 +-- +-- \<6,4\> is not on the line but we can still point closest to it. +-- >>> toOffset' (Point2 6 4) (lineThrough origin $ Point2 10 10) +-- 0.5 toOffset' :: (Eq r, Fractional r, Arity d) => Point d r -> Line d r -> r -toOffset' p = fromJust' . toOffset p - where - fromJust' (Just x) = x - fromJust' _ = error "toOffset: Nothing" +toOffset' p (Line q v) = dot (p .-. q) v / quadrance v +-- toOffset' p = fromJust' . toOffset p +-- where +-- fromJust' (Just x) = x +-- fromJust' _ = error "toOffset: Nothing" -- | The intersection of two lines is either: NoIntersection, a point or a line. @@ -154,7 +171,7 @@ , Line 2 r ] -instance (Eq r, Fractional r) => (Line 2 r) `IsIntersectableWith` (Line 2 r) where +instance (Eq r, Fractional r) => Line 2 r `IsIntersectableWith` Line 2 r where nonEmptyIntersection = defaultNonEmptyIntersection @@ -207,6 +224,7 @@ fromLinearFunction :: Num r => r -> r -> Line 2 r fromLinearFunction a b = Line (Point2 0 b) (Vector2 1 a) +{- HLINT ignore toLinearFunction -} -- | get values a,b s.t. the input line is described by y = ax + b. -- returns Nothing if the line is vertical toLinearFunction :: forall r. (Fractional r, Eq r) @@ -274,6 +292,9 @@ liesAbove :: (Ord r, Num r) => Point 2 r -> Line 2 r -> Bool q `liesAbove` l = q `onSideUpDown` l == Above +-- | Test if the query point q lies (strictly) above line l +liesBelow :: (Ord r, Num r) => Point 2 r -> Line 2 r -> Bool +q `liesBelow` l = q `onSideUpDown` l == Below -- | Get the bisector between two points bisector :: Fractional r => Point 2 r -> Point 2 r -> Line 2 r diff --git a/src/Data/Geometry/LineSegment.hs b/src/Data/Geometry/LineSegment.hs --- a/src/Data/Geometry/LineSegment.hs +++ b/src/Data/Geometry/LineSegment.hs @@ -10,306 +10,22 @@ -- Line segment data type and some basic functions on line segments -- -------------------------------------------------------------------------------- -module Data.Geometry.LineSegment( LineSegment - , pattern LineSegment - , pattern LineSegment' - , pattern ClosedLineSegment - , pattern OpenLineSegment - , endPoints - - , _SubLine - , module Data.Geometry.Interval - - - , toLineSegment - , onSegment - , orderedEndPoints - , segmentLength - , sqDistanceToSeg, sqDistanceToSegArg - , flipSegment - - , interpolate - ) where - -import Control.Arrow ((&&&)) -import Control.DeepSeq -import Control.Lens -import Data.Ext -import qualified Data.Foldable as F -import Data.Geometry.Box.Internal -import Data.Geometry.Interval hiding (width, midPoint) -import Data.Geometry.Line.Internal -import Data.Geometry.Point -import Data.Geometry.Properties -import Data.Geometry.SubLine -import Data.Geometry.Transformation -import Data.Geometry.Vector -import Data.Ord (comparing) -import Data.Vinyl -import Data.Vinyl.CoRec -import GHC.TypeLits -import Test.QuickCheck(Arbitrary(..)) - --------------------------------------------------------------------------------- --- * d-dimensional LineSegments - - --- | Line segments. LineSegments have a start and end point, both of which may --- contain additional data of type p. We can think of a Line-Segment being defined as --- --- --- >>> data LineSegment d p r = LineSegment (EndPoint (Point d r :+ p)) (EndPoint (Point d r :+ p)) -newtype LineSegment d p r = GLineSegment { _unLineSeg :: Interval p (Point d r)} - -makeLenses ''LineSegment - - --- | Pattern that essentially models the line segment as a: --- --- >>> data LineSegment d p r = LineSegment (EndPoint (Point d r :+ p)) (EndPoint (Point d r :+ p)) -pattern LineSegment :: EndPoint (Point d r :+ p) - -> EndPoint (Point d r :+ p) - -> LineSegment d p r -pattern LineSegment s t = GLineSegment (Interval s t) -{-# COMPLETE LineSegment #-} - --- | Gets the start and end point, but forgetting if they are open or closed. -pattern LineSegment' :: Point d r :+ p - -> Point d r :+ p - -> LineSegment d p r -pattern LineSegment' s t <- ((^.start) &&& (^.end) -> (s,t)) -{-# COMPLETE LineSegment' #-} - -pattern ClosedLineSegment :: Point d r :+ p -> Point d r :+ p -> LineSegment d p r -pattern ClosedLineSegment s t = GLineSegment (ClosedInterval s t) -{-# COMPLETE ClosedLineSegment #-} - -pattern OpenLineSegment :: Point d r :+ p -> Point d r :+ p -> LineSegment d p r -pattern OpenLineSegment s t = GLineSegment (OpenInterval s t) -{-# COMPLETE OpenLineSegment #-} - - - -type instance Dimension (LineSegment d p r) = d -type instance NumType (LineSegment d p r) = r - -instance HasStart (LineSegment d p r) where - type StartCore (LineSegment d p r) = Point d r - type StartExtra (LineSegment d p r) = p - start = unLineSeg.start - -instance HasEnd (LineSegment d p r) where - type EndCore (LineSegment d p r) = Point d r - type EndExtra (LineSegment d p r) = p - end = unLineSeg.end - -instance (Arbitrary r, Arbitrary p, Arity d) => Arbitrary (LineSegment d p r) where - arbitrary = LineSegment <$> arbitrary <*> arbitrary - -deriving instance (Arity d, NFData r, NFData p) => NFData (LineSegment d p r) - - --- | Traversal to access the endpoints. Note that this traversal --- allows you to change more or less everything, even the dimension --- and the numeric type used, but it preservers if the segment is open --- or closed. -endPoints :: Traversal (LineSegment d p r) (LineSegment d' q s) - (Point d r :+ p) (Point d' s :+ q) -endPoints = \f (LineSegment p q) -> LineSegment <$> traverse f p - <*> traverse f q - -_SubLine :: (Num r, Arity d) => Iso' (LineSegment d p r) (SubLine d p r r) -_SubLine = iso segment2SubLine subLineToSegment -{-# INLINE _SubLine #-} - -segment2SubLine :: (Num r, Arity d) - => LineSegment d p r -> SubLine d p r r -segment2SubLine ss = SubLine (Line p (q .-. p)) (Interval s e) - where - p = ss^.start.core - q = ss^.end.core - (Interval a b) = ss^.unLineSeg - s = a&unEndPoint.core .~ 0 - e = b&unEndPoint.core .~ 1 - -subLineToSegment :: (Num r, Arity d) => SubLine d p r r -> LineSegment d p r -subLineToSegment sl = let (Interval s' e') = (fixEndPoints sl)^.subRange - s = s'&unEndPoint %~ (^.extra) - e = e'&unEndPoint %~ (^.extra) - in LineSegment s e - -instance (Num r, Arity d) => HasSupportingLine (LineSegment d p r) where - supportingLine s = lineThrough (s^.start.core) (s^.end.core) - - -instance (Show r, Show p, Arity d) => Show (LineSegment d p r) where - show ~(LineSegment p q) = concat ["LineSegment (", show p, ") (", show q, ")"] - -deriving instance (Eq r, Eq p, Arity d) => Eq (LineSegment d p r) --- deriving instance (Ord r, Ord p, Arity d) => Ord (LineSegment d p r) -deriving instance Arity d => Functor (LineSegment d p) - -instance PointFunctor (LineSegment d p) where - pmap f ~(LineSegment s e) = LineSegment (s&unEndPoint.core %~ f) - (e&unEndPoint.core %~ f) - -instance Arity d => IsBoxable (LineSegment d p r) where - boundingBox l = boundingBox (l^.start.core) <> boundingBox (l^.end.core) - -instance (Fractional r, Arity d, Arity (d + 1)) => IsTransformable (LineSegment d p r) where - transformBy = transformPointFunctor - -instance Arity d => Bifunctor (LineSegment d) where - bimap f g (GLineSegment i) = GLineSegment $ bimap f (fmap g) i - - - --- ** Converting between Lines and LineSegments - --- | Directly convert a line into a line segment. -toLineSegment :: (Monoid p, Num r, Arity d) => Line d r -> LineSegment d p r -toLineSegment (Line p v) = ClosedLineSegment (p :+ mempty) - (p .+^ v :+ mempty) - --- *** Intersecting LineSegments - -type instance IntersectionOf (LineSegment 2 p r) (LineSegment 2 p r) = [ NoIntersection - , Point 2 r - , LineSegment 2 p r - ] - -type instance IntersectionOf (LineSegment 2 p r) (Line 2 r) = [ NoIntersection - , Point 2 r - , LineSegment 2 p r - ] - - -instance (Ord r, Fractional r) => - (LineSegment 2 p r) `IsIntersectableWith` (LineSegment 2 p r) where - nonEmptyIntersection = defaultNonEmptyIntersection - - a `intersect` b = match ((a^._SubLine) `intersect` (b^._SubLine)) $ - (H coRec) - :& (H coRec) - :& (H $ coRec . subLineToSegment) - :& RNil - -instance (Ord r, Fractional r) => - (LineSegment 2 p r) `IsIntersectableWith` (Line 2 r) where - nonEmptyIntersection = defaultNonEmptyIntersection - - s `intersect` l = let ubSL = s^._SubLine.re _unBounded.to dropExtra - in match (ubSL `intersect` (fromLine l)) $ - (H coRec) - :& (H $ coRec) - :& (H $ const (coRec s)) - :& RNil - --- * Functions on LineSegments - --- | Test if a point lies on a line segment. --- --- >>> (Point2 1 0) `onSegment` (ClosedLineSegment (origin :+ ()) (Point2 2 0 :+ ())) --- True --- >>> (Point2 1 1) `onSegment` (ClosedLineSegment (origin :+ ()) (Point2 2 0 :+ ())) --- False --- >>> (Point2 5 0) `onSegment` (ClosedLineSegment (origin :+ ()) (Point2 2 0 :+ ())) --- False --- >>> (Point2 (-1) 0) `onSegment` (ClosedLineSegment (origin :+ ()) (Point2 2 0 :+ ())) --- False --- >>> (Point2 1 1) `onSegment` (ClosedLineSegment (origin :+ ()) (Point2 3 3 :+ ())) --- True --- --- Note that the segments are assumed to be closed. So the end points lie on the segment. --- --- >>> (Point2 2 0) `onSegment` (ClosedLineSegment (origin :+ ()) (Point2 2 0 :+ ())) --- True --- >>> origin `onSegment` (ClosedLineSegment (origin :+ ()) (Point2 2 0 :+ ())) --- True --- --- --- This function works for arbitrary dimensons. --- --- >>> (Point3 1 1 1) `onSegment` (ClosedLineSegment (origin :+ ()) (Point3 3 3 3 :+ ())) --- True --- >>> (Point3 1 2 1) `onSegment` (ClosedLineSegment (origin :+ ()) (Point3 3 3 3 :+ ())) --- False -onSegment :: (Ord r, Fractional r, Arity d) - => Point d r -> LineSegment d p r -> Bool -p `onSegment` l = let s = l^.start.core - t = l^.end.core - inRange' x = 0 <= x && x <= 1 - in - if s == t -- zero length segment - then p == s - else maybe False inRange' $ scalarMultiple (p .-. s) (t .-. s) - - --- | The left and right end point (or left below right if they have equal x-coords) -orderedEndPoints :: Ord r => LineSegment 2 p r -> (Point 2 r :+ p, Point 2 r :+ p) -orderedEndPoints s = if pc <= qc then (p, q) else (q,p) - where - p@(pc :+ _) = s^.start - q@(qc :+ _) = s^.end - - --- | Length of the line segment -segmentLength :: (Arity d, Floating r) => LineSegment d p r -> r -segmentLength ~(LineSegment' p q) = distanceA (p^.core) (q^.core) - - --- | Squared distance from the point to the Segment s. The same remark as for --- the 'sqDistanceToSegArg' applies here. -sqDistanceToSeg :: (Arity d, Fractional r, Ord r) => Point d r -> LineSegment d p r -> r -sqDistanceToSeg p = fst . sqDistanceToSegArg p - - --- | Squared distance from the point to the Segment s, and the point on s --- realizing it. Note that if the segment is *open*, the closest point --- returned may be one of the (open) end points, even though technically the --- end point does not lie on the segment. (The true closest point then lies --- arbitrarily close to the end point). -sqDistanceToSegArg :: (Arity d, Fractional r, Ord r) - => Point d r -> LineSegment d p r -> (r, Point d r) -sqDistanceToSegArg p s = let m = sqDistanceToArg p (supportingLine s) - xs = m : map (\(q :+ _) -> (qdA p q, q)) [s^.start, s^.end] - in F.minimumBy (comparing fst) - . filter (flip onSegment s . snd) $ xs - --- | flips the start and end point of the segment -flipSegment :: LineSegment d p r -> LineSegment d p r -flipSegment s = let p = s^.start - q = s^.end - in (s&start .~ q)&end .~ p - --- testSeg :: LineSegment 2 () Rational --- testSeg = LineSegment (Open $ ext origin) (Closed $ ext (Point2 10 0)) - --- horL' :: Line 2 Rational --- horL' = horizontalLine 0 - --- testI = testSeg `intersect` horL' - +module Data.Geometry.LineSegment + ( LineSegment(LineSegment, LineSegment', ClosedLineSegment, OpenLineSegment) + , endPoints --- ff = bimap (fmap Val) (const ()) + , _SubLine + , module Data.Geometry.Interval --- ss' = let (LineSegment p q) = testSeg in --- LineSegment (p&unEndPoint %~ ff) --- (q&unEndPoint %~ ff) + , toLineSegment + , orderedEndPoints + , segmentLength + , sqSegmentLength + , sqDistanceToSeg, sqDistanceToSegArg + , flipSegment --- ss'' = ss'^._SubLine + , interpolate, sampleLineSegment + ) where --- | Linearly interpolate the two endpoints with a value in the range [0,1] --- --- >>> interpolate 0.5 $ ClosedLineSegment (ext $ origin) (ext $ Point2 10.0 10.0) --- Point2 [5.0,5.0] --- >>> interpolate 0.1 $ ClosedLineSegment (ext $ origin) (ext $ Point2 10.0 10.0) --- Point2 [1.0,1.0] --- >>> interpolate 0 $ ClosedLineSegment (ext $ origin) (ext $ Point2 10.0 10.0) --- Point2 [0.0,0.0] --- >>> interpolate 1 $ ClosedLineSegment (ext $ origin) (ext $ Point2 10.0 10.0) --- Point2 [10.0,10.0] -interpolate :: (Fractional r, Arity d) => r -> LineSegment d p r -> Point d r -interpolate t (LineSegment' p q) = Point $ (asV p ^* (1-t)) ^+^ (asV q ^* t) - where - asV = (^.core.vector) +import Data.Geometry.Interval hiding (width, midPoint) +import Data.Geometry.LineSegment.Internal diff --git a/src/Data/Geometry/LineSegment/Internal.hs b/src/Data/Geometry/LineSegment/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Data/Geometry/LineSegment/Internal.hs @@ -0,0 +1,406 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE UndecidableInstances #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Data.Geometry.LineSegment.Internal +-- Copyright : (C) Frank Staals +-- License : see the LICENSE file +-- Maintainer : Frank Staals +-- +-- Line segment data type and some basic functions on line segments +-- +-------------------------------------------------------------------------------- +module Data.Geometry.LineSegment.Internal + ( LineSegment(LineSegment, LineSegment', ClosedLineSegment, OpenLineSegment) + , endPoints + + , _SubLine + , module Data.Geometry.Interval + + + , toLineSegment + , onSegment, onSegment2 + , orderedEndPoints + , segmentLength + , sqSegmentLength + , sqDistanceToSeg, sqDistanceToSegArg + , flipSegment + + , interpolate + , validSegment + , sampleLineSegment + ) where + +import Control.Arrow ((&&&)) +import Control.DeepSeq +import Control.Lens +import Control.Monad.Random +import Data.Ext +import qualified Data.Foldable as F +import Data.Geometry.Box.Internal +import Data.Geometry.Interval hiding (width, midPoint) +import Data.Geometry.Line.Internal +import Data.Geometry.Point +import Data.Geometry.Properties +import Data.Geometry.SubLine +import Data.Geometry.Transformation +import Data.Geometry.Vector +import Data.Ord (comparing) +import Data.Vinyl +import Data.Vinyl.CoRec +import GHC.TypeLits +import Test.QuickCheck (Arbitrary(..), suchThatMap) +import Text.Read + +-------------------------------------------------------------------------------- +-- * d-dimensional LineSegments + + +-- | Line segments. LineSegments have a start and end point, both of which may +-- contain additional data of type p. We can think of a Line-Segment being defined as +-- +-- +-- >>> data LineSegment d p r = LineSegment (EndPoint (Point d r :+ p)) (EndPoint (Point d r :+ p)) +-- +-- it is assumed that the two endpoints of the line segment are disjoint. This is not checked. +newtype LineSegment d p r = GLineSegment { _unLineSeg :: Interval p (Point d r) } + +makeLenses ''LineSegment + + +pattern LineSegment :: EndPoint (Point d r :+ p) + -> EndPoint (Point d r :+ p) + -> LineSegment d p r +pattern LineSegment s t = GLineSegment (Interval s t) +{-# COMPLETE LineSegment #-} + +-- | Gets the start and end point, but forgetting if they are open or closed. +pattern LineSegment' :: Point d r :+ p + -> Point d r :+ p + -> LineSegment d p r +pattern LineSegment' s t <- ((^.start) &&& (^.end) -> (s,t)) +{-# COMPLETE LineSegment' #-} + +pattern ClosedLineSegment :: Point d r :+ p -> Point d r :+ p -> LineSegment d p r +pattern ClosedLineSegment s t = GLineSegment (ClosedInterval s t) +{-# COMPLETE ClosedLineSegment #-} + +pattern OpenLineSegment :: Point d r :+ p -> Point d r :+ p -> LineSegment d p r +pattern OpenLineSegment s t = GLineSegment (OpenInterval s t) +{-# COMPLETE OpenLineSegment #-} + + + +type instance Dimension (LineSegment d p r) = d +type instance NumType (LineSegment d p r) = r + +instance HasStart (LineSegment d p r) where + type StartCore (LineSegment d p r) = Point d r + type StartExtra (LineSegment d p r) = p + start = unLineSeg.start + +instance HasEnd (LineSegment d p r) where + type EndCore (LineSegment d p r) = Point d r + type EndExtra (LineSegment d p r) = p + end = unLineSeg.end + +instance (Arbitrary r, Arbitrary p, Eq r, Arity d) => Arbitrary (LineSegment d p r) where + arbitrary = suchThatMap ((,) <$> arbitrary <*> arbitrary) + (uncurry validSegment) + + +deriving instance (Arity d, NFData r, NFData p) => NFData (LineSegment d p r) + +sampleLineSegment :: (Arity d, RandomGen g, Random r) => Rand g (LineSegment d () r) +sampleLineSegment = do + a <- ext <$> getRandom + a' <- getRandom + b <- ext <$> getRandom + b' <- getRandom + pure $ LineSegment (if a' then Open a else Closed a) (if b' then Open b else Closed b) + + +{- HLINT ignore endPoints -} +-- | Traversal to access the endpoints. Note that this traversal +-- allows you to change more or less everything, even the dimension +-- and the numeric type used, but it preservers if the segment is open +-- or closed. +endPoints :: Traversal (LineSegment d p r) (LineSegment d' q s) + (Point d r :+ p) (Point d' s :+ q) +endPoints = \f (LineSegment p q) -> LineSegment <$> traverse f p + <*> traverse f q + +_SubLine :: (Num r, Arity d) => Iso' (LineSegment d p r) (SubLine d p r r) +_SubLine = iso segment2SubLine subLineToSegment +{-# INLINE _SubLine #-} + +segment2SubLine :: (Num r, Arity d) + => LineSegment d p r -> SubLine d p r r +segment2SubLine ss = SubLine (Line p (q .-. p)) (Interval s e) + where + p = ss^.start.core + q = ss^.end.core + (Interval a b) = ss^.unLineSeg + s = a&unEndPoint.core .~ 0 + e = b&unEndPoint.core .~ 1 + +{- HLINT ignore subLineToSegment -} +subLineToSegment :: (Num r, Arity d) => SubLine d p r r -> LineSegment d p r +subLineToSegment sl = let Interval s' e' = (fixEndPoints sl)^.subRange + s = s'&unEndPoint %~ (^.extra) + e = e'&unEndPoint %~ (^.extra) + in LineSegment s e + +instance (Num r, Arity d) => HasSupportingLine (LineSegment d p r) where + supportingLine s = lineThrough (s^.start.core) (s^.end.core) + + +instance (Show r, Show p, Arity d) => Show (LineSegment d p r) where + showsPrec d (LineSegment p' q') = case (p',q') of + (Closed p, Closed q) -> f "ClosedLineSegment" p q + (Open p, Open q) -> f "OpenLineSegment" p q + (p,q) -> f "LineSegment" p q + where + app_prec = 10 + f :: (Show a, Show b) => String -> a -> b -> String -> String + f cn p q = showParen (d > app_prec) $ + showString cn . showString " " + . showsPrec (app_prec+1) p + . showString " " + . showsPrec (app_prec+1) q + +instance (Read r, Read p, Arity d) => Read (LineSegment d p r) where + readPrec = parens $ (prec app_prec $ do + Ident "ClosedLineSegment" <- lexP + p <- step readPrec + q <- step readPrec + return (ClosedLineSegment p q)) + +++ + (prec app_prec $ do + Ident "OpenLineSegment" <- lexP + p <- step readPrec + q <- step readPrec + return (OpenLineSegment p q)) + +++ + (prec app_prec $ do + Ident "LineSegment" <- lexP + p <- step readPrec + q <- step readPrec + return (LineSegment p q)) + where app_prec = 10 + + +deriving instance (Eq r, Eq p, Arity d) => Eq (LineSegment d p r) +-- deriving instance (Ord r, Ord p, Arity d) => Ord (LineSegment d p r) +deriving instance Arity d => Functor (LineSegment d p) + +instance PointFunctor (LineSegment d p) where + pmap f ~(LineSegment s e) = LineSegment (s&unEndPoint.core %~ f) + (e&unEndPoint.core %~ f) + +instance Arity d => IsBoxable (LineSegment d p r) where + boundingBox l = boundingBox (l^.start.core) <> boundingBox (l^.end.core) + +instance (Fractional r, Arity d, Arity (d + 1)) => IsTransformable (LineSegment d p r) where + transformBy = transformPointFunctor + +instance Arity d => Bifunctor (LineSegment d) where + bimap f g (GLineSegment i) = GLineSegment $ bimap f (fmap g) i + + + +-- ** Converting between Lines and LineSegments + +-- | Directly convert a line into a line segment. +toLineSegment :: (Monoid p, Num r, Arity d) => Line d r -> LineSegment d p r +toLineSegment (Line p v) = ClosedLineSegment (p :+ mempty) + (p .+^ v :+ mempty) + +-- *** Intersecting LineSegments + +type instance IntersectionOf (Point d r) (LineSegment d p r) = [ NoIntersection + , Point d r + ] + +type instance IntersectionOf (LineSegment 2 p r) (LineSegment 2 p r) = [ NoIntersection + , Point 2 r + , LineSegment 2 p r + ] + +type instance IntersectionOf (LineSegment 2 p r) (Line 2 r) = [ NoIntersection + , Point 2 r + , LineSegment 2 p r + ] + + +instance {-# OVERLAPPING #-} (Ord r, Num r) + => Point 2 r `IsIntersectableWith` LineSegment 2 p r where + nonEmptyIntersection = defaultNonEmptyIntersection + intersects = onSegment2 + p `intersect` seg | p `intersects` seg = coRec p + | otherwise = coRec NoIntersection + +instance {-# OVERLAPPABLE #-} (Ord r, Fractional r, Arity d) + => Point d r `IsIntersectableWith` LineSegment d p r where + nonEmptyIntersection = defaultNonEmptyIntersection + intersects = onSegment + p `intersect` seg | p `intersects` seg = coRec p + | otherwise = coRec NoIntersection + +-- | Test if a point lies on a line segment. +-- +-- As a user, you should typically just use 'intersects' instead. +onSegment :: (Ord r, Fractional r, Arity d) => Point d r -> LineSegment d p r -> Bool +p `onSegment` (LineSegment up vp) = + maybe False inRange' (scalarMultiple (p .-. u) (v .-. u)) + where + u = up^.unEndPoint.core + v = vp^.unEndPoint.core + + atMostUpperBound = if isClosed vp then (<= 1) else (< 1) + atLeastLowerBound = if isClosed up then (0 <=) else (0 <) + + inRange' x = atLeastLowerBound x && atMostUpperBound x + -- the type of test we use for the 2D version might actually also + -- work in higher dimensions that might allow us to drop the + -- Fractional constraint + + + +instance (Ord r, Fractional r) => + LineSegment 2 p r `IsIntersectableWith` LineSegment 2 p r where + nonEmptyIntersection = defaultNonEmptyIntersection + + a `intersect` b = match ((a^._SubLine) `intersect` (b^._SubLine)) $ + H coRec + :& H coRec + :& H (coRec . subLineToSegment) + :& RNil + +instance (Ord r, Fractional r) => + LineSegment 2 p r `IsIntersectableWith` Line 2 r where + nonEmptyIntersection = defaultNonEmptyIntersection + + s `intersect` l = let ubSL = s^._SubLine.re _unBounded.to dropExtra + in match (ubSL `intersect` fromLine l) $ + H coRec + :& H coRec + :& H (const (coRec s)) + :& RNil + + + +-- * Functions on LineSegments + +-- | Test if a point lies on a line segment. +-- +-- >>> (Point2 1 0) `onSegment2` (ClosedLineSegment (origin :+ ()) (Point2 2 0 :+ ())) +-- True +-- >>> (Point2 1 1) `onSegment2` (ClosedLineSegment (origin :+ ()) (Point2 2 0 :+ ())) +-- False +-- >>> (Point2 5 0) `onSegment2` (ClosedLineSegment (origin :+ ()) (Point2 2 0 :+ ())) +-- False +-- >>> (Point2 (-1) 0) `onSegment2` (ClosedLineSegment (origin :+ ()) (Point2 2 0 :+ ())) +-- False +-- >>> (Point2 1 1) `onSegment2` (ClosedLineSegment (origin :+ ()) (Point2 3 3 :+ ())) +-- True +-- >>> (Point2 2 0) `onSegment2` (ClosedLineSegment (origin :+ ()) (Point2 2 0 :+ ())) +-- True +-- >>> origin `onSegment2` (ClosedLineSegment (origin :+ ()) (Point2 2 0 :+ ())) +-- True +onSegment2 :: (Ord r, Num r) + => Point 2 r -> LineSegment 2 p r -> Bool +p `onSegment2` s@(LineSegment u v) = case ccw' (ext p) (u^.unEndPoint) (v^.unEndPoint) of + CoLinear -> let su = p `onSide` lu + sv = p `onSide` lv + in su /= sv + && ((su == OnLine) `implies` isClosed u) + && ((sv == OnLine) `implies` isClosed v) + _ -> False + where + (Line _ w) = perpendicularTo $ supportingLine s + lu = Line (u^.unEndPoint.core) w + lv = Line (v^.unEndPoint.core) w + + a `implies` b = b || not a + + +-- | The left and right end point (or left below right if they have equal x-coords) +orderedEndPoints :: Ord r => LineSegment 2 p r -> (Point 2 r :+ p, Point 2 r :+ p) +orderedEndPoints s = if pc <= qc then (p, q) else (q,p) + where + p@(pc :+ _) = s^.start + q@(qc :+ _) = s^.end + + +-- | Length of the line segment +segmentLength :: (Arity d, Floating r) => LineSegment d p r -> r +segmentLength ~(LineSegment' p q) = distanceA (p^.core) (q^.core) + +sqSegmentLength :: (Arity d, Num r) => LineSegment d p r -> r +sqSegmentLength ~(LineSegment' p q) = qdA (p^.core) (q^.core) + +-- | Squared distance from the point to the Segment s. The same remark as for +-- the 'sqDistanceToSegArg' applies here. +sqDistanceToSeg :: (Arity d, Fractional r, Ord r) => Point d r -> LineSegment d p r -> r +sqDistanceToSeg p = fst . sqDistanceToSegArg p + + +-- | Squared distance from the point to the Segment s, and the point on s +-- realizing it. Note that if the segment is *open*, the closest point +-- returned may be one of the (open) end points, even though technically the +-- end point does not lie on the segment. (The true closest point then lies +-- arbitrarily close to the end point). +sqDistanceToSegArg :: (Arity d, Fractional r, Ord r) + => Point d r -> LineSegment d p r -> (r, Point d r) +sqDistanceToSegArg p s = let m = sqDistanceToArg p (supportingLine s) + xs = m : map (\(q :+ _) -> (qdA p q, q)) [s^.start, s^.end] + in F.minimumBy (comparing fst) + . filter (flip onSegment s . snd) $ xs + +-- | flips the start and end point of the segment +flipSegment :: LineSegment d p r -> LineSegment d p r +flipSegment s = let p = s^.start + q = s^.end + in (s&start .~ q)&end .~ p + +-- testSeg :: LineSegment 2 () Rational +-- testSeg = LineSegment (Open $ ext origin) (Closed $ ext (Point2 10 0)) + +-- horL' :: Line 2 Rational +-- horL' = horizontalLine 0 + +-- testI = testSeg `intersect` horL' + + +-- ff = bimap (fmap Val) (const ()) + +-- ss' = let (LineSegment p q) = testSeg in +-- LineSegment (p&unEndPoint %~ ff) +-- (q&unEndPoint %~ ff) + +-- ss'' = ss'^._SubLine + +-- | Linearly interpolate the two endpoints with a value in the range [0,1] +-- +-- >>> interpolate 0.5 $ ClosedLineSegment (ext $ origin) (ext $ Point2 10.0 10.0) +-- Point2 5.0 5.0 +-- >>> interpolate 0.1 $ ClosedLineSegment (ext $ origin) (ext $ Point2 10.0 10.0) +-- Point2 1.0 1.0 +-- >>> interpolate 0 $ ClosedLineSegment (ext $ origin) (ext $ Point2 10.0 10.0) +-- Point2 0.0 0.0 +-- >>> interpolate 1 $ ClosedLineSegment (ext $ origin) (ext $ Point2 10.0 10.0) +-- Point2 10.0 10.0 +interpolate :: (Fractional r, Arity d) => r -> LineSegment d p r -> Point d r +interpolate t (LineSegment' p q) = Point $ (asV p ^* (1-t)) ^+^ (asV q ^* t) + where + asV = (^.core.vector) + + +-- | smart constructor that creates a valid segment, i.e. it validates +-- that the endpoints are disjoint. +validSegment :: (Eq r, Arity d) + => EndPoint (Point d r :+ p) -> EndPoint (Point d r :+ p) + -> Maybe (LineSegment d p r) +validSegment u v = let s = LineSegment u v + in if s^.start.core /= s^.end.core then Just s else Nothing diff --git a/src/Data/Geometry/Matrix.hs b/src/Data/Geometry/Matrix.hs --- a/src/Data/Geometry/Matrix.hs +++ b/src/Data/Geometry/Matrix.hs @@ -19,17 +19,18 @@ , HasDeterminant(..) ) where -import Control.Lens (imap) -import Data.Geometry.Matrix.Internal (mkRow) +import Control.Lens (imap) +import Data.Coerce +import Data.Geometry.Matrix.Internal (mkRow) import Data.Geometry.Vector -import Linear.Matrix ((!*),(!*!)) -import qualified Linear.Matrix as Lin -import Unsafe.Coerce (unsafeCoerce) +import Data.Geometry.Vector.VectorFamilyPeano +import Linear.Matrix (M22, M33, M44, (!*!), (!*)) +import qualified Linear.Matrix as Lin -------------------------------------------------------------------------------- -- * Matrices --- | a matrix of n rows, each of m columns, storing values of type r +-- | A matrix of n rows, each of m columns, storing values of type r. newtype Matrix n m r = Matrix (Vector n (Vector m r)) deriving instance (Show r, Arity n, Arity m) => Show (Matrix n m r) @@ -39,41 +40,56 @@ deriving instance (Arity n, Arity m) => Foldable (Matrix n m) deriving instance (Arity n, Arity m) => Traversable (Matrix n m) +-- | Matrix product. multM :: (Arity r, Arity c, Arity c', Num a) => Matrix r c a -> Matrix c c' a -> Matrix r c' a (Matrix a) `multM` (Matrix b) = Matrix $ a !*! b +-- | Matrix * column vector. mult :: (Arity m, Arity n, Num r) => Matrix n m r -> Vector m r -> Vector n r (Matrix m) `mult` v = m !* v --- | Produces the Identity Matrix +-- | Produces the Identity Matrix. identityMatrix :: (Arity d, Num r) => Matrix d d r identityMatrix = Matrix $ imap mkRow (pure 1) +-- | Class of matrices that are invertible. class Invertible n r where inverse' :: Matrix n n r -> Matrix n n r instance Fractional r => Invertible 2 r where -- >>> inverse' $ Matrix $ Vector2 (Vector2 1 2) (Vector2 3 4.0) -- Matrix Vector2 [Vector2 [-2.0,1.0],Vector2 [1.5,-0.5]] - inverse' (Matrix m) = Matrix . unsafeCoerce . Lin.inv22 . unsafeCoerce $ m + inverse' = withM22 Lin.inv22 instance Fractional r => Invertible 3 r where -- >>> inverse' $ Matrix $ Vector3 (Vector3 1 2 4) (Vector3 4 2 2) (Vector3 1 1 1.0) -- Matrix Vector3 [Vector3 [0.0,0.5,-1.0],Vector3 [-0.5,-0.75,3.5],Vector3 [0.5,0.25,-1.5]] - inverse' (Matrix m) = Matrix . unsafeCoerce . Lin.inv33 . unsafeCoerce $ m + inverse' = withM33 Lin.inv33 instance Fractional r => Invertible 4 r where - inverse' (Matrix m) = Matrix . unsafeCoerce . Lin.inv44 . unsafeCoerce $ m - + inverse' = withM44 Lin.inv44 +-- | Class of matrices that have a determinant. class Arity d => HasDeterminant d where det :: Num r => Matrix d d r -> r instance HasDeterminant 1 where det (Matrix (Vector1 (Vector1 x))) = x instance HasDeterminant 2 where - det = Lin.det22 . unsafeCoerce + det = Lin.det22 . coerce instance HasDeterminant 3 where - det = Lin.det33 . unsafeCoerce + det = Lin.det33 . coerce instance HasDeterminant 4 where - det = Lin.det44 . unsafeCoerce + det = Lin.det44 . coerce + +-------------------------------------------------------------------------------- +-- Boilerplate code for converting between Matrix and M22/M33/M44. + +withM22 :: (M22 a -> M22 b) -> Matrix 2 2 a -> Matrix 2 2 b +withM22 f = coerce . f . coerce + +withM33 :: (M33 a -> M33 b) -> Matrix 3 3 a -> Matrix 3 3 b +withM33 f = coerce . f . coerce + +withM44 :: (M44 a -> M44 b) -> Matrix 4 4 a -> Matrix 4 4 b +withM44 f = coerce . f . coerce diff --git a/src/Data/Geometry/PlanarSubdivision.hs b/src/Data/Geometry/PlanarSubdivision.hs --- a/src/Data/Geometry/PlanarSubdivision.hs +++ b/src/Data/Geometry/PlanarSubdivision.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE PartialTypeSignatures #-} {-# LANGUAGE ScopedTypeVariables #-} -------------------------------------------------------------------------------- @@ -76,7 +75,7 @@ -> f -- ^ data inside -> f -- ^ data outside the polygon -> PlanarSubdivision s p () f r -fromPolygon p pg@(SimplePolygon _) iD oD = fromSimplePolygon p pg iD oD +fromPolygon p pg@SimplePolygon{} iD oD = fromSimplePolygon p pg iD oD fromPolygon p (MultiPolygon vs hs) iD oD = case NonEmpty.nonEmpty hs of Nothing -> outerPG Just hs' -> let hs'' = (\pg -> fromSimplePolygon wp (toCounterClockWiseOrder pg) oD iD) <$> hs' @@ -84,7 +83,7 @@ where wp = Proxy :: Proxy (Wrap s) - outerPG = fromSimplePolygon p (SimplePolygon vs) iD oD + outerPG = fromSimplePolygon p vs iD oD i = V.last $ faces' outerPG @@ -122,13 +121,13 @@ data HoleData f p = Outer !f | Hole !f !p deriving (Show,Eq) -holeData :: HoleData f p -> f -holeData (Outer f) = f -holeData (Hole f _) = f +_holeData :: HoleData f p -> f +_holeData (Outer f) = f +_holeData (Hole f _) = f -getP :: HoleData f p -> Maybe p -getP (Outer _) = Nothing -getP (Hole _ p) = Just p +_getP :: HoleData f p -> Maybe p +_getP (Outer _) = Nothing +_getP (Hole _ p) = Just p -------------------------------------------------------------------------------- diff --git a/src/Data/Geometry/PlanarSubdivision/Basic.hs b/src/Data/Geometry/PlanarSubdivision/Basic.hs --- a/src/Data/Geometry/PlanarSubdivision/Basic.hs +++ b/src/Data/Geometry/PlanarSubdivision/Basic.hs @@ -155,6 +155,7 @@ => PlaneGraph s v e f r -> PlanarSubdivision s v e f r fromPlaneGraph g = fromPlaneGraph' g (PG.outerFaceDart g) +{- HLINT ignore fromPlaneGraph' -} -- | Given a (connected) PlaneGraph and a dart that has the outerface on its left -- | Constructs a planarsubdivision -- @@ -280,7 +281,7 @@ numEdges :: PlanarSubdivision s v e f r -> Int numEdges = (`div` 2) . V.length . _rawDartData --- | Get the number of faces +-- | \( O(1) \). Get the number of faces -- -- >>> numFaces myGraph -- 4 @@ -327,11 +328,12 @@ edges :: PlanarSubdivision s v e f r -> V.Vector (Dart s, e) edges ps = (\e -> (e,ps^.dataOf e)) <$> edges' ps - +-- | \( O(n) \). Vector of all primal faces. faces' :: PlanarSubdivision s v e f r -> V.Vector (FaceId' s) faces' ps = let n = numFaces ps in V.fromList $ map (FaceId . VertexId) [0..n-1] +-- | \( O(n) \). Vector of all primal faces with associated data. faces :: PlanarSubdivision s v e f r -> V.Vector (FaceId' s, FaceData (Dart s) f) faces ps = (\fi -> (fi,ps^.faceDataOf fi)) <$> faces' ps @@ -492,7 +494,7 @@ -- running time: \(O(k)\), where \(k\) is the output size. boundaryVertices :: FaceId' s -> PlanarSubdivision s v e f r -> V.Vector (VertexId' s) -boundaryVertices f ps = (\d -> headOf d ps) <$> outerBoundaryDarts f ps +boundaryVertices f ps = (`headOf` ps) <$> outerBoundaryDarts f ps -- | Lists the holes in this face, given as a list of darts to arbitrary darts @@ -640,7 +642,7 @@ -- -- \(O(k)\), where \(k\) is the complexity of the outer boundary of the face rawFaceBoundary :: FaceId' s -> PlanarSubdivision s v e f r -> SimplePolygon v r :+ f -rawFaceBoundary i ps = fromPoints pts :+ (ps^.dataOf i) +rawFaceBoundary i ps = unsafeFromPoints pts :+ (ps^.dataOf i) where d = V.head $ outerBoundaryDarts i ps pts = (\d' -> PG.vtxDataToExt $ ps^.vertexDataOf (headOf d' ps)) @@ -654,10 +656,10 @@ -> SomePolygon v r :+ f rawFacePolygon i ps = case F.toList $ holesOf i ps of [] -> Left res :+ x - hs -> Right (MultiPolygon vs $ map toHole hs) :+ x + hs -> Right (MultiPolygon res $ map toHole hs) :+ x where - res@(SimplePolygon vs) :+ x = rawFaceBoundary i ps - toHole d = (rawFaceBoundary (leftFace d ps) ps)^.core + res :+ x = rawFaceBoundary i ps + toHole d = rawFaceBoundary (leftFace d ps) ps ^. core -- | Lists all *internal* faces of the planar subdivision. rawFacePolygons :: PlanarSubdivision s v e f r diff --git a/src/Data/Geometry/PlanarSubdivision/Merge.hs b/src/Data/Geometry/PlanarSubdivision/Merge.hs --- a/src/Data/Geometry/PlanarSubdivision/Merge.hs +++ b/src/Data/Geometry/PlanarSubdivision/Merge.hs @@ -23,9 +23,6 @@ import Data.Geometry.Point import Data.Geometry.Polygon import Data.PlanarGraph.Dart -import Data.PlaneGraph ( Dart, VertexId(..), FaceId(..) - , VertexId', FaceId' - ) import qualified Data.PlaneGraph as PG import Data.Semigroup.Foldable import qualified Data.Vector as V @@ -215,34 +212,39 @@ -------------------------------------------------------------------------------- data Test = Test -data Id a = Id a +newtype Id a = Id a triangle1 :: PlanarSubdivision Test () () Int Rational triangle1 = (\pg -> fromSimplePolygon (Id Test) pg 1 0) - $ trianglePG1 + trianglePG1 +trianglePG1 :: SimplePolygon () Rational trianglePG1 = fromPoints . map ext $ [origin, Point2 200 0, Point2 200 200] triangle2 :: PlanarSubdivision Test () () Int Rational triangle2 = (\pg -> fromSimplePolygon (Id Test) pg 2 0) - $ trianglePG2 + trianglePG2 +trianglePG2 :: SimplePolygon () Rational trianglePG2 = fromPoints . map ext $ [Point2 0 30, Point2 10 30, Point2 10 40] triangle4 :: PlanarSubdivision Test () () Int Rational triangle4 = (\pg -> fromSimplePolygon (Id Test) pg 1 0) - $ trianglePG4 + trianglePG4 +trianglePG4 :: SimplePolygon () Rational trianglePG4 = fromPoints . map ext $ [Point2 400 400, Point2 600 400, Point2 600 600] triangle3 :: PlanarSubdivision Test () () Int Rational triangle3 = (\pg -> fromSimplePolygon (Id Test) pg 3 0) - $ trianglePG3 + trianglePG3 +trianglePG3 :: SimplePolygon () Rational trianglePG3 = fromPoints . map ext $ [Point2 401 530, Point2 410 530, Point2 410 540] -myPS = embedAsHoleIn triangle2 const (mkFI 1) triangle1 +_myPS :: PlanarSubdivision Test () () Int Rational +_myPS = embedAsHoleIn triangle2 const (mkFI 1) triangle1 `merge` embedAsHoleIn triangle3 const (mkFI 1) triangle4 diff --git a/src/Data/Geometry/PlanarSubdivision/Raw.hs b/src/Data/Geometry/PlanarSubdivision/Raw.hs --- a/src/Data/Geometry/PlanarSubdivision/Raw.hs +++ b/src/Data/Geometry/PlanarSubdivision/Raw.hs @@ -46,7 +46,7 @@ -------------------------------------------------------------------------------- -- | The Face data consists of the data itself and a list of holes -data FaceData h f = FaceData { _holes :: (Seq.Seq h) +data FaceData h f = FaceData { _holes :: Seq.Seq h , _fData :: !f } deriving (Show,Eq,Ord,Functor,Foldable,Traversable,Generic) makeLenses ''FaceData diff --git a/src/Data/Geometry/Point.hs b/src/Data/Geometry/Point.hs --- a/src/Data/Geometry/Point.hs +++ b/src/Data/Geometry/Point.hs @@ -10,32 +10,32 @@ -- \(d\)-dimensional points. -- -------------------------------------------------------------------------------- -module Data.Geometry.Point( Point(..) +module Data.Geometry.Point( Point(.., Point1, Point2, Point3) , origin, vector , pointFromList , projectPoint - , pattern Point1 - , pattern Point2 - , pattern Point3 , xCoord, yCoord, zCoord , PointFunctor(..) - , CCW, ccw, ccw' + , CCW, ccw, ccw', isCoLinear , pattern CCW, pattern CW, pattern CoLinear - , ccwCmpAround, cwCmpAround, ccwCmpAroundWith, cwCmpAroundWith - , sortAround, insertIntoCyclicOrder + , ccwCmpAround, ccwCmpAround' + , cwCmpAround, cwCmpAround' + , ccwCmpAroundWith, ccwCmpAroundWith' + , cwCmpAroundWith, cwCmpAroundWith' + , sortAround, sortAround' + , insertIntoCyclicOrder , Quadrant(..), quadrantWith, quadrant, partitionIntoQuadrants - , cmpByDistanceTo + , cmpByDistanceTo, cmpByDistanceTo' , squaredEuclideanDist, euclideanDist - - , AsAPoint(..), coord, unsafeCoord, vector' + , coord, unsafeCoord ) where import Data.Geometry.Point.Class diff --git a/src/Data/Geometry/Point/Class.hs b/src/Data/Geometry/Point/Class.hs --- a/src/Data/Geometry/Point/Class.hs +++ b/src/Data/Geometry/Point/Class.hs @@ -9,7 +9,7 @@ -------------------------------------------------------------------------------- -- $setup --- >>> import Data.Geometry.Point.Internal (pattern Point2, pattern Point3) +-- >>> import Data.Geometry.Point.Internal (pattern Point2, pattern Point3, origin) class ToAPoint point d r where toPoint :: Prism' (point d r) (Point d r) @@ -17,12 +17,32 @@ class AsAPoint p where asAPoint :: Lens (p d r) (p d' r') (Point d r) (Point d' r') +-- | Lens to access the vector corresponding to this point. +-- +-- >>> (Point3 1 2 3) ^. vector' +-- Vector3 1 2 3 +-- >>> origin & vector' .~ Vector3 1 2 3 +-- Point3 1 2 3 vector' :: AsAPoint p => Lens (p d r) (p d r') (Vector d r) (Vector d r') vector' = asAPoint . lens Internal.toVec (const Internal.Point) +-- | Get the coordinate in a given dimension +-- +-- >>> Point3 1 2 3 ^. coord (C :: C 2) +-- 2 +-- >>> Point3 1 2 3 & coord (C :: C 1) .~ 10 +-- Point3 10 2 3 +-- >>> Point3 1 2 3 & coord (C :: C 3) %~ (+1) +-- Point3 1 2 4 coord :: (1 <= i, i <= d, KnownNat i, Arity d, AsAPoint p) => proxy i -> Lens' (p d r) r coord i = asAPoint.Internal.coord i +-- | Get the coordinate in a given dimension. This operation is unsafe in the +-- sense that no bounds are checked. Consider using `coord` instead. +-- +-- +-- >>> Point3 1 2 3 ^. unsafeCoord 2 +-- 2 unsafeCoord :: (Arity d, AsAPoint p) => Int -> Lens' (p d r) r unsafeCoord i = asAPoint.Internal.unsafeCoord i @@ -33,14 +53,12 @@ asAPoint = id - - -- | Shorthand to access the first coordinate C 1 -- -- >>> Point3 1 2 3 ^. xCoord -- 1 -- >>> Point2 1 2 & xCoord .~ 10 --- Point2 [10,2] +-- Point2 10 2 xCoord :: (1 <= d, Arity d, AsAPoint point) => Lens' (point d r) r xCoord = coord (C :: C 1) {-# INLINABLE xCoord #-} @@ -50,7 +68,7 @@ -- >>> Point2 1 2 ^. yCoord -- 2 -- >>> Point3 1 2 3 & yCoord %~ (+1) --- Point3 [1,3,3] +-- Point3 1 3 3 yCoord :: (2 <= d, Arity d, AsAPoint point) => Lens' (point d r) r yCoord = coord (C :: C 2) {-# INLINABLE yCoord #-} @@ -60,7 +78,7 @@ -- >>> Point3 1 2 3 ^. zCoord -- 3 -- >>> Point3 1 2 3 & zCoord %~ (+1) --- Point3 [1,2,4] -zCoord :: (3 <= d, Arity d,AsAPoint point) => Lens' (point d r) r +-- Point3 1 2 4 +zCoord :: (3 <= d, Arity d, AsAPoint point) => Lens' (point d r) r zCoord = coord (C :: C 3) {-# INLINABLE zCoord #-} diff --git a/src/Data/Geometry/Point/Internal.hs b/src/Data/Geometry/Point/Internal.hs --- a/src/Data/Geometry/Point/Internal.hs +++ b/src/Data/Geometry/Point/Internal.hs @@ -25,27 +25,29 @@ , PointFunctor(..) , cmpByDistanceTo + , cmpByDistanceTo' , squaredEuclideanDist, euclideanDist ) where import Control.DeepSeq import Control.Lens +import Control.Monad import Data.Aeson import Data.Ext -import qualified Data.Foldable as F +import qualified Data.Foldable as F +import Data.Functor.Classes import Data.Geometry.Properties import Data.Geometry.Vector -import qualified Data.Geometry.Vector as Vec +import qualified Data.Geometry.Vector as Vec import Data.Hashable -import Data.Ord (comparing) +import Data.List (intersperse) +import Data.Ord (comparing) import Data.Proxy -import GHC.Generics (Generic) +import GHC.Generics (Generic) import GHC.TypeLits -import System.Random (Random(..)) -import Test.QuickCheck (Arbitrary) -import Text.ParserCombinators.ReadP (ReadP, string,pfail) -import Text.ParserCombinators.ReadPrec (lift) -import Text.Read (Read(..),readListPrecDefault, readPrec_to_P,minPrec) +import System.Random (Random (..)) +import Test.QuickCheck (Arbitrary, Arbitrary1) +import Text.Read (Read (..), readListPrecDefault) -------------------------------------------------------------------------------- @@ -61,31 +63,65 @@ -- * A d-dimensional Point -- | A d-dimensional point. +-- +-- There are convenience pattern synonyms for 1, 2 and 3 dimensional points. +-- +-- >>> let f (Point1 x) = x in f (Point1 1) +-- 1 +-- >>> let f (Point2 x y) = x in f (Point2 1 2) +-- 1 +-- >>> let f (Point3 x y z) = z in f (Point3 1 2 3) +-- 3 +-- >>> let f (Point3 x y z) = z in f (Point $ Vector3 1 2 3) +-- 3 newtype Point d r = Point { toVec :: Vector d r } deriving (Generic) instance (Show r, Arity d) => Show (Point d r) where - show (Point v) = mconcat [ "Point", show $ F.length v , " " - , show $ F.toList v - ] + showsPrec = liftShowsPrec showsPrec showList + +instance (Arity d) => Show1 (Point d) where + liftShowsPrec sp _ d (Point v) = showParen (d > 10) $ + showString constr . showChar ' ' . + unwordsS (map (sp 11) (F.toList v)) + where + constr = "Point" <> show (fromIntegral (natVal @d Proxy)) + unwordsS = foldr (.) id . intersperse (showChar ' ') + instance (Read r, Arity d) => Read (Point d r) where - readPrec = lift readPt + readPrec = liftReadPrec readPrec readListPrec readListPrec = readListPrecDefault -readPt :: forall d r. (Arity d, Read r) => ReadP (Point d r) -readPt = do let d = natVal (Proxy :: Proxy d) - _ <- string $ "Point" <> show d <> " " - rs <- readPrec_to_P readPrec minPrec - case pointFromList rs of - Just p -> pure p - _ -> pfail +instance (Arity d) => Read1 (Point d) where + liftReadPrec rp _rl = readData $ + readUnaryWith (replicateM d rp) constr $ \rs -> + case pointFromList rs of + Just p -> p + _ -> error "internal error in Data.Geometry.Point read instance." + where + d = fromIntegral (natVal (Proxy :: Proxy d)) + constr = "Point" <> show d + liftReadListPrec = liftReadListPrecDefault +-- readPt :: forall d r. (Arity d, Read r) => ReadP (Point d r) +-- readPt = do let d = natVal (Proxy :: Proxy d) +-- _ <- string $ "Point" <> show d +-- rs <- if d > 3 +-- then readPrec_to_P readPrec minPrec +-- else replicateM (fromIntegral d) (readPrec_to_P readPrec minPrec) +-- case pointFromList rs of +-- Just p -> pure p +-- _ -> pfail + deriving instance (Eq r, Arity d) => Eq (Point d r) +deriving instance Arity d => Eq1 (Point d) deriving instance (Ord r, Arity d) => Ord (Point d r) deriving instance Arity d => Functor (Point d) +deriving instance Arity d => Applicative (Point d) deriving instance Arity d => Foldable (Point d) deriving instance Arity d => Traversable (Point d) deriving instance (Arity d, NFData r) => NFData (Point d r) deriving instance (Arity d, Arbitrary r) => Arbitrary (Point d r) +deriving instance Arity d => Arbitrary1 (Point d) deriving instance (Arity d, Hashable r) => Hashable (Point d r) deriving instance (Arity d, Random r) => Random (Point d r) @@ -109,7 +145,7 @@ -- | Point representing the origin in d dimensions -- -- >>> origin :: Point 4 Int --- Point4 [0,0,0,0] +-- Point4 0 0 0 0 origin :: (Arity d, Num r) => Point d r origin = Point $ pure 0 @@ -119,10 +155,10 @@ -- | Lens to access the vector corresponding to this point. -- -- >>> (Point3 1 2 3) ^. vector --- Vector3 [1,2,3] +-- Vector3 1 2 3 -- >>> origin & vector .~ Vector3 1 2 3 --- Point3 [1,2,3] -vector :: Lens' (Point d r) (Vector d r) +-- Point3 1 2 3 +vector :: Lens (Point d r) (Point d r') (Vector d r) (Vector d r') vector = lens toVec (const Point) {-# INLINABLE vector #-} @@ -142,9 +178,9 @@ -- >>> Point3 1 2 3 ^. coord (C :: C 2) -- 2 -- >>> Point3 1 2 3 & coord (C :: C 1) .~ 10 --- Point3 [10,2,3] +-- Point3 10 2 3 -- >>> Point3 1 2 3 & coord (C :: C 3) %~ (+1) --- Point3 [1,2,4] +-- Point3 1 2 4 coord :: forall proxy i d r. (1 <= i, i <= d, Arity d, KnownNat i) => proxy i -> Lens' (Point d r) r coord _ = unsafeCoord $ fromIntegral (natVal $ C @i) @@ -160,7 +196,7 @@ -- list has to match the dimension exactly. -- -- >>> pointFromList [1,2,3] :: Maybe (Point 3 Int) --- Just Point3 [1,2,3] +-- Just (Point3 1 2 3) -- >>> pointFromList [1] :: Maybe (Point 3 Int) -- Nothing -- >>> pointFromList [1,2,3,4] :: Maybe (Point 3 Int) @@ -176,44 +212,18 @@ -------------------------------------------------------------------------------- -- * Convenience functions to construct 1, 2 and 3 dimensional points --- | We provide pattern synonyms for 1, 2 and 3 dimensional points. i.e. --- we can write: --- --- --- >>> :{ --- let --- f :: Num r => Point 1 r -> r --- f (Point1 x) = x + 1 --- in f (Point1 1) --- :} --- 2 +-- | A bidirectional pattern synonym for 1 dimensional points. pattern Point1 :: r -> Point 1 r pattern Point1 x = Point (Vector1 x) {-# COMPLETE Point1 #-} --- | Pattern synonym for 2 dimensional points --- --- >>> :{ --- let --- f :: Point 2 r -> r --- f (Point2 x y) = x --- in f (Point2 1 2) --- :} --- 1 +-- | A bidirectional pattern synonym for 2 dimensional points. pattern Point2 :: r -> r -> Point 2 r pattern Point2 x y = Point (Vector2 x y) {-# COMPLETE Point2 #-} --- | Similarly, we can write: --- --- >>> :{ --- let --- g :: Point 3 r -> r --- g (Point3 x y z) = z --- in g myPoint --- :} --- 3 +-- | A bidirectional pattern synonym for 3 dimensional points. pattern Point3 :: r -> r -> r -> Point 3 r pattern Point3 x y z = (Point (Vector3 x y z)) {-# COMPLETE Point3 #-} @@ -237,9 +247,13 @@ -- | Compare by distance to the first argument cmpByDistanceTo :: (Ord r, Num r, Arity d) - => Point d r :+ c -> Point d r :+ p -> Point d r :+ q -> Ordering -cmpByDistanceTo (c :+ _) p q = comparing (squaredEuclideanDist c) (p^.core) (q^.core) + => Point d r -> Point d r -> Point d r -> Ordering +cmpByDistanceTo c p q = comparing (squaredEuclideanDist c) p q +-- | Compare by distance to the first argument +cmpByDistanceTo' :: (Ord r, Num r, Arity d) + => Point d r :+ c -> Point d r :+ p -> Point d r :+ q -> Ordering +cmpByDistanceTo' c p q = cmpByDistanceTo (c^.core) (p^.core) (q^.core) diff --git a/src/Data/Geometry/Point/Orientation/Degenerate.hs b/src/Data/Geometry/Point/Orientation/Degenerate.hs --- a/src/Data/Geometry/Point/Orientation/Degenerate.hs +++ b/src/Data/Geometry/Point/Orientation/Degenerate.hs @@ -4,11 +4,15 @@ , ccw, ccw' - , sortAround + , isCoLinear - , ccwCmpAroundWith, cwCmpAroundWith - , ccwCmpAround, cwCmpAround + , sortAround, sortAround' + , ccwCmpAroundWith, ccwCmpAroundWith' + , cwCmpAroundWith, cwCmpAroundWith' + , ccwCmpAround, ccwCmpAround' + , cwCmpAround, cwCmpAround' + , insertIntoCyclicOrder ) where @@ -22,16 +26,22 @@ -------------------------------------------------------------------------------- +-- $setup +-- >>> import Data.Double.Approximate + -- | Data type for expressing the orientation of three points, with -- the option of allowing Colinearities. newtype CCW = CCWWrap Ordering deriving Eq +-- | CounterClockwise orientation. Also called a left-turn. pattern CCW :: CCW pattern CCW = CCWWrap GT +-- | Clockwise orientation. Also called a right-turn. pattern CW :: CCW pattern CW = CCWWrap LT +-- | CoLinear orientation. Also called a straight line. pattern CoLinear :: CCW pattern CoLinear = CCWWrap EQ {-# COMPLETE CCW, CW, CoLinear #-} @@ -44,8 +54,22 @@ -- | Given three points p q and r determine the orientation when going from p to r via q. +-- +-- Be vary of numerical instability: +-- >>> ccw (Point2 0 0.3) (Point2 1 0.6) (Point2 2 (0.9::Double)) +-- CCW +-- +-- >>> ccw (Point2 0 0.3) (Point2 1 0.6) (Point2 2 (0.9::Rational)) +-- CoLinear +-- +-- If you can't use 'Rational', try 'SafeDouble' instead of 'Double': +-- >>> ccw (Point2 0 0.3) (Point2 1 0.6) (Point2 2 (0.9::SafeDouble)) +-- CoLinear +-- ccw :: (Ord r, Num r) => Point 2 r -> Point 2 r -> Point 2 r -> CCW -ccw p q r = CCWWrap $ z `compare` 0 +ccw p q r = CCWWrap $ (ux*vy) `compare` (uy*vx) +-- ccw p q r = CCWWrap $ z `compare` 0 -- Comparing against 0 is bad for numerical robustness. + -- I've added a testcase that fails if comparing against 0. -- case z `compare` 0 of -- LT -> CW -- GT -> CCW @@ -53,21 +77,38 @@ where Vector2 ux uy = q .-. p Vector2 vx vy = r .-. p - z = ux * vy - uy * vx + -- _z = ux * vy - uy * vx +-- | Given three points p q and r determine if the line from p to r via q is straight/colinear. +-- +-- This is identical to `ccw p q r == CoLinear` but doesn't have the `Ord` constraint. +isCoLinear :: (Eq r, Num r) => Point 2 r -> Point 2 r -> Point 2 r -> Bool +isCoLinear p q r = (ux * vy) == (uy * vx) + where + Vector2 ux uy = q .-. p + Vector2 vx vy = r .-. p + -- | Given three points p q and r determine the orientation when going from p to r via q. ccw' :: (Ord r, Num r) => Point 2 r :+ a -> Point 2 r :+ b -> Point 2 r :+ c -> CCW ccw' p q r = ccw (p^.core) (q^.core) (r^.core) --- | Sort the points arround the given point p in counter clockwise order with +-- | \( O(n log n) \) +-- Sort the points arround the given point p in counter clockwise order with -- respect to the rightward horizontal ray starting from p. If two points q -- and r are colinear with p, the closest one to p is reported first. --- running time: O(n log n) sortAround :: (Ord r, Num r) - => Point 2 r :+ q -> [Point 2 r :+ p] -> [Point 2 r :+ p] + => Point 2 r -> [Point 2 r] -> [Point 2 r] sortAround c = L.sortBy (ccwCmpAround c <> cmpByDistanceTo c) +-- | \( O(n log n) \) +-- Sort the points arround the given point p in counter clockwise order with +-- respect to the rightward horizontal ray starting from p. If two points q +-- and r are colinear with p, the closest one to p is reported first. +sortAround' :: (Ord r, Num r) + => Point 2 r :+ q -> [Point 2 r :+ p] -> [Point 2 r :+ p] +sortAround' c = L.sortBy (ccwCmpAround' c <> cmpByDistanceTo' c) + -- | Given a zero vector z, a center c, and two points p and q, -- compute the ccw ordering of p and q around c with this vector as zero -- direction. @@ -75,10 +116,10 @@ -- pre: the points p,q /= c ccwCmpAroundWith :: (Ord r, Num r) => Vector 2 r - -> Point 2 r :+ c - -> Point 2 r :+ a -> Point 2 r :+ b + -> Point 2 r + -> Point 2 r -> Point 2 r -> Ordering -ccwCmpAroundWith z@(Vector2 zx zy) (c :+ _) (q :+ _) (r :+ _) = +ccwCmpAroundWith z@(Vector2 zx zy) c q r = case (ccw c a q, ccw c a r) of (CCW,CCW) -> cmp (CCW,CW) -> LT @@ -115,36 +156,71 @@ CoLinear -> EQ -- | Given a zero vector z, a center c, and two points p and q, +-- compute the ccw ordering of p and q around c with this vector as zero +-- direction. +-- +-- pre: the points p,q /= c +ccwCmpAroundWith' :: (Ord r, Num r) + => Vector 2 r + -> Point 2 r :+ c + -> Point 2 r :+ a -> Point 2 r :+ b + -> Ordering +ccwCmpAroundWith' z (c :+ _) (q :+ _) (r :+ _) = ccwCmpAroundWith z c q r + +-- | Given a zero vector z, a center c, and two points p and q, -- compute the cw ordering of p and q around c with this vector as zero -- direction. -- -- pre: the points p,q /= c cwCmpAroundWith :: (Ord r, Num r) => Vector 2 r + -> Point 2 r + -> Point 2 r -> Point 2 r + -> Ordering +cwCmpAroundWith z c = flip (ccwCmpAroundWith z c) + + +-- | Given a zero vector z, a center c, and two points p and q, +-- compute the cw ordering of p and q around c with this vector as zero +-- direction. +-- +-- pre: the points p,q /= c +cwCmpAroundWith' :: (Ord r, Num r) + => Vector 2 r -> Point 2 r :+ a -> Point 2 r :+ b -> Point 2 r :+ c -> Ordering -cwCmpAroundWith z c = flip (ccwCmpAroundWith z c) +cwCmpAroundWith' z c = flip (ccwCmpAroundWith' z c) -- | Counter clockwise ordering of the points around c. Points are ordered with -- respect to the positive x-axis. ccwCmpAround :: (Num r, Ord r) - => Point 2 r :+ qc -> Point 2 r :+ p -> Point 2 r :+ q -> Ordering + => Point 2 r -> Point 2 r -> Point 2 r -> Ordering ccwCmpAround = ccwCmpAroundWith (Vector2 1 0) +-- | Counter clockwise ordering of the points around c. Points are ordered with +-- respect to the positive x-axis. +ccwCmpAround' :: (Num r, Ord r) + => Point 2 r :+ qc -> Point 2 r :+ p -> Point 2 r :+ q -> Ordering +ccwCmpAround' = ccwCmpAroundWith' (Vector2 1 0) + -- | Clockwise ordering of the points around c. Points are ordered with -- respect to the positive x-axis. cwCmpAround :: (Num r, Ord r) - => Point 2 r :+ qc -> Point 2 r :+ p -> Point 2 r :+ q -> Ordering + => Point 2 r -> Point 2 r -> Point 2 r -> Ordering cwCmpAround = cwCmpAroundWith (Vector2 1 0) +-- | Clockwise ordering of the points around c. Points are ordered with +-- respect to the positive x-axis. +cwCmpAround' :: (Num r, Ord r) + => Point 2 r :+ qc -> Point 2 r :+ p -> Point 2 r :+ q -> Ordering +cwCmpAround' a b c = cwCmpAround (a^.core) (b^.core) (c^.core) --- | Given a center c, a new point p, and a list of points ps, sorted in +-- | \( O(n) \) +-- Given a center c, a new point p, and a list of points ps, sorted in -- counter clockwise order around c. Insert p into the cyclic order. The focus -- of the returned cyclic list is the new point p. --- --- running time: O(n) insertIntoCyclicOrder :: (Ord r, Num r) => Point 2 r :+ q -> Point 2 r :+ p -> C.CList (Point 2 r :+ p) -> C.CList (Point 2 r :+ p) -insertIntoCyclicOrder c = CU.insertOrdBy (ccwCmpAround c <> cmpByDistanceTo c) +insertIntoCyclicOrder c = CU.insertOrdBy (ccwCmpAround' c <> cmpByDistanceTo' c) diff --git a/src/Data/Geometry/Point/Quadrants.hs b/src/Data/Geometry/Point/Quadrants.hs --- a/src/Data/Geometry/Point/Quadrants.hs +++ b/src/Data/Geometry/Point/Quadrants.hs @@ -1,26 +1,19 @@ +-------------------------------------------------------------------------------- +-- | +-- Module : Data.Geometry.Point.Quadrants +-- Copyright : (C) Frank Staals +-- License : see the LICENSE file +-- Maintainer : Frank Staals +-------------------------------------------------------------------------------- module Data.Geometry.Point.Quadrants where -import Control.DeepSeq import Control.Lens -import Data.Aeson import Data.Ext -import qualified Data.Foldable as F import Data.Geometry.Point.Class import Data.Geometry.Point.Internal -import Data.Geometry.Properties import Data.Geometry.Vector -import qualified Data.Geometry.Vector as Vec -import Data.Hashable import qualified Data.List as L -import Data.Ord (comparing) -import Data.Proxy -import GHC.Generics (Generic) import GHC.TypeLits -import System.Random (Random(..)) -import Test.QuickCheck (Arbitrary) -import Text.ParserCombinators.ReadP (ReadP, string,pfail) -import Text.ParserCombinators.ReadPrec (lift) -import Text.Read (Read(..),readListPrecDefault, readPrec_to_P,minPrec) -------------------------------------------------------------------------------- diff --git a/src/Data/Geometry/PointLocation.hs b/src/Data/Geometry/PointLocation.hs new file mode 100644 --- /dev/null +++ b/src/Data/Geometry/PointLocation.hs @@ -0,0 +1,12 @@ +-------------------------------------------------------------------------------- +-- | +-- Module : Data.Geometry.PointLocation +-- Copyright : (C) Frank Staals +-- License : see the LICENSE file +-- Maintainer : Frank Staals +-------------------------------------------------------------------------------- +module Data.Geometry.PointLocation + ( module Data.Geometry.PointLocation.PersistentSweep + ) where + +import Data.Geometry.PointLocation.PersistentSweep diff --git a/src/Data/Geometry/PointLocation/PersistentSweep.hs b/src/Data/Geometry/PointLocation/PersistentSweep.hs new file mode 100644 --- /dev/null +++ b/src/Data/Geometry/PointLocation/PersistentSweep.hs @@ -0,0 +1,177 @@ +{-# Language TemplateHaskell #-} +{-# Language TypeApplications #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Data.Geometry.PointLocation.PersistentSweep +-- Copyright : (C) Frank Staals +-- License : see the LICENSE file +-- Maintainer : Frank Staals +-------------------------------------------------------------------------------- +module Data.Geometry.PointLocation.PersistentSweep + ( PointLocationDS(PointLocationDS) + , verticalRayShootingStructure, subdivision, outerFace + + -- * Building the Data Structure + , pointLocationDS + -- * Querying the Data Structure + , dartAbove, dartAboveOrOn + , faceContaining, faceIdContaining + + , InPolygonDS, inPolygonDS + , InOut(..) + + , pointInPolygon + , edgeOnOrAbove + ) where + +import qualified Data.Geometry.VerticalRayShooting.PersistentSweep as VRS +import Control.Lens hiding (contains, below) +import Data.Ext +import Data.Geometry.LineSegment +import Data.Geometry.PlanarSubdivision +import Data.Geometry.Point +import Data.Geometry.Polygon +import qualified Data.List.NonEmpty as NonEmpty +import Data.Proxy +import Data.Util (SP(..)) +import qualified Data.Vector as V + +-------------------------------------------------------------------------------- + +-- | Planar Point Location Data structure +data PointLocationDS s v e f r = PointLocationDS { + _verticalRayShootingStructure :: VRS.VerticalRayShootingStructure v (Dart s) r + , _subdivision :: PlanarSubdivision s v e f r + , _outerFace :: FaceId' s + } deriving (Show,Eq) + +makeLensesWith (lensRules&generateUpdateableOptics .~ False) ''PointLocationDS + +-------------------------------------------------------------------------------- +-- * Buidlding the Point location Data structure + +-- | Builds a pointlocation data structure on the planar subdivision with \(n\) +-- vertices. +-- +-- running time: \(O(n\log n)\). +-- space: \(O(n\log n)\). +pointLocationDS :: (Ord r, Fractional r) + => PlanarSubdivision s v e f r -> PointLocationDS s v e f r +pointLocationDS ps = PointLocationDS (VRS.verticalRayShootingStructure es) ps (outerFaceId ps) + where + es = NonEmpty.fromList . V.toList . fmap (\(d,s) -> s&extra .~ d) . edgeSegments $ ps + -- the VRS structure will throw away vertical edges. So there is no need to + -- explicitly filter them yet at this point + +-------------------------------------------------------------------------------- +-- * Querying the Structure + +-- | Locates the first edge (dart) strictly above the query point. +-- returns Nothing if the query point lies in the outer face and there is no dart +-- above it. +-- +-- running time: \(O(\log n)\) +dartAbove :: (Ord r, Fractional r) + => Point 2 r -> PointLocationDS s v e f r -> Maybe (Dart s) +dartAbove = queryWith VRS.segmentAbove + +dartAboveOrOn :: (Ord r, Fractional r) + => Point 2 r -> PointLocationDS s v e f r -> Maybe (Dart s) +dartAboveOrOn = queryWith VRS.segmentAboveOrOn + +type QueryAlgorithm v e r = + Point 2 r -> VRS.VerticalRayShootingStructure v e r -> Maybe (LineSegment 2 v r :+ e) + +queryWith :: (Ord r, Fractional r) + => QueryAlgorithm v (Dart s) r + -> Point 2 r -> PointLocationDS s v e f r -> Maybe (Dart s) +queryWith query q = fmap (view extra) . query q . view verticalRayShootingStructure + +-- | Locates the face containing the query point. +-- +-- running time: \(O(\log n)\) +faceContaining :: (Ord r, Fractional r) + => Point 2 r -> PointLocationDS s v e f r -> f +faceContaining q ds = ds^.subdivision.dataOf (faceIdContaining q ds) + +-- | Locates the faceId of the face containing the query point. +-- +-- If the query point lies *on* an edge, an arbitrary face incident to +-- the edge is returned. +-- +-- running time: \(O(\log n)\) +faceIdContaining :: (Ord r, Fractional r) + => Point 2 r -> PointLocationDS s v e f r -> FaceId' s +faceIdContaining q ds = dartToFace ds $ dartAbove q ds + +-- | Given the dart determine the faceId correspondig to it (depending +-- on the orientation of the dart that is returned.) +dartToFace :: Ord r => PointLocationDS s v e f r -> Maybe (Dart s) -> FaceId' s +dartToFace ds = maybe (ds^.outerFace) getFace + where + ps = ds^.subdivision + getFace d = let (u,v) = bimap (^.location) (^.location) $ endPointData d ps + in if u <= v then rightFace d ps + else leftFace d ps + + +data OneOrTwo a = One !a | Two !a !a deriving (Show,Read,Eq,Ord,Functor,Foldable,Traversable) + +-- | Locates the faceId of the face containing the query point. If the +-- query point lies on an edge, it returns both faces incident to the +-- edge; first the one below the edge then the one above the edge. +-- +-- running time: \(O(\log n)\) +faceIdContaining' :: (Ord r, Fractional r) + => Point 2 r -> PointLocationDS s v e f r -> OneOrTwo (FaceId' s) +faceIdContaining' q ds = maybe (One $ ds^.outerFace) getFace $ dartAboveOrOn q ds + where + ps = ds^.subdivision + + getFace = getFace' . orient + + orient d = let (u,v) = bimap (^.location) (^.location) $ endPointData d ps + in if u <= v then (d,u,v) else (twin d, v, u) + + + getFace' (d,u,v) = case ccw u q v of + CoLinear -> Two (rightFace d ps) (leftFace d ps) + _ -> One (rightFace d ps) + +-------------------------------------------------------------------------------- + +-- | Data structure for fast InPolygon Queries +-- newtype InPolygonDS v r = InPolygonDS (VRS.VerticalRayShootingStructure (Vertex v r) () r) +-- deriving (Show,Eq) + +data InOut = In | Out deriving (Show,Eq) + +data Dummy +type InPolygonDS v r = PointLocationDS Dummy (SP Int v) () InOut r + + +-- type Vertex v r = Int :+ (Point 2 r :+ v) + +inPolygonDS :: (Fractional r, Ord r) => SimplePolygon v r -> InPolygonDS v r +inPolygonDS pg = pointLocationDS $ fromSimplePolygon (Proxy @Dummy) (numberVertices pg) In Out + +-- | Finds the edge on or above the query point, if it exists +-- +-- +edgeOnOrAbove :: (Ord r, Fractional r) + => Point 2 r -> InPolygonDS v r -> Maybe (LineSegment 2 (SP Int v) r) +edgeOnOrAbove q ds = view core . flip edgeSegment (ds^.subdivision) <$> dartAboveOrOn q ds + + +-- | Returns if a query point lies in (or on the boundary of) the polygon. +-- +-- \(O(\log n)\) +pointInPolygon :: (Ord r, Fractional r) => Point 2 r -> InPolygonDS v r -> InOut +pointInPolygon q ds = case faceIdContaining' q ds of + One i -> ds^.subdivision.dataOf i + Two _ _ -> In -- on an edge, so inside. + + -- FIXME: Make sure to also test the edge "below" q, i.e. if q is on + -- some edge we should return that edge. + + -- FIXME: Figure out if this works ok for vertical edges as well diff --git a/src/Data/Geometry/PolyLine.hs b/src/Data/Geometry/PolyLine.hs --- a/src/Data/Geometry/PolyLine.hs +++ b/src/Data/Geometry/PolyLine.hs @@ -1,6 +1,11 @@ -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE UndecidableInstances #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Data.Geometry.PolyLine +-- Copyright : (C) Frank Staals +-- License : see the LICENSE file +-- Maintainer : Frank Staals +-------------------------------------------------------------------------------- module Data.Geometry.PolyLine where import Control.Lens @@ -35,8 +40,11 @@ -- | A Poly line in R^d has at least 2 vertices newtype PolyLine d p r = PolyLine { _points :: LSeq 2 (Point d r :+ p) } deriving (Generic) -makeLenses ''PolyLine +-- | PolyLines are isomorphic to a sequence of points with at least 2 members. +points :: Iso (PolyLine d1 p1 r1) (PolyLine d2 p2 r2) (LSeq 2 (Point d1 r1 :+ p1)) (LSeq 2 (Point d2 r2 :+ p2)) +points = iso (\(PolyLine s) -> s) PolyLine + deriving instance (Show r, Show p, Arity d) => Show (PolyLine d p r) deriving instance (Eq r, Eq p, Arity d) => Eq (PolyLine d p r) deriving instance (Ord r, Ord p, Arity d) => Ord (PolyLine d p r) @@ -70,6 +78,16 @@ toEncoding = genericToEncoding defaultOptions instance (FromJSON p, FromJSON r, Arity d, KnownNat d) => FromJSON (PolyLine d p r) +instance HasStart (PolyLine d p r) where + type StartCore (PolyLine d p r) = Point d r + type StartExtra (PolyLine d p r) = p + start = points.head1 + +instance HasEnd (PolyLine d p r) where + type EndCore (PolyLine d p r) = Point d r + type EndExtra (PolyLine d p r) = p + end = points.last1 + -- | Builds a Polyline from a list of points, if there are sufficiently many points fromPoints :: [Point d r :+ p] -> Maybe (PolyLine d p r) fromPoints = fmap PolyLine . LSeq.eval (C @ 2) . LSeq.fromList @@ -81,7 +99,7 @@ -- | pre: The input list contains at least two points. All extra vields are -- initialized with mempty. fromPointsUnsafe' :: (Monoid p) => [Point d r] -> PolyLine d p r -fromPointsUnsafe' = fromPointsUnsafe . map (\p -> p :+ mempty) +fromPointsUnsafe' = fromPointsUnsafe . map (:+ mempty) -- | We consider the line-segment as closed. @@ -111,9 +129,9 @@ -- running time: \(O(\log n)\) -- -- >>> interpolatePoly 0.5 myPolyLine --- Point2 [5.0,5.0] +-- Point2 5.0 5.0 -- >>> interpolatePoly 1.5 myPolyLine --- Point2 [10.0,15.0] +-- Point2 10.0 15.0 interpolatePoly :: (RealFrac r, Arity d) => r -> PolyLine d p r -> Point d r interpolatePoly t pl = let i = floor t in case edgeSegments pl^?ix i of Nothing -> pl^.points.to LSeq.last.core diff --git a/src/Data/Geometry/Polygon.hs b/src/Data/Geometry/Polygon.hs --- a/src/Data/Geometry/Polygon.hs +++ b/src/Data/Geometry/Polygon.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE TemplateHaskell #-} -------------------------------------------------------------------------------- -- | -- Module : Data.Geometry.Polygon @@ -9,43 +8,76 @@ -- A Polygon data type and some basic functions to interact with them. -- -------------------------------------------------------------------------------- -module Data.Geometry.Polygon( PolygonType(..) - , Polygon(..) - , _SimplePolygon, _MultiPolygon - , SimplePolygon, MultiPolygon, SomePolygon +module Data.Geometry.Polygon + ( -- * Types + PolygonType(..) + , Polygon(..) + , _SimplePolygon, _MultiPolygon + , SimplePolygon, MultiPolygon, SomePolygon - , fromPoints + -- * Conversion + , fromPoints + , fromCircularVector - , polygonVertices, listEdges + , simpleFromPoints + , simpleFromCircularVector - , outerBoundary, outerBoundaryEdges - , outerVertex, outerBoundaryEdge + , unsafeFromPoints + , unsafeFromCircularVector + , unsafeFromVector + , toVector + , toPoints - , polygonHoles, polygonHoles' - , holeList + , isSimple - , inPolygon, insidePolygon, onBoundary + -- * Accessors - , area, signedArea + , size + , polygonVertices, listEdges - , centroid - , pickPoint + , outerBoundary, outerBoundaryVector + , unsafeOuterBoundaryVector + , outerBoundaryEdges + , outerVertex, outerBoundaryEdge - , isTriangle, isStarShaped + , polygonHoles, polygonHoles' + , holeList - , isCounterClockwise - , toCounterClockWiseOrder, toCounterClockWiseOrder' - , toClockwiseOrder, toClockwiseOrder' - , reverseOuterBoundary + -- * Properties - , findDiagonal + , area, signedArea + , centroid - , withIncidentEdges, numberVertices + -- * Queries + , inPolygon, insidePolygon, onBoundary - , asSimplePolygon - , extremesLinear, cmpExtreme - ) where + , isTriangle, isStarShaped + + , isCounterClockwise + , toCounterClockWiseOrder, toCounterClockWiseOrder' + , toClockwiseOrder, toClockwiseOrder' + , reverseOuterBoundary + + , rotateLeft + , rotateRight + , maximumVertexBy + , minimumVertexBy + + + -- * Misc + , pickPoint + , findDiagonal + + , withIncidentEdges, numberVertices + + , extremesLinear, cmpExtreme + + , findRotateTo + + ) where + +import Algorithms.Geometry.InPolygon import Algorithms.Geometry.LinearProgramming.LP2DRIC import Algorithms.Geometry.LinearProgramming.Types import Control.Lens hiding (Simple) @@ -54,10 +86,13 @@ import qualified Data.Foldable as F import Data.Geometry.HalfSpace (rightOf) import Data.Geometry.Line +import Data.Geometry.LineSegment import Data.Geometry.Point +import Data.Geometry.Boundary import Data.Geometry.Polygon.Core import Data.Geometry.Polygon.Extremes - +import Data.Geometry.Properties +import qualified Data.Sequence as Seq -------------------------------------------------------------------------------- -- * Polygons @@ -76,3 +111,30 @@ -- the first vertex is the intersection point of the two supporting lines -- bounding it, so the first two edges bound the shape in this sirection hs = fmap (rightOf . supportingLine) . outerBoundaryEdges $ pg + + +-------------------------------------------------------------------------------- +-- * Instances + +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 + +-- instance IsIntersectableWith (Line 2 r) (Boundary (Polygon t p r)) where +-- nonEmptyIntersection _ _ (CoRec xs) = null xs +-- l `intersect` (Boundary (SimplePolygon vs)) = +-- undefined + -- l `intersect` (Boundary (MultiPolygon vs hs)) = coRec . + -- Seq.sortBy f . Seq.fromList + -- . concatMap (unpack . (l `intersect`) . Boundary) + -- $ SimplePolygon vs : hs + -- where + -- unpack (CoRec x) = x + -- f = undefined diff --git a/src/Data/Geometry/Polygon/Convex.hs b/src/Data/Geometry/Polygon/Convex.hs --- a/src/Data/Geometry/Polygon/Convex.hs +++ b/src/Data/Geometry/Polygon/Convex.hs @@ -1,5 +1,4 @@ {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -------------------------------------------------------------------------------- -- | -- Module : Data.Geometry.Polygon.Convex @@ -10,54 +9,82 @@ -- Convex Polygons -- -------------------------------------------------------------------------------- -module Data.Geometry.Polygon.Convex( ConvexPolygon(..), simplePolygon - , merge - , lowerTangent, lowerTangent' - , upperTangent, upperTangent' +module Data.Geometry.Polygon.Convex + ( ConvexPolygon(..), simplePolygon + , convexPolygon + , isConvex, verifyConvex + , merge + , lowerTangent, lowerTangent' + , upperTangent, upperTangent' - , extremes - , maxInDirection + , extremes + , maxInDirection - , leftTangent, rightTangent + , leftTangent, rightTangent - , minkowskiSum - , bottomMost - ) where + , minkowskiSum + , bottomMost + , inConvex + , randomConvex -import Control.DeepSeq -import Control.Lens hiding ((:<), (:>)) -import Data.CircularSeq (CSeq) -import qualified Data.CircularSeq as C + , diameter + , diametralPair + , diametralIndexPair + ) where + + +import Control.DeepSeq (NFData) +import Control.Lens (Iso, iso, over, view, (%~), (&), (^.)) +import Control.Monad.Random +import Control.Monad.ST +import Control.Monad.State +import Data.Coerce import Data.Ext -import qualified Data.Foldable as F -import Data.Function (on) -import Data.Geometry.Box (IsBoxable(..)) +import qualified Data.Foldable as F +import Data.Function (on) +import Data.Geometry.Boundary +import Data.Geometry.Box (IsBoxable (..)) import Data.Geometry.LineSegment import Data.Geometry.Point -import Data.Geometry.Polygon.Core (fromPoints, SimplePolygon, outerBoundary) -import Data.Geometry.Polygon.Extremes(cmpExtreme) +import Data.Geometry.Polygon.Core (Polygon (..), SimplePolygon, centroid, + outerBoundaryVector, outerVertex, size, + unsafeFromPoints, unsafeFromVector, + unsafeOuterBoundaryVector) +import Data.Geometry.Polygon.Extremes (cmpExtreme) import Data.Geometry.Properties import Data.Geometry.Transformation +import Data.Geometry.Triangle import Data.Geometry.Vector -import Data.List.NonEmpty (NonEmpty(..)) -import qualified Data.List.NonEmpty as NonEmpty -import Data.Maybe (fromJust) -import Data.Ord (comparing) -import Data.Semigroup.Foldable (Foldable1(..)) -import Data.Sequence (viewl,viewr, ViewL(..), ViewR(..)) -import qualified Data.Sequence as S +import qualified Data.IntSet as IS +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NonEmpty +import Data.Maybe (fromJust) +import Data.Ord (comparing) +import Data.Semigroup.Foldable (Foldable1 (..)) import Data.Util - +import qualified Data.Vector as V +import Data.Vector.Circular (CircularVector) +import qualified Data.Vector.Circular as CV +import qualified Data.Vector.Circular.Util as CV +import qualified Data.Vector.Mutable as Mut +import qualified Data.Vector.NonEmpty as NE +import qualified Data.Vector.Unboxed as VU -- import Data.Geometry.Ipe --- import Debug.Trace +-- import Data.Ratio +-- import Data.RealNumber.Rational +-- import Debug.Trace -------------------------------------------------------------------------------- -- | Data Type representing a convex polygon newtype ConvexPolygon p r = ConvexPolygon {_simplePolygon :: SimplePolygon p r } deriving (Show,Eq,NFData) -makeLenses ''ConvexPolygon +-- | ConvexPolygons are isomorphic to SimplePolygons with the added constraint that they have no +-- reflex vertices. +simplePolygon :: Iso (ConvexPolygon p1 r1) (ConvexPolygon p2 r2) (SimplePolygon p1 r1) (SimplePolygon p2 r2) +simplePolygon = iso _simplePolygon ConvexPolygon + instance PointFunctor (ConvexPolygon p) where pmap f (ConvexPolygon p) = ConvexPolygon $ pmap f p @@ -73,14 +100,110 @@ boundingBox = boundingBox . _simplePolygon --- convexPolygon :: SimplePolygon p r -> Maybe (ConvexPolygon p r) --- convexPolygon p = if isConvex p then Just p else Nothing --- isConvex :: SimplePolygon p r -> Bool --- isConvex p = let ch = convexHull $ p^.vertices --- in p^.vertices.size == ch^.simplePolygon.vertices.size +-------------------------------------------------------------------------------- +-- Convex hull of simple polygon. +type M s v a = StateT (Mut.MVector s v, Int) (ST s) a +runM :: Int -> M s v () -> ST s (Mut.MVector s v) +runM s action = do + v <- Mut.new (2*s) + (v', f) <- execStateT action (Mut.drop s v, 0) + return $ Mut.tail $ Mut.take f v' + +dequeRemove :: M s a () +dequeRemove = do + modify $ \(Mut.MVector offset len arr, f) -> (Mut.MVector (offset+1) (len-1) arr, f-1) + +dequeInsert :: a -> M s a () +dequeInsert a = do + modify $ \(Mut.MVector offset len arr, f) -> (Mut.MVector (offset-1) (len+1) arr, f+1) + (v,_) <- get + Mut.write v 0 a + +dequePush :: a -> M s a () +dequePush a = do + (v, f) <- get + Mut.write v f a + put (v,f+1) + +dequePop :: M s a () +dequePop = do + modify $ \(v,f) -> (v,f-1) + +dequeBottom :: Int -> M s a a +dequeBottom idx = do + (v,_) <- get + Mut.read v idx + +dequeTop :: Int -> M s a a +dequeTop idx = do + (v,f) <- get + Mut.read v (f-idx-1) + +-- Melkman's algorithm: http://citeseerx.ist.psu.edu/viewdoc/download?doi=10.1.1.512.9681&rep=rep1&type=pdf + +-- | \( O(n) \) Convex hull of a simple polygon. +-- +-- For algorithmic details see: +convexPolygon :: forall t p r. (Ord r, Num r, Show r, Show p) => Polygon t p r -> ConvexPolygon p r +convexPolygon p = ConvexPolygon $ unsafeFromVector $ V.create $ runM (size p) $ + findStartingPoint 2 + where + -- Find the first spot where 0,n-1,n is not colinear. + findStartingPoint :: Int -> M s (Point 2 r :+ p) () + findStartingPoint nth = do + let vPrev = NE.unsafeIndex vs (nth-1) + vNth = NE.unsafeIndex vs nth + case ccw' v1 vPrev vNth of + CoLinear -> findStartingPoint (nth+1) + CCW -> do + dequePush v1 >> dequePush vPrev + dequePush vNth; dequeInsert vNth + V.mapM_ build (NE.drop (nth+1) vs) + CW -> do + dequePush vPrev >> dequePush v1 + dequePush vNth; dequeInsert vNth + V.mapM_ build (NE.drop (nth+1) vs) + + v1 = NE.unsafeIndex vs 0 + vs = CV.vector (p^.outerBoundaryVector) + build v = do + botTurn <- ccw' <$> pure v <*> dequeBottom 0 <*> dequeBottom 1 + topTurn <- ccw' <$> dequeTop 1 <*> dequeTop 0 <*> pure v + when (botTurn == CW || topTurn == CW) $ do + backtrackTop v; dequePush v + backtrackBot v; dequeInsert v + backtrackTop v = do + turn <- ccw' <$> dequeTop 1 <*> dequeTop 0 <*> pure v + unless (turn == CCW) $ do + dequePop + backtrackTop v + backtrackBot v = do + turn <- ccw' <$> pure v <*> dequeBottom 0 <*> dequeBottom 1 + unless (turn == CCW) $ do + dequeRemove + backtrackBot v + + + + + + + +-- | \( O(n) \) Check if a polygon is strictly convex. +isConvex :: (Ord r, Num r) => SimplePolygon p r -> Bool +isConvex s = + CV.and (CV.zipWith3 f (CV.rotateLeft 1 vs) vs (CV.rotateRight 1 vs)) + where + f a b c = ccw' a b c == CCW + vs = s ^. outerBoundaryVector + +-- | \( O(n) \) Verify that a convex polygon is strictly convex. +verifyConvex :: (Ord r, Num r) => ConvexPolygon p r -> Bool +verifyConvex = isConvex . _simplePolygon + -- mainWith inFile outFile = do -- ePage <- readSinglePageFile inFile -- case ePage of @@ -115,13 +238,40 @@ -- -- pre: The input polygon is strictly convex. -- --- running time: \(O(\log^2 n)\) +-- running time: \(O(\log n)\) maxInDirection :: (Num r, Ord r) => Vector 2 r -> ConvexPolygon p r -> Point 2 r :+ p maxInDirection u = findMaxWith (cmpExtreme u) +-- FIXME: c+1 is always less than n so we don't need to use `mod` or do bounds checking. +-- Use unsafe indexing. +-- \( O(\log n) \) +findMaxWith :: (Point 2 r :+ p -> Point 2 r :+ p -> Ordering) + -> ConvexPolygon p r -> Point 2 r :+ p +findMaxWith cmp p = CV.index v (worker 0 (F.length v)) + where + v = p ^. simplePolygon.outerBoundaryVector + a `icmp` b = CV.index v a `cmp` CV.index v b + worker a b + | localMaximum c = c + | a+1==b = b + | otherwise = + case (isUpwards a, isUpwards c, c `icmp` a /= LT) of + (True, False, _) -> worker a c -- A is up, C is down, pick [a,c] + (True, True, True) -> worker c b -- A is up, C is up, C is GTE A, pick [c,b] + (True, True, False) -> worker a c -- A is up, C is LT A, pick [a,c] + (False, True, _) -> worker c b -- A is down, C is up, pick [c,b] + (False, False, False) -> worker c b -- A is down, C is down, C is LT A, pick [c,b] + (False, _, True) -> worker a c -- A is down, C is GTE A, pick [a,c] + where + c = (a+b) `div` 2 + localMaximum idx = idx `icmp` (c-1) == GT && idx `icmp` (c+1) == GT + isUpwards idx = idx `icmp` (idx+1) /= GT + +{- Convex binary search using sequences in \( O(log^2 n) \) + findMaxWith :: (Point 2 r :+ p -> Point 2 r :+ p -> Ordering) -> ConvexPolygon p r -> Point 2 r :+ p -findMaxWith cmp p = findMaxStart . C.rightElements . getVertices $ p +findMaxWith cmp = findMaxStart . S.fromList . F.toList . getVertices where p' >=. q = (p' `cmp` q) /= LT @@ -140,7 +290,7 @@ | otherwise = binSearch ac c cb -- | Given the vertices [a..] c [..b] find the exteral vtx - binSearch ac@(viewl -> a:=. c) of + binSearch ac@(viewl -> a: c), isUpwards c cb, a >=. c) of (True,False,_) -> findMax (ac |> c) (True,True,True) -> findMax (ac |> c) (True,True,False) -> findMax (c <| cb) @@ -157,7 +307,7 @@ -- the Edge from a to b is upwards w.r.t b if a is not larger than b isUpwards a (viewl -> b :< _) = (a `cmp` b) /= GT isUpwards _ _ = error "isUpwards: no edge endpoint" - +-} tangentCmp :: (Num r, Ord r) => Point 2 r -> Point 2 r :+ p -> Point 2 r :+ q -> Ordering @@ -167,19 +317,19 @@ CW -> GT -- q is right of the line from o to p --- | Given a convex polygon poly, and a point outside the polygon, find the +-- | Given a convex polygon poly, and a point outside the polygon, find the -- left tangent of q and the polygon, i.e. the vertex v of the convex polygon -- s.t. the polygon lies completely to the right of the line from q to v. -- --- running time: \(O(\log^2 n)\). +-- running time: \(O(\log n)\). leftTangent :: (Ord r, Num r) => ConvexPolygon p r -> Point 2 r -> Point 2 r :+ p leftTangent poly q = findMaxWith (tangentCmp q) poly --- | Given a convex polygon poly, and a point outside the polygon, find the +-- | Given a convex polygon poly, and a point outside the polygon, find the -- right tangent of q and the polygon, i.e. the vertex v of the convex polygon -- s.t. the polygon lies completely to the left of the line from q to v. -- --- running time: \(O(\log^2 n)\). +-- running time: \(O(\log n)\). rightTangent :: (Ord r, Num r) => ConvexPolygon p r -> Point 2 r -> Point 2 r :+ p rightTangent poly q = findMaxWith (flip $ tangentCmp q) poly @@ -209,21 +359,21 @@ -- Running time: O(n+m), where n and m are the sizes of the two polygons respectively merge :: (Num r, Ord r) => ConvexPolygon p r -> ConvexPolygon p r -> (ConvexPolygon p r, LineSegment 2 p r, LineSegment 2 p r) -merge lp rp = (ConvexPolygon . fromPoints $ r' ++ l', lt, ut) +merge lp rp = (ConvexPolygon . unsafeFromPoints $ r' ++ l', lt, ut) where lt@(ClosedLineSegment a b) = lowerTangent lp rp ut@(ClosedLineSegment c d) = upperTangent lp rp takeUntil p xs = let (xs',x:_) = break p xs in xs' ++ [x] - rightElems = F.toList . C.rightElements + rightElems = F.toList . CV.rightElements takeAndRotate x y = takeUntil (coreEq x) . rightElems . rotateTo' y . getVertices r' = takeAndRotate b d rp l' = takeAndRotate c a lp -rotateTo' :: Eq a => (a :+ b) -> CSeq (a :+ b) -> CSeq (a :+ b) -rotateTo' x = fromJust . C.findRotateTo (coreEq x) +rotateTo' :: Eq a => (a :+ b) -> CircularVector (a :+ b) -> CircularVector (a :+ b) +rotateTo' x = fromJust . CV.findRotateTo (coreEq x) coreEq :: Eq a => (a :+ b) -> (a :+ b) -> Bool coreEq = (==) `on` (^.core) @@ -246,9 +396,8 @@ -> LineSegment 2 p r lowerTangent lp rp = ClosedLineSegment l r where - mkH f = NonEmpty.fromList . F.toList . f . getVertices - lh = mkH (C.rightElements . rightMost) lp - rh = mkH (C.leftElements . leftMost) rp + lh = CV.rightElements . rightMost . getVertices $ lp + rh = CV.leftElements . leftMost . getVertices $ rp (Two (l :+ _) (r :+ _)) = lowerTangent' lh rh -- | Compute the lower tangent of the two convex chains lp and rp @@ -286,16 +435,15 @@ -- the two polygons. -- - The vertices of the polygons are given in clockwise order -- --- Running time: O(n+m), where n and m are the sizes of the two polygons respectively +-- Running time: \( O(n+m) \), where n and m are the sizes of the two polygons respectively upperTangent :: (Num r, Ord r) => ConvexPolygon p r -> ConvexPolygon p r -> LineSegment 2 p r upperTangent lp rp = ClosedLineSegment l r where - mkH f = NonEmpty.fromList . F.toList . f . getVertices - lh = mkH (C.leftElements . rightMost) lp - rh = mkH (C.rightElements . leftMost) rp + lh = CV.leftElements . rightMost . getVertices $ lp + rh = CV.rightElements . leftMost . getVertices $ rp (Two (l :+ _) (r :+ _)) = upperTangent' lh rh -- | Compute the upper tangent of the two convex chains lp and rp @@ -335,14 +483,14 @@ -- running time: \(O(n+m)\). minkowskiSum :: (Ord r, Num r) => ConvexPolygon p r -> ConvexPolygon q r -> ConvexPolygon (p,q) r -minkowskiSum p q = ConvexPolygon . fromPoints $ merge' (f p) (f q) +minkowskiSum p q = ConvexPolygon . unsafeFromPoints $ merge' (f p) (f q) where - f p' = let xs@(S.viewl -> (v :< _)) = C.asSeq . bottomMost . getVertices $ p' - in F.toList $ xs |> v - (v :+ ve) .+. (w :+ we) = v .+^ (toVec w) :+ (ve,we) + f p' = let (v:xs) = F.toList . bottomMost . getVertices $ p' + in v:xs++[v] + (v :+ ve) .+. (w :+ we) = v .+^ toVec w :+ (ve,we) cmpAngle v v' w w' = - ccwCmpAround (ext $ origin) (ext . Point $ v' .-. v) (ext . Point $ w' .-. w) + ccwCmpAround origin (Point $ v' .-. v) (Point $ w' .-. w) merge' [_] [_] = [] merge' vs@[v] (w:ws) = v .+. w : merge' vs ws @@ -352,32 +500,117 @@ LT -> merge' (v':vs) (w:w':ws) GT -> merge' (v:v':vs) (w':ws) EQ -> merge' (v':vs) (w':ws) - merge' _ _ = error $ "minkowskiSum: Should not happen" + merge' _ _ = error "minkowskiSum: Should not happen" +-------------------------------------------------------------------------------- +-- inConvex +-- 1. Check if p is on left edge or right edge. +-- 2. Do binary search: +-- Find the largest n where p is on the right of 0 to n. +-- 3. Check if p is on segment n,n+1 +-- 4. Check if p is in triangle 0,n,n+1 +-- | \( O(\log n) \) +-- Check if a point lies inside a convex polygon, on the boundary, or outside of the +-- convex polygon. +inConvex :: forall p r. (Fractional r, Ord r) + => Point 2 r -> ConvexPolygon p r + -> PointLocationResult +inConvex p (ConvexPolygon poly) + | p `intersects` leftEdge = OnBoundary + | p `intersects` rightEdge = OnBoundary + | otherwise = worker 1 n + where + p' = p :+ undefined + n = size poly - 1 + point0 = point 0 + leftEdge = ClosedLineSegment point0 (point n) + rightEdge = ClosedLineSegment point0 (point 1) + worker a b + | a+1 == b = + if p `intersects` (ClosedLineSegment (point a) (point b)) + then OnBoundary + else + if inTriangle p (Triangle point0 (point a) (point b)) == Outside + then Outside + else Inside + | ccw' point0 (point c) p' == CCW = worker c b + | otherwise = worker a c + where c = (a+b) `div` 2 + point x = poly ^. outerVertex x + -------------------------------------------------------------------------------- +-- Diameter +-- | \( O(n) \) Computes the Euclidean diameter by scanning antipodal pairs. +diameter :: (Ord r, Floating r) => ConvexPolygon p r -> r +diameter p = euclideanDist (a^.core) (b^.core) + where + (a,b) = diametralPair p + +-- | \( O(n) \) +-- Computes the Euclidean diametral pair by scanning antipodal pairs. +diametralPair :: (Ord r, Num r) => ConvexPolygon p r -> (Point 2 r :+ p, Point 2 r :+ p) +diametralPair p = (p^.simplePolygon.outerVertex a, p^.simplePolygon.outerVertex b) + where + (a,b) = diametralIndexPair p + +-- | \( O(n) \) +-- Computes the Euclidean diametral pair by scanning antipodal pairs. +diametralIndexPair :: (Ord r, Num r) => ConvexPolygon p r -> (Int, Int) +diametralIndexPair p = F.maximumBy fn $ antipodalPairs p + where + fn (a1,b1) (a2,b2) = + squaredEuclideanDist (p^.simplePolygon.outerVertex a1.core) (p^.simplePolygon.outerVertex b1.core) + `compare` + squaredEuclideanDist (p^.simplePolygon.outerVertex a2.core) (p^.simplePolygon.outerVertex b2.core) + +antipodalPairs :: forall p r. (Ord r, Num r) => ConvexPolygon p r -> [(Int, Int)] +antipodalPairs p = worker 0 (CV.index vectors 0) 1 + where + n = size (p^.simplePolygon) + vs = p^.simplePolygon.outerBoundaryVector + + worker a aElt b + | a == n = [] + | otherwise = + case ccw aElt (Point2 0 0) (CV.index vectors b) of + CW -> worker a aElt (b+1) + _ -> + (a, b `mod` n) : + worker (a+1) (CV.index vectors (a+1)) b + + vectors :: CircularVector (Point 2 r) + vectors = CV.unsafeFromVector $ V.generate n $ \i -> + let Point p1 = point i + p2 = point (i+1) + in p2 .-^ p1 + + point x = CV.index vs x ^. core + +-------------------------------------------------------------------------------- + -- | Rotate to the rightmost point (rightmost and topmost in case of ties) -rightMost :: Ord r => CSeq (Point 2 r :+ p) -> CSeq (Point 2 r :+ p) -rightMost xs = let m = F.maximumBy (comparing (^.core)) xs in rotateTo' m xs +rightMost :: Ord r => CircularVector (Point 2 r :+ p) -> CircularVector (Point 2 r :+ p) +rightMost = CV.rotateToMaximumBy (comparing (^.core)) -- | Rotate to the leftmost point (and bottommost in case of ties) -leftMost :: Ord r => CSeq (Point 2 r :+ p) -> CSeq (Point 2 r :+ p) -leftMost xs = let m = F.minimumBy (comparing (^.core)) xs in rotateTo' m xs +leftMost :: Ord r => CircularVector (Point 2 r :+ p) -> CircularVector (Point 2 r :+ p) +leftMost = CV.rotateToMinimumBy (comparing (^.core)) -- | Rotate to the bottommost point (and leftmost in case of ties) -bottomMost :: Ord r => CSeq (Point 2 r :+ p) -> CSeq (Point 2 r :+ p) -bottomMost xs = let f p = (p^.core.yCoord,p^.core.xCoord) - m = F.minimumBy (comparing f) xs - in rotateTo' m xs +bottomMost :: Ord r => CircularVector (Point 2 r :+ p) -> CircularVector (Point 2 r :+ p) +bottomMost = CV.rotateToMinimumBy (comparing f) + where + f p = (p^.core.yCoord,p^.core.xCoord) -- | Helper to get the vertices of a convex polygon -getVertices :: ConvexPolygon p r -> CSeq (Point 2 r :+ p) -getVertices = view (simplePolygon.outerBoundary) +getVertices :: ConvexPolygon p r -> CircularVector (Point 2 r :+ p) +getVertices = view (simplePolygon.outerBoundaryVector) -- -- | rotate right while p 'current' 'rightNeibhour' is true -- rotateRWhile :: (a -> a -> Bool) -> C.CList a -> C.CList a @@ -401,3 +634,76 @@ -- testB :: Num r => ConvexPolygon () r -- testB = ConvexPolygon . fromPoints . map ext $ [origin, Point2 5 3, Point2 (-2) 2, Point2 (-2) 1] + + + + +-------------------------------------------------------------------------------- +-- Random convex polygons + +-- This is true for all convex polygons: +-- 1. the sum of all edge vectors is (0,0). This is even true for all polygons. +-- 2. edges are sorted by angle. Ie. all vertices are convex, not reflex. +-- +-- So, if we can generate a set of vectors that sum to zero then we can sort them +-- and place them end-to-end and the result will be a convex polygon. +-- +-- So, we need to generate N points that sum to 0. This can be done by generating +-- two sets of N points that sum to M, and the subtracting them from each other. +-- +-- Generating N points that sum to M is done like this: Generate (N-1) unique points +-- between (but not including) 0 and M. Write down the distance between the points. +-- Imagine a scale from 0 to M: +-- 0 M +-- | | +-- Then we add two randomly selected points: +-- 0 M +-- | * * | +-- Then we look at the distance between 0 and point1, point1 and point2, and point2 to M: +-- 0 M +-- |--*------*--| +-- 2 6 2 +-- 2+6+2 = 10 = M +-- +-- Doing this again might yield [5,2,3]. Subtract them: +-- [2, 6, 2 ] +-- - [5, 2, 3 ] +-- = [2-5, 6-2, 2-3] +-- = [-3, 4, -1 ] +-- And the sum of [-3, 4, -1] = -3+4-1 = 0. + +-- O(n log n) +randomBetween :: RandomGen g => Int -> Int -> Rand g (VU.Vector Int) +randomBetween n vMax | vMax < n+1 = pure $ VU.replicate vMax 1 +randomBetween n vMax = worker (n-1) IS.empty + where + gen from [] = [vMax-from] + gen from (x:xs) = (x-from) : gen x xs + worker 0 seen = pure (VU.fromList (gen 0 $ IS.elems seen)) + worker i seen = do + v <- getRandomR (1, vMax-1) + if IS.member v seen + then worker i seen + else worker (i-1) (IS.insert v seen) + +randomBetweenZero :: RandomGen g => Int -> Int -> Rand g (VU.Vector Int) +randomBetweenZero n vMax = VU.zipWith (-) <$> randomBetween n vMax <*> randomBetween n vMax + +randomEdges :: RandomGen g => Int -> Int -> Rand g [Vector 2 Int] +randomEdges n vMax = do + zipWith Vector2 + <$> fmap VU.toList (randomBetweenZero n vMax) + <*> fmap VU.toList (randomBetweenZero n vMax) + +-- | \( O(n \log n) \) +-- Generate a uniformly random ConvexPolygon with @N@ vertices and a granularity of @vMax@. +randomConvex :: RandomGen g => Int -> Int -> Rand g (ConvexPolygon () Rational) +randomConvex n _vMax | n < 3 = + error "Data.Geometry.Polygon.Convex.randomConvex: At least 3 edges are required." +randomConvex n vMax = do + ~(v:vs) <- coerce . sortAround origin . coerce <$> randomEdges n vMax + let vertices = fmap ((/ realToFrac vMax) . realToFrac) <$> scanl (.+^) (Point v) vs + pRational = unsafeFromPoints $ map ext vertices + Point c = centroid pRational + pFinal = pRational & unsafeOuterBoundaryVector %~ CV.map (over core (.-^ c)) + pure $ ConvexPolygon pFinal diff --git a/src/Data/Geometry/Polygon/Core.hs b/src/Data/Geometry/Polygon/Core.hs --- a/src/Data/Geometry/Polygon/Core.hs +++ b/src/Data/Geometry/Polygon/Core.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE OverloadedStrings #-} -------------------------------------------------------------------------------- -- | -- Module : Data.Geometry.Polygon.Core @@ -8,104 +9,167 @@ -- A Polygon data type and some basic functions to interact with them. -- -------------------------------------------------------------------------------- -module Data.Geometry.Polygon.Core( PolygonType(..) - , Polygon(..) - , _SimplePolygon, _MultiPolygon - , SimplePolygon, MultiPolygon, SomePolygon +module Data.Geometry.Polygon.Core + ( PolygonType(..) + , Polygon(..) + , Vertices + , _SimplePolygon, _MultiPolygon + , SimplePolygon, MultiPolygon, SomePolygon + -- * Construction + , fromPoints + , fromCircularVector - , fromPoints + , simpleFromPoints + , simpleFromCircularVector - , polygonVertices, listEdges + , unsafeFromPoints + , unsafeFromCircularVector + , unsafeFromVector + , toVector + , toPoints - , outerBoundary, outerBoundaryEdges - , outerVertex, outerBoundaryEdge + , isSimple - , polygonHoles, polygonHoles' - , holeList + , size + , polygonVertices, listEdges - , inPolygon, insidePolygon, onBoundary + , outerBoundary, outerBoundaryVector + , unsafeOuterBoundaryVector + , outerBoundaryEdges + , outerVertex, unsafeOuterVertex + , outerBoundaryEdge - , area, signedArea + , polygonHoles, polygonHoles' + , holeList - , centroid - , pickPoint + , area, signedArea - , isTriangle + , centroid + , pickPoint - , isCounterClockwise - , toCounterClockWiseOrder, toCounterClockWiseOrder' - , toClockwiseOrder, toClockwiseOrder' - , reverseOuterBoundary + , isTriangle - , findDiagonal + , isCounterClockwise + , toCounterClockWiseOrder, toCounterClockWiseOrder' + , toClockwiseOrder, toClockwiseOrder' + , reverseOuterBoundary - , withIncidentEdges, numberVertices + , findDiagonal - , asSimplePolygon - ) where + , withIncidentEdges, numberVertices + -- * Testing for Reflex or Convex + + , isReflexVertex, isConvexVertex, isStrictlyConvexVertex + , reflexVertices, convexVertices, strictlyConvexVertices + + -- * Specialized folds + , maximumVertexBy + , minimumVertexBy + , findRotateTo + , rotateLeft + , rotateRight + ) where + +import qualified Algorithms.Geometry.LineSegmentIntersection.BentleyOttmann as BO import Control.DeepSeq -import Control.Lens hiding (Simple) +import Control.Lens (Getter, Lens', Prism', + Traversal', lens, over, + prism', to, toListOf, + view, (%~), (&), (.~), + (^.)) +import Data.Aeson 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 qualified Data.Foldable as F import Data.Geometry.Boundary -import Data.Geometry.Box +import Data.Geometry.Box (IsBoxable (..), + boundingBoxList') 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.Geometry.Triangle (Triangle (..), + inTriangle) +import Data.Geometry.Vector (Additive (zero, (^+^)), + Affine ((.+^), (.-.)), + (*^), (^*), (^/)) +import qualified Data.List as List +import qualified Data.List.NonEmpty as NonEmpty +import Data.Maybe (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) +import Data.Vector (Vector) +import qualified Data.Vector as V +import Data.Vector.Circular (CircularVector) +import qualified Data.Vector.Circular as CV +import qualified Data.Vector.Circular.Util as CV + -- import Data.RealNumber.Rational -------------------------------------------------------------------------------- {- $setup >>> import Data.RealNumber.Rational +>>> import Data.Foldable +>>> import Control.Lens.Extras >>> :{ --- import qualified Data.CircularSeq as C +-- import qualified Data.Vector.Circular as CV let simplePoly :: SimplePolygon () (RealNumber 10) - simplePoly = SimplePolygon . C.fromList . map ext $ [ Point2 0 0 - , Point2 10 0 - , Point2 10 10 - , Point2 5 15 - , Point2 1 11 - ] + simplePoly = fromPoints . map ext $ + [ Point2 0 0 + , Point2 10 0 + , Point2 10 10 + , Point2 5 15 + , Point2 1 11 + ] + simpleTriangle :: SimplePolygon () (RealNumber 10) + simpleTriangle = fromPoints . map ext $ + [ Point2 0 0, Point2 2 0, Point2 1 1] + multiPoly :: MultiPolygon () (RealNumber 10) + multiPoly = MultiPolygon + (fromPoints . map ext $ [Point2 (-1) (-1), Point2 3 (-1), Point2 2 2]) + [simpleTriangle] :} -} --- | We distinguish between simple polygons (without holes) and Polygons with holes. +-- | We distinguish between simple polygons (without holes) and polygons with holes. data PolygonType = Simple | Multi - +-- | Polygons are sequences of points and may or may not contain holes. +-- +-- Degenerate polygons (polygons with self-intersections or fewer than 3 points) +-- are only possible if you use functions marked as unsafe. 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 :: Vertices (Point 2 r :+ p) -> SimplePolygon p r + MultiPolygon :: SimplePolygon p r -> [SimplePolygon p r] -> MultiPolygon p r +newtype Vertices a = Vertices (CircularVector a) + deriving (Functor, Foldable, Foldable1, Traversable, NFData, Eq, Ord) + -- | Prism to 'test' if we are a simple polygon -_SimplePolygon :: Prism' (Polygon Simple p r) (C.CSeq (Point 2 r :+ p)) +-- +-- >>> is _SimplePolygon simplePoly +-- True +_SimplePolygon :: Prism' (Polygon Simple p r) (Vertices (Point 2 r :+ p)) _SimplePolygon = prism' SimplePolygon (\(SimplePolygon vs) -> Just vs) -- | Prism to 'test' if we are a Multi polygon -_MultiPolygon :: Prism' (Polygon Multi p r) (C.CSeq (Point 2 r :+ p), [Polygon Simple p r]) +-- +-- >>> is _MultiPolygon multiPoly +-- True +_MultiPolygon :: Prism' (Polygon Multi p r) (Polygon Simple p r, [Polygon Simple p r]) _MultiPolygon = prism' (uncurry MultiPolygon) (\(MultiPolygon vs hs) -> Just (vs,hs)) +instance Functor (Polygon t p) where + fmap = bimap id + instance Bifunctor (Polygon t) where bimap = bimapDefault @@ -115,7 +179,7 @@ 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 + MultiPolygon vs hs -> MultiPolygon <$> bitraverse f g vs <*> traverse (bitraverse f g) hs instance (NFData p, NFData r) => NFData (Polygon t p r) where @@ -126,8 +190,10 @@ -> t (Point 2 r :+ p) -> f (t (Point 2 s :+ q)) bitraverseVertices f g = traverse (bitraverse (traverse g) f) +-- | Polygon without holes. type SimplePolygon = Polygon Simple +-- | Polygon with zero or more holes. type MultiPolygon = Polygon Multi -- | Either a simple or multipolygon @@ -141,9 +207,23 @@ 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 (SimplePolygon vs) = "SimplePolygon " <> show (F.toList vs) show (MultiPolygon vs hs) = "MultiPolygon (" <> show vs <> ") (" <> show hs <> ")" +instance (Read p, Read r) => Read (SimplePolygon p r) where + readsPrec d = readParen (d > app_prec) $ \r -> + [ (unsafeFromPoints vs, t) + | ("SimplePolygon", s) <- lex r, (vs, t) <- reads s ] + where app_prec = 10 + +instance (Read p, Read r) => Read (MultiPolygon p r) where + readsPrec d = readParen (d > app_prec) $ \r -> + [ (MultiPolygon vs hs, t') + | ("MultiPolygon", s) <- lex r + , (vs, t) <- reads s + , (hs, t') <- reads t ] + where app_prec = 10 + -- instance (Read p, Read r) => Show (Polygon t p r) where -- show (SimplePolygon vs) = "SimplePolygon (" <> show vs <> ")" -- show (MultiPolygon vs hs) = "MultiPolygon (" <> show vs <> ") (" <> show hs <> ")" @@ -156,54 +236,94 @@ 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) + pmap f (MultiPolygon vs hs) = MultiPolygon (pmap 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) + boundingBox = boundingBoxList' . toListOf (outerBoundaryVector.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 +instance (ToJSON r, ToJSON p) => ToJSON (Polygon t p r) where + toJSON = \case + (SimplePolygon vs) -> object [ "tag" .= ("SimplePolygon" :: String) + , "vertices" .= F.toList vs + ] + (MultiPolygon vs hs) -> object [ "tag" .= ("MultiPolygon" :: String) + , "outerBoundary" .= getVertices vs + , "holes" .= map getVertices hs + ] + where + getVertices = view (outerBoundaryVector.to F.toList) --- instance IsIntersectableWith (Line 2 r) (Boundary (Polygon t p r)) where --- nonEmptyIntersection _ _ (CoRec xs) = null xs --- l `intersect` (Boundary (SimplePolygon vs)) = --- undefined - -- l `intersect` (Boundary (MultiPolygon vs hs)) = coRec . - -- Seq.sortBy f . Seq.fromList - -- . concatMap (unpack . (l `intersect`) . Boundary) - -- $ SimplePolygon vs : hs - -- where - -- unpack (CoRec x) = x - -- f = undefined +instance (FromJSON r, Eq r, Num r, FromJSON p) => FromJSON (Polygon Simple p r) where + parseJSON = withObject "Polygon" $ \o -> o .: "tag" >>= \case + "SimplePolygon" -> pSimple o + (_ :: String) -> fail "Not a SimplePolygon" + where + pSimple o = fromPoints <$> o .: "vertices" +instance (FromJSON r, Eq r, Num r, FromJSON p) => FromJSON (Polygon Multi p r) where + parseJSON = withObject "Polygon" $ \o -> o .: "tag" >>= \case + "MultiPolygon" -> pMulti o + (_ :: String) -> fail "Not a MultiPolygon" + where + pMulti o = (\vs hs -> MultiPolygon (fromPoints vs) (map fromPoints hs)) + <$> o .: "outerBoundary" <*> o .: "holes" -- * Functions on Polygons -outerBoundary :: forall t p r. Lens' (Polygon t p r) (C.CSeq (Point 2 r :+ p)) +-- | Getter access to the outer boundary vector of a polygon. +-- +-- >>> toList (simpleTriangle ^. outerBoundaryVector) +-- [Point2 0 0 :+ (),Point2 2 0 :+ (),Point2 1 1 :+ ()] +outerBoundaryVector :: forall t p r. Getter (Polygon t p r) (CircularVector (Point 2 r :+ p)) +outerBoundaryVector = to g + where + g :: Polygon t p r -> CircularVector (Point 2 r :+ p) + g (SimplePolygon (Vertices vs)) = vs + g (MultiPolygon (SimplePolygon (Vertices vs)) _) = vs + +-- | Unsafe lens access to the outer boundary vector of a polygon. +-- +-- >>> toList (simpleTriangle ^. unsafeOuterBoundaryVector) +-- [Point2 0 0 :+ (),Point2 2 0 :+ (),Point2 1 1 :+ ()] +-- +-- >>> simpleTriangle & unsafeOuterBoundaryVector .~ CV.singleton (Point2 0 0 :+ ()) +-- SimplePolygon [Point2 0 0 :+ ()] +unsafeOuterBoundaryVector :: forall t p r. Lens' (Polygon t p r) (CircularVector (Point 2 r :+ p)) +unsafeOuterBoundaryVector = lens g s + where + g :: Polygon t p r -> CircularVector (Point 2 r :+ p) + g (SimplePolygon (Vertices vs)) = vs + g (MultiPolygon (SimplePolygon (Vertices vs)) _) = vs + + s :: Polygon t p r -> CircularVector (Point 2 r :+ p) + -> Polygon t p r + s SimplePolygon{} vs = SimplePolygon (Vertices vs) + s (MultiPolygon _ hs) vs = MultiPolygon (SimplePolygon (Vertices vs)) hs + + +-- | \( O(1) \) Lens access to the outer boundary of a polygon. +outerBoundary :: forall t p r. Lens' (Polygon t p r) (SimplePolygon p r) outerBoundary = lens g s where - g :: Polygon t p r -> C.CSeq (Point 2 r :+ p) - g (SimplePolygon vs) = vs - g (MultiPolygon vs _) = vs + g :: Polygon t p r -> SimplePolygon p r + g poly@SimplePolygon{} = poly + g (MultiPolygon simple _) = simple - s :: Polygon t p r -> C.CSeq (Point 2 r :+ p) + s :: Polygon t p r -> SimplePolygon p r -> Polygon t p r - s (SimplePolygon _) vs = SimplePolygon vs - s (MultiPolygon _ hs) vs = MultiPolygon vs hs + s SimplePolygon{} simple = simple + s (MultiPolygon _ hs) simple = MultiPolygon simple hs +-- | Lens access for polygon holes. +-- +-- >>> multiPoly ^. polygonHoles +-- [SimplePolygon [Point2 0 0 :+ (),Point2 2 0 :+ (),Point2 1 1 :+ ()]] polygonHoles :: forall p r. Lens' (Polygon Multi p r) [Polygon Simple p r] polygonHoles = lens g s where @@ -213,16 +333,30 @@ -> Polygon Multi p r s (MultiPolygon vs _) = MultiPolygon vs +{- HLINT ignore polygonHoles' -} +-- | \( O(1) \). Traversal lens for polygon holes. Does nothing for simple polygons. polygonHoles' :: Traversal' (Polygon t p r) [Polygon Simple p r] polygonHoles' = \f -> \case - p@(SimplePolygon _) -> pure p - (MultiPolygon vs hs) -> MultiPolygon vs <$> f hs + p@SimplePolygon{} -> pure p + MultiPolygon vs hs -> MultiPolygon vs <$> f hs --- | Access the i^th vertex on the outer boundary -outerVertex :: Int -> Lens' (Polygon t p r) (Point 2 r :+ p) -outerVertex i = outerBoundary.C.item i +-- | /O(1)/ Access the i^th vertex on the outer boundary. Indices are modulo \(n\). +-- +-- >>> simplePoly ^. outerVertex 0 +-- Point2 0 0 :+ () +outerVertex :: Int -> Getter (Polygon t p r) (Point 2 r :+ p) +outerVertex i = outerBoundaryVector . CV.item i --- running time: \(O(\log i)\) +-- | \( O(1) \) read and \( O(n) \) write. Access the i^th vertex on the outer boundary +-- +-- >>> simplePoly ^. unsafeOuterVertex 0 +-- Point2 0 0 :+ () +-- >>> simplePoly & unsafeOuterVertex 0 .~ (Point2 10 10 :+ ()) +-- SimplePolygon [Point2 10 10 :+ (),Point2 10 0 :+ (),Point2 10 10 :+ (),Point2 5 15 :+ (),Point2 1 11 :+ ()] +unsafeOuterVertex :: Int -> Lens' (Polygon t p r) (Point 2 r :+ p) +unsafeOuterVertex i = unsafeOuterBoundaryVector . CV.item i + +-- | \( O(1) \) Get the n^th edge along the outer boundary of the polygon. The edge is half open. outerBoundaryEdge :: Int -> Polygon t p r -> LineSegment 2 p r outerBoundaryEdge i p = let u = p^.outerVertex i v = p^.outerVertex (i+1) @@ -231,36 +365,116 @@ -- | Get all holes in a polygon holeList :: Polygon t p r -> [Polygon Simple p r] -holeList (SimplePolygon _) = [] +holeList SimplePolygon{} = [] holeList (MultiPolygon _ hs) = hs --- | The vertices in the polygon. No guarantees are given on the order in which +-- | \( O(1) \) Vertex count. Includes the vertices of holes. +size :: Polygon t p r -> Int +size (SimplePolygon (Vertices cv)) = F.length cv +size (MultiPolygon b hs) = sum (map size (b:hs)) + +-- | \( O(n) \) The vertices in the polygon. No guarantees are given on the order in which -- they appear! polygonVertices :: Polygon t p r -> NonEmpty.NonEmpty (Point 2 r :+ p) -polygonVertices (SimplePolygon vs) = toNonEmpty vs +polygonVertices p@SimplePolygon{} = toNonEmpty $ p^.outerBoundaryVector polygonVertices (MultiPolygon vs hs) = - sconcat $ toNonEmpty vs NonEmpty.:| map polygonVertices hs + sconcat $ toNonEmpty (polygonVertices vs) NonEmpty.:| map polygonVertices hs +-- FIXME: Get rid of 'Fractional r' constraint. +-- | \( O(n \log n) \) Check if a polygon has any holes, duplicate points, or +-- self-intersections. +isSimple :: (Ord r, Fractional r) => Polygon p t r -> Bool +isSimple p@SimplePolygon{} = null . BO.interiorIntersections $ listEdges p +isSimple (MultiPolygon b []) = isSimple b +isSimple MultiPolygon{} = False --- | Creates a simple polygon from the given list of vertices. +requireThree :: String -> [a] -> [a] +requireThree _ lst@(_:_:_:_) = lst +requireThree label _ = error $ + "Data.Geometry.Polygon." ++ label ++ ": Polygons must have at least three points." + +-- | \( O(n) \) Creates a polygon from the given list of vertices. -- +-- The points are placed in CCW order if they are not already. Overlapping +-- edges and repeated vertices are allowed. +-- +fromPoints :: forall p r. (Eq r, Num r) => [Point 2 r :+ p] -> SimplePolygon p r +fromPoints = fromCircularVector . CV.unsafeFromList . requireThree "fromPoints" + +-- | \( O(n) \) Creates a polygon from the given vector of vertices. +-- +-- The points are placed in CCW order if they are not already. Overlapping +-- edges and repeated vertices are allowed. +-- +fromCircularVector :: forall p r. (Eq r, Num r) => CircularVector (Point 2 r :+ p) -> SimplePolygon p r +fromCircularVector = toCounterClockWiseOrder . unsafeFromCircularVector + +-- | \( O(n \log n) \) Creates a simple polygon from the given list of vertices. +-- +-- The points are placed in CCW order if they are not already. Overlapping +-- edges and repeated vertices are /not/ allowed and will trigger an exception. +-- +simpleFromPoints :: forall p r. (Ord r, Fractional r) => [Point 2 r :+ p] -> SimplePolygon p r +simpleFromPoints = + simpleFromCircularVector . CV.unsafeFromList . requireThree "simpleFromPoints" + +-- | \( O(n \log n) \) Creates a simple polygon from the given vector of vertices. +-- +-- The points are placed in CCW order if they are not already. Overlapping +-- edges and repeated vertices are /not/ allowed and will trigger an exception. +-- +simpleFromCircularVector :: forall p r. (Ord r, Fractional r) + => CircularVector (Point 2 r :+ p) -> SimplePolygon p r +simpleFromCircularVector v = + let p = fromCircularVector v + hasInteriorIntersections = not . null . BO.interiorIntersections + in if hasInteriorIntersections (listEdges p) + then error "Data.Geometry.Polygon.simpleFromCircularVector: \ + \Found self-intersections or repeated vertices." + else p + +-- | \( O(n) \) Creates a simple polygon from the given list of vertices. +-- -- pre: the input list constains no repeated vertices. -fromPoints :: [Point 2 r :+ p] -> SimplePolygon p r -fromPoints = SimplePolygon . C.fromList +unsafeFromPoints :: [Point 2 r :+ p] -> SimplePolygon p r +unsafeFromPoints = unsafeFromCircularVector . CV.unsafeFromList +-- | \( O(1) \) Creates a simple polygon from the given vector of vertices. +-- +-- pre: the input list constains no repeated vertices. +unsafeFromCircularVector :: CircularVector (Point 2 r :+ p) -> SimplePolygon p r +unsafeFromCircularVector = SimplePolygon . Vertices --- | The edges along the outer boundary of the polygon. The edges are half open. +-- | \( O(1) \) Creates a simple polygon from the given vector of vertices. -- --- running time: \(O(n)\) -outerBoundaryEdges :: Polygon t p r -> C.CSeq (LineSegment 2 p r) -outerBoundaryEdges = toEdges . (^.outerBoundary) +-- pre: the input list constains no repeated vertices. +unsafeFromVector :: Vector (Point 2 r :+ p) -> SimplePolygon p r +unsafeFromVector = unsafeFromCircularVector . CV.unsafeFromVector --- | Lists all edges. The edges on the outer boundary are given before the ones +-- -- | Polygon points, from left to right. +-- toList :: Polygon t p r -> [Point 2 r :+ p] +-- toList (SimplePolygon c) = F.toList c +-- toList (MultiPolygon s hs) = toList s ++ concatMap toList hs + +-- | \( O(n) \) +-- Polygon points, from left to right. +toVector :: Polygon t p r -> Vector (Point 2 r :+ p) +toVector p@SimplePolygon{} = CV.toVector $ p^.outerBoundaryVector +toVector (MultiPolygon s hs) = foldr (<>) (toVector s) (map toVector hs) + +-- | \( O(n) \) +-- Polygon points, from left to right. +toPoints :: Polygon t p r -> [Point 2 r :+ p] +toPoints = V.toList . toVector + +-- | \( O(n) \) The edges along the outer boundary of the polygon. The edges are half open. +outerBoundaryEdges :: Polygon t p r -> CircularVector (LineSegment 2 p r) +outerBoundaryEdges = toEdges . (^.outerBoundaryVector) + +-- | \( O(n) \) Lists all edges. The edges on the outer boundary are given before the ones -- on the holes. However, no other guarantees are given on the order. --- --- running time: \(O(n)\) listEdges :: Polygon t p r -> [LineSegment 2 p r] listEdges pg = let f = F.toList . outerBoundaryEdges in f pg <> concatMap f (holeList pg) @@ -271,20 +485,21 @@ -- -- -- >>> mapM_ print . polygonVertices $ withIncidentEdges simplePoly --- Point2 [0,0] :+ V2 LineSegment (Closed (Point2 [1,11] :+ ())) (Closed (Point2 [0,0] :+ ())) LineSegment (Closed (Point2 [0,0] :+ ())) (Closed (Point2 [10,0] :+ ())) --- Point2 [10,0] :+ V2 LineSegment (Closed (Point2 [0,0] :+ ())) (Closed (Point2 [10,0] :+ ())) LineSegment (Closed (Point2 [10,0] :+ ())) (Closed (Point2 [10,10] :+ ())) --- Point2 [10,10] :+ V2 LineSegment (Closed (Point2 [10,0] :+ ())) (Closed (Point2 [10,10] :+ ())) LineSegment (Closed (Point2 [10,10] :+ ())) (Closed (Point2 [5,15] :+ ())) --- Point2 [5,15] :+ V2 LineSegment (Closed (Point2 [10,10] :+ ())) (Closed (Point2 [5,15] :+ ())) LineSegment (Closed (Point2 [5,15] :+ ())) (Closed (Point2 [1,11] :+ ())) --- Point2 [1,11] :+ V2 LineSegment (Closed (Point2 [5,15] :+ ())) (Closed (Point2 [1,11] :+ ())) LineSegment (Closed (Point2 [1,11] :+ ())) (Closed (Point2 [0,0] :+ ())) +-- Point2 0 0 :+ V2 (ClosedLineSegment (Point2 1 11 :+ ()) (Point2 0 0 :+ ())) (ClosedLineSegment (Point2 0 0 :+ ()) (Point2 10 0 :+ ())) +-- Point2 10 0 :+ V2 (ClosedLineSegment (Point2 0 0 :+ ()) (Point2 10 0 :+ ())) (ClosedLineSegment (Point2 10 0 :+ ()) (Point2 10 10 :+ ())) +-- Point2 10 10 :+ V2 (ClosedLineSegment (Point2 10 0 :+ ()) (Point2 10 10 :+ ())) (ClosedLineSegment (Point2 10 10 :+ ()) (Point2 5 15 :+ ())) +-- Point2 5 15 :+ V2 (ClosedLineSegment (Point2 10 10 :+ ()) (Point2 5 15 :+ ())) (ClosedLineSegment (Point2 5 15 :+ ()) (Point2 1 11 :+ ())) +-- Point2 1 11 :+ V2 (ClosedLineSegment (Point2 5 15 :+ ()) (Point2 1 11 :+ ())) (ClosedLineSegment (Point2 1 11 :+ ()) (Point2 0 0 :+ ())) 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) +withIncidentEdges poly@SimplePolygon{} = + unsafeFromCircularVector $ CV.zipWith3 f (CV.rotateLeft 1 vs) vs (CV.rotateRight 1 vs) where + vs = poly ^. outerBoundaryVector f p c n = c&extra .~ Two (ClosedLineSegment p c) (ClosedLineSegment c n) withIncidentEdges (MultiPolygon vs hs) = MultiPolygon vs' hs' where - (SimplePolygon vs') = withIncidentEdges $ SimplePolygon vs + vs' = withIncidentEdges vs hs' = map withIncidentEdges hs -- -- | Gets the i^th edge on the outer boundary of the polygon, that is the edge @@ -292,143 +507,33 @@ -- -- modulo n. -- -- +-- FIXME: Test that \poly -> fromEdges (toEdges poly) == poly -- | Given the vertices of the polygon. Produce a list of edges. The edges are -- half-open. -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) - -- let vs' = F.toList vs in - -- C.fromList $ zipWith (\p q -> LineSegment (Closed p) (Open q)) vs' (tail vs' ++ vs') - - --- | Test if q lies on the boundary of the polygon. Running time: O(n) --- --- >>> Point2 1 1 `onBoundary` simplePoly --- False --- >>> Point2 0 0 `onBoundary` simplePoly --- True --- >>> Point2 10 0 `onBoundary` simplePoly --- True --- >>> Point2 5 13 `onBoundary` simplePoly --- False --- >>> Point2 5 10 `onBoundary` simplePoly --- False --- >>> Point2 10 5 `onBoundary` simplePoly --- True --- >>> Point2 20 5 `onBoundary` simplePoly --- False --- --- TODO: testcases multipolygon -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 - --- | Check if a point lies inside a polygon, on the boundary, or outside of the polygon. --- Running time: O(n). --- --- >>> Point2 1 1 `inPolygon` simplePoly --- Inside --- >>> Point2 0 0 `inPolygon` simplePoly --- OnBoundary --- >>> Point2 10 0 `inPolygon` simplePoly --- OnBoundary --- >>> Point2 5 13 `inPolygon` simplePoly --- Inside --- >>> Point2 5 10 `inPolygon` simplePoly --- Inside --- >>> Point2 10 5 `inPolygon` simplePoly --- OnBoundary --- >>> Point2 20 5 `inPolygon` simplePoly --- Outside --- --- TODO: Add some testcases with multiPolygons --- TODO: Add some more onBoundary testcases -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 - - -- Given a line segment, compute the intersection point (if a point) with the - -- line l - intersectionPoint = asA @(Point 2 r) . (`intersect` l) - - -- Count the number of intersections that the horizontal line through q - -- maxes with the polygon, that are strictly to the left and strictly to - -- the right of q. If these numbers are both odd the point lies within the polygon. - -- - -- - -- note that: - by the asA (Point 2 r) we ignore horizontal segments (as desired) - -- - by the filtering, we effectively limit l to an open-half line, starting - -- at the (open) point q. - -- - by using half-open segments as edges we avoid double counting - -- intersections that coincide with vertices. - -- - If the point is outside, and on the same height as the - -- minimum or maximum coordinate of the polygon. The number of - -- intersections to the left or right may be one. Thus - -- incorrectly classifying the point as inside. To avoid this, - -- we count both the points to the left *and* to the right of - -- p. Only if both are odd the point is inside. so that if - -- the point is outside, and on the same y-coordinate as one - -- of the extermal vertices (one ofth) - -- - -- See http://geomalgorithms.com/a03-_inclusion.html for more information. - SP kl kr = count (\p -> (p^.xCoord) `compare` (q^.xCoord)) - . mapMaybe intersectionPoint . F.toList . outerBoundaryEdges $ pg - - -- For multi polygons we have to test if we do not lie in a hole . - 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) - - --- | Test if a point lies strictly inside the polgyon. -insidePolygon :: (Fractional r, Ord r) => Point 2 r -> Polygon t p r -> Bool -q `insidePolygon` pg = q `inPolygon` pg == Inside - - --- testQ = map (`inPolygon` testPoly) [ Point2 1 1 -- Inside --- , Point2 0 0 -- OnBoundary --- , Point2 5 14 -- Inside --- , Point2 5 10 -- Inside --- , Point2 10 5 -- OnBoundary --- , Point2 20 5 -- Outside --- ] - --- testPoly :: SimplePolygon () Rational --- testPoly = SimplePolygon . C.fromList . map ext $ [ Point2 0 0 --- , Point2 10 0 --- , Point2 10 10 --- , Point2 5 15 --- , Point2 1 11 --- ] +toEdges :: CircularVector (Point 2 r :+ p) -> CircularVector (LineSegment 2 p r) +toEdges vs = CV.zipWith (\p q -> LineSegment (Closed p) (Open q)) vs (CV.rotateRight 1 vs) -- | Compute the area of a polygon 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] +area poly@SimplePolygon{} = abs $ signedArea poly +area (MultiPolygon vs hs) = area vs - sum [area h | h <- hs] -- | Compute the signed area of a simple polygon. The the vertices are in -- clockwise order, the signed area will be negative, if the verices are given -- in counter clockwise order, the area will be positive. signedArea :: Fractional r => SimplePolygon p r -> r -signedArea poly = x / 2 +signedArea poly = signedArea2X poly / 2 + +-- | Compute the signed area times 2 of a simple polygon. The the vertices are in +-- clockwise order, the signed area will be negative, if the verices are given +-- in counter clockwise order, the area will be positive. +signedArea2X :: Num r => SimplePolygon p r -> r +signedArea2X poly = x where x = sum [ p^.core.xCoord * q^.core.yCoord - q^.core.xCoord * p^.core.yCoord | LineSegment' p q <- F.toList $ outerBoundaryEdges poly ] - -- | Compute the centroid of a simple polygon. centroid :: Fractional r => SimplePolygon p r -> Point 2 r centroid poly = Point $ sum' xs ^/ (6 * signedArea poly) @@ -439,43 +544,33 @@ sum' = F.foldl' (^+^) zero --- | Pick a point that is inside the polygon. +-- | \( O(n) \) Pick a point that is inside the polygon. -- -- (note: if the polygon is degenerate; i.e. has <3 vertices, we report a -- vertex of the polygon instead.) -- -- pre: the polygon is given in CCW order --- --- running time: \(O(n)\) pickPoint :: (Ord r, Fractional r) => Polygon p t r -> Point 2 r -pickPoint pg | isTriangle pg = centroid . SimplePolygon $ pg^.outerBoundary +pickPoint pg | isTriangle pg = centroid $ pg^.outerBoundary | otherwise = let LineSegment' (p :+ _) (q :+ _) = findDiagonal pg in p .+^ (0.5 *^ (q .-. p)) --- | Test if the polygon is a triangle --- --- running time: \(O(1)\) +-- | \( O(1) \) Test if the polygon is a triangle isTriangle :: Polygon p t r -> Bool isTriangle = \case - SimplePolygon vs -> go vs - MultiPolygon vs [] -> go vs + p@SimplePolygon{} -> F.length (p^.outerBoundaryVector) == 3 + MultiPolygon vs [] -> isTriangle vs MultiPolygon _ _ -> False - where - go vs = case toNonEmpty vs of - (_ :| [_,_]) -> True - _ -> False --- | Find a diagonal of the polygon. +-- | \( O(n) \) Find a diagonal of the polygon. -- -- pre: the polygon is given in CCW order --- --- running time: \(O(n)\) findDiagonal :: (Ord r, Fractional r) => Polygon t p r -> LineSegment 2 p r findDiagonal pg = List.head . catMaybes . F.toList $ diags -- note that a diagonal is guaranteed to exist, so the usage of head is safe. where - vs = pg^.outerBoundary - diags = C.zip3LWith f (C.rotateL vs) vs (C.rotateR vs) + vs = pg^.outerBoundaryVector + diags = CV.zipWith3 f (CV.rotateLeft 1 vs) vs (CV.rotateRight 1 vs) f u v w = case ccw (u^.core) (v^.core) (w^.core) of CCW -> Just $ findDiag u v w -- v is a convex vertex, so find a diagonal @@ -508,59 +603,48 @@ xs -> Just $ List.maximumBy (comparing f) xs --- | Test if the outer boundary of the polygon is in clockwise or counter +-- | \( O(n) \) Test if the outer boundary of the polygon is in clockwise or counter -- clockwise order. --- --- running time: \(O(n)\) --- -isCounterClockwise :: (Eq r, Fractional r) => Polygon t p r -> Bool -isCounterClockwise = (\x -> x == abs x) . signedArea - . fromPoints . F.toList . (^.outerBoundary) +isCounterClockwise :: (Eq r, Num r) => Polygon t p r -> Bool +isCounterClockwise = (\x -> x == abs x) . signedArea2X . view outerBoundary --- | Make sure that every edge has the polygon's interior on its +-- | \( O(n) \) Make sure that every edge has the polygon's interior on its -- right, by orienting the outer boundary into clockwise order, and -- the inner borders (i.e. any holes, if they exist) into -- counter-clockwise order. --- --- running time: \(O(n)\) --- | Orient the outer boundary of the polygon to clockwise order -toClockwiseOrder :: (Eq r, Fractional r) => Polygon t p r -> Polygon t p r -toClockwiseOrder p = (toClockwiseOrder' p)&polygonHoles'.traverse %~ toCounterClockWiseOrder' +toClockwiseOrder :: (Eq r, Num r) => Polygon t p r -> Polygon t p r +toClockwiseOrder p = toClockwiseOrder' p & polygonHoles'.traverse %~ toCounterClockWiseOrder' --- | Orient the outer boundary into clockwise order. Leaves any holes +-- | \( O(n) \) Orient the outer boundary into clockwise order. Leaves any holes -- as they are. -- -toClockwiseOrder' :: (Eq r, Fractional r) => Polygon t p r -> Polygon t p r +toClockwiseOrder' :: (Eq r, Num r) => Polygon t p r -> Polygon t p r toClockwiseOrder' pg | isCounterClockwise pg = reverseOuterBoundary pg | otherwise = pg --- | Make sure that every edge has the polygon's interior on its left, +-- | \( O(n) \) Make sure that every edge has the polygon's interior on its left, -- by orienting the outer boundary into counter-clockwise order, and -- the inner borders (i.e. any holes, if they exist) into clockwise order. --- --- running time: \(O(n)\) -toCounterClockWiseOrder :: (Eq r, Fractional r) => Polygon t p r -> Polygon t p r +toCounterClockWiseOrder :: (Eq r, Num r) => Polygon t p r -> Polygon t p r toCounterClockWiseOrder p = - (toCounterClockWiseOrder' p)&polygonHoles'.traverse %~ toClockwiseOrder' + toCounterClockWiseOrder' p & polygonHoles'.traverse %~ toClockwiseOrder' --- | Orient the outer boundary into counter-clockwise order. Leaves +-- | \( O(n) \) Orient the outer boundary into counter-clockwise order. Leaves -- any holes as they are. --- -toCounterClockWiseOrder' :: (Eq r, Fractional r) => Polygon t p r -> Polygon t p r +toCounterClockWiseOrder' :: (Eq r, Num r) => Polygon t p r -> Polygon t p r toCounterClockWiseOrder' p | not $ isCounterClockwise p = reverseOuterBoundary p | otherwise = p +-- FIXME: Delete this function. +-- | Reorient the outer boundary from clockwise order to counter-clockwise order or +-- from counter-clockwise order to clockwise order. Leaves +-- any holes as they are. +-- reverseOuterBoundary :: Polygon t p r -> Polygon t p r -reverseOuterBoundary p = p&outerBoundary %~ C.reverseDirection - - --- | Convert a Polygon to a simple polygon by forgetting about any holes. -asSimplePolygon :: Polygon t p r -> SimplePolygon p r -asSimplePolygon poly@(SimplePolygon _) = poly -asSimplePolygon (MultiPolygon vs _) = SimplePolygon vs +reverseOuterBoundary p = p&unsafeOuterBoundaryVector %~ CV.reverse -- | assigns unique integer numbers to all vertices. Numbers start from 0, and @@ -568,7 +652,164 @@ -- will be numbered last, in the same order. -- -- >>> numberVertices simplePoly --- SimplePolygon (CSeq [Point2 [0,0] :+ SP 0 (),Point2 [10,0] :+ SP 1 (),Point2 [10,10] :+ SP 2 (),Point2 [5,15] :+ SP 3 (),Point2 [1,11] :+ SP 4 ()]) +-- SimplePolygon [Point2 0 0 :+ SP 0 (),Point2 10 0 :+ SP 1 (),Point2 10 10 :+ SP 2 (),Point2 5 15 :+ SP 3 (),Point2 1 11 :+ SP 4 ()] 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 +numberVertices = snd . bimapAccumL (\a p -> (a+1,SP a p)) (,) 0 -- TODO: Make sure that this does not have the same issues as foldl vs foldl' + +-------------------------------------------------------------------------------- +-- Specialized folds + +-- maximum and minimum probably aren't useful. Disabled for now. Lemmih, 2020-12-26. + +-- | \( O(n) \) Yield the maximum point of the polygon. Points are compared first by x-coordinate +-- and then by y-coordinate. The maximum point will therefore be the right-most point in +-- the polygon (and top-most if multiple points share the largest x-coordinate). +-- +-- Hole vertices are ignored since they cannot be the maximum. +_maximum :: Ord r => Polygon t p r -> Point 2 r :+ p +_maximum = F.maximumBy (comparing _core) . view outerBoundaryVector + +-- | \( O(n) \) Yield the maximum point of a polygon according to the given comparison function. +maximumVertexBy :: (Point 2 r :+ p -> Point 2 r :+ p -> Ordering) -> Polygon t p r -> Point 2 r :+ p +maximumVertexBy fn (SimplePolygon vs) = F.maximumBy fn vs +maximumVertexBy fn (MultiPolygon b hs) = F.maximumBy fn $ map (maximumVertexBy fn) (b:hs) + +-- | \( O(n) \) Yield the maximum point of the polygon. Points are compared first by x-coordinate +-- and then by y-coordinate. The minimum point will therefore be the left-most point in +-- the polygon (and bottom-most if multiple points share the smallest x-coordinate). +-- +-- Hole vertices are ignored since they cannot be the minimum. +_minimum :: Ord r => Polygon t p r -> Point 2 r :+ p +_minimum = F.minimumBy (comparing _core) . view outerBoundaryVector + +-- | \( O(n) \) Yield the maximum point of a polygon according to the given comparison function. +minimumVertexBy :: (Point 2 r :+ p -> Point 2 r :+ p -> Ordering) -> Polygon t p r -> Point 2 r :+ p +minimumVertexBy fn (SimplePolygon vs) = F.minimumBy fn vs +minimumVertexBy fn (MultiPolygon b hs) = F.minimumBy fn $ map (minimumVertexBy fn) (b:hs) + +-- | Rotate to the first point that matches the given condition. +-- +-- >>> toVector <$> findRotateTo (== (Point2 1 0 :+ ())) (unsafeFromPoints [Point2 0 0 :+ (), Point2 1 0 :+ (), Point2 1 1 :+ ()]) +-- Just [Point2 1 0 :+ (),Point2 1 1 :+ (),Point2 0 0 :+ ()] +-- >>> findRotateTo (== (Point2 7 0 :+ ())) $ unsafeFromPoints [Point2 0 0 :+ (), Point2 1 0 :+ (), Point2 1 1 :+ ()] +-- Nothing +findRotateTo :: (Point 2 r :+ p -> Bool) -> SimplePolygon p r -> Maybe (SimplePolygon p r) +findRotateTo fn = fmap unsafeFromCircularVector . CV.findRotateTo fn . view outerBoundaryVector + +-------------------------------------------------------------------------------- +-- Rotation + +-- | \( O(1) \) Rotate the polygon to the left by n number of points. +rotateLeft :: Int -> SimplePolygon p r -> SimplePolygon p r +rotateLeft n = over unsafeOuterBoundaryVector (CV.rotateLeft n) + +-- | \( O(1) \) Rotate the polygon to the right by n number of points. +rotateRight :: Int -> SimplePolygon p r -> SimplePolygon p r +rotateRight n = over unsafeOuterBoundaryVector (CV.rotateRight n) + +-------------------------------------------------------------------------------- +-- Testing for reflex or convex + +-- | Test if a given vertex is a reflex vertex. +-- +-- \(O(1)\) +isReflexVertex :: (Ord r, Num r) => Int -> Polygon Simple p r -> Bool +isReflexVertex i pg = ccw' u v w == CW + where + u = pg^.outerVertex (i-1) + v = pg^.outerVertex i + w = pg^.outerVertex (i+1) + +-- | Test if a given vertex is a convex vertex (i.e. not a reflex vertex). +-- +-- \(O(1)\) +isConvexVertex :: (Ord r, Num r) => Int -> Polygon Simple p r -> Bool +isConvexVertex i = not . isReflexVertex i + +-- | Test if a given vertex is a strictly convex vertex. +-- +-- \(O(1)\) +isStrictlyConvexVertex :: (Ord r, Num r) => Int -> Polygon t p r -> Bool +isStrictlyConvexVertex i pg = ccw' u v w == CCW + where + u = pg^.outerVertex (i-1) + v = pg^.outerVertex i + w = pg^.outerVertex (i+1) + + +-- | Computes all reflex vertices of the polygon. +-- +-- \(O(n)\) +reflexVertices :: (Ord r, Num r) => Polygon t p r -> [Int :+ (Point 2 r :+ p)] +reflexVertices p@(SimplePolygon _) = reflexVertices' p +reflexVertices (numberVertices -> MultiPolygon vs hs) = + map (\(_ :+ (p :+ SP i e)) -> i :+ (p :+ e)) $ + reflexVertices' vs <> concatMap strictlyConvexVertices' hs + +-- | Computes all convex (i.e. non-reflex) vertices of the polygon. +-- +-- \(O(n)\) +convexVertices :: (Ord r, Num r) => Polygon t p r -> [Int :+ (Point 2 r :+ p)] +convexVertices = \case + p@(SimplePolygon _) -> convexVertices' p + (numberVertices -> MultiPolygon vs hs) -> + map (\(_ :+ (p :+ SP i e)) -> i :+ (p :+ e)) $ + convexVertices' vs <> concatMap reflexVertices' hs + +-- | Computes all strictly convex vertices of the polygon. +-- +-- \(O(n)\) +strictlyConvexVertices :: (Ord r, Num r) => Polygon t p r -> [Int :+ (Point 2 r :+ p)] +strictlyConvexVertices = \case + p@(SimplePolygon _) -> convexVertices' p + (numberVertices -> MultiPolygon vs hs) -> + map (\(_ :+ (p :+ SP i e)) -> i :+ (p :+ e)) $ + strictlyConvexVertices' vs <> concatMap reflexVertices' hs + +---------------------------------------- + +-- | Return (the indices of) all reflex vertices, in increasing order +-- along the boundary. +-- +-- \(O(n)\) +reflexVertices' :: (Ord r, Num r) => SimplePolygon p r -> [Int :+ (Point 2 r :+ p)] +reflexVertices' = filterReflexConvexWorker asReflex + where + asReflex u v w | ccw' (u^.extra) (v^.extra) (w^.extra) == CW = Just v + | otherwise = Nothing + +-- | Return (the indices of) all strictly convex vertices, in +-- increasing order along the boundary. +-- +-- \(O(n)\) +strictlyConvexVertices' :: (Ord r, Num r) => SimplePolygon p r -> [Int :+ (Point 2 r :+ p)] +strictlyConvexVertices' = filterReflexConvexWorker asStrictlyConvex + where + asStrictlyConvex u v w | ccw' (u^.extra) (v^.extra) (w^.extra) == CCW = Just v + | otherwise = Nothing + +-- | Return (the indices of) all convex (= non-reflex) vertices, in increasing order +-- along the boundary. +-- +-- \(O(n)\) +convexVertices' :: (Ord r, Num r) => SimplePolygon p r -> [Int :+ (Point 2 r :+ p)] +convexVertices' = filterReflexConvexWorker asConvex + where + asConvex u v w | ccw' (u^.extra) (v^.extra) (w^.extra) /= CW = Just v + | otherwise = Nothing + +-- | Helper function to implement convexVertices, reflexVertices, and +-- strictlyConvexVertices +filterReflexConvexWorker :: (Ord r, Num r) + => ( Int :+ (Point 2 r :+ p) + -> Int :+ (Point 2 r :+ p) + -> Int :+ (Point 2 r :+ p) + -> Maybe (Int :+ (Point 2 r :+ p)) + ) + -> SimplePolygon p r -> [Int :+ (Point 2 r :+ p)] +filterReflexConvexWorker g pg = + catMaybes $ zip3RWith g (CV.rotateLeft 1 vs) vs (CV.rotateRight 1 vs) + where + vs = CV.withIndicesRight $ pg^.outerBoundaryVector + zip3RWith f us' vs' ws' = zipWith3 f (F.toList us') (F.toList vs') (F.toList ws') diff --git a/src/Data/Geometry/Polygon/Extremes.hs b/src/Data/Geometry/Polygon/Extremes.hs --- a/src/Data/Geometry/Polygon/Extremes.hs +++ b/src/Data/Geometry/Polygon/Extremes.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE TemplateHaskell #-} -------------------------------------------------------------------------------- -- | -- Module : Data.Geometry.Polygon.Extremes @@ -13,15 +12,15 @@ , extremesLinear ) where -import Control.Lens hiding (Simple) +import Control.Lens hiding (Simple,simple) import Data.Ext -import qualified Data.Foldable as F import Data.Geometry.Point -import Data.Geometry.Polygon.Core +import Data.Geometry.Polygon.Core as P import Data.Geometry.Vector -------------------------------------------------------------------------------- +{- HLINT ignore cmpExtreme -} -- | Comparison that compares which point is 'larger' in the direction given by -- the vector u. cmpExtreme :: (Num r, Ord r) @@ -34,6 +33,6 @@ -- running time: \(O(n)\) 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 +extremesLinear u p = let simple = p^.outerBoundary f = cmpExtreme u - in (F.minimumBy f vs, F.maximumBy f vs) + in (P.minimumVertexBy f simple, P.maximumVertexBy f simple) diff --git a/src/Data/Geometry/Polygon/Inflate.hs b/src/Data/Geometry/Polygon/Inflate.hs new file mode 100644 --- /dev/null +++ b/src/Data/Geometry/Polygon/Inflate.hs @@ -0,0 +1,142 @@ +-------------------------------------------------------------------------------- +-- | +-- Module : Data.Geometry.Polygon.Inflate +-- Copyright : (C) David Himmelstrup +-- License : see the LICENSE file +-- Maintainer : David Himmelstrup +-------------------------------------------------------------------------------- +module Data.Geometry.Polygon.Inflate + ( Arc(..) + , inflate + ) where + +import Algorithms.Geometry.SSSP (SSSP, sssp, triangulate) +import Control.Lens +import Data.Ext +import Data.Geometry.Line (lineThrough) +import Data.Geometry.LineSegment (LineSegment (LineSegment, OpenLineSegment), + interpolate, sqSegmentLength) +import Data.Geometry.Point +import Data.Geometry.Polygon.Core +import Data.Intersection (IsIntersectableWith (intersect), + NoIntersection (NoIntersection)) +import Data.Maybe (catMaybes) +import qualified Data.Vector as V +import qualified Data.Vector.Circular as CV +import qualified Data.Vector.Unboxed as VU +import Data.Vinyl (Rec (RNil, (:&))) +import Data.Vinyl.CoRec (Handler (H), match) + +---------------------------------------------------- +-- Implementation + +-- | Points annotated with an 'Arc' indicate that the edge from this point to +-- the next should not be a straight line but instead an arc with a given center +-- and a given border edge. +data Arc r = Arc + { arcCenter :: Point 2 r + , arcEdge :: (Point 2 r, Point 2 r) + } deriving (Show) + +type Parent = Int + +markParents :: SSSP -> SimplePolygon p r -> SimplePolygon Parent r +markParents t p = unsafeFromCircularVector $ + CV.imap (\i (pt :+ _) -> pt :+ t VU.! i) (p^.outerBoundaryVector) + +addSteinerPoints :: (Ord r, Fractional r) => SimplePolygon Parent r -> SimplePolygon Parent r +addSteinerPoints p = fromPoints $ concatMap worker [0 .. size p - 1] + where + worker nth = do + pointA : catMaybes [ (:+ parent nth) <$> getIntersection edge lineA + , (:+ parent (nth+1)) <$> getIntersection edge lineB ] + where + fetch idx = p ^. outerVertex idx + pointA = fetch nth + pointB = fetch (nth+1) + parent idx = p^.outerVertex idx.extra + lineA = lineThrough + (fetch (parent nth) ^. core) + (fetch (parent (parent nth)) ^. core) + lineB = lineThrough + (fetch (parent (nth+1)) ^. core) + (fetch (parent (parent (nth+1))) ^. core) + edge = OpenLineSegment pointA pointB + getIntersection segment line = + match (segment `intersect` line) ( + H (\NoIntersection -> Nothing) + :& H (\pt -> Just pt) + :& H (\LineSegment{} -> Nothing) + :& RNil + ) + +annotate :: (Real r, Fractional r) => + Double -> SimplePolygon Parent r -> SimplePolygon Parent r -> SimplePolygon (Arc r) r +annotate t original p = unsafeFromCircularVector $ + CV.imap ann (p^.outerBoundaryVector) + -- CV.generate (size p) ann -- Use this when circular-vector-0.1.2 is out. + where + nO = size original + visibleDist = V.maximum distanceTreeSum * t + parent idx = p^.outerVertex idx.extra + parentO idx = original^.outerVertex idx.extra + getLineO idx = OpenLineSegment (original ^. outerVertex (parentO idx)) (original ^. outerVertex idx) + getLineP idx = OpenLineSegment (original ^. outerVertex (parent idx)) (p ^. outerVertex idx) + + ann i _ = + ptLocation i :+ arc + where + start = p ^. outerVertex i . core + end = p ^. outerVertex (i+1) . core + arc = Arc + { arcCenter = + original ^. outerVertex (commonParent original (parent i) (parent (i+1))) . core + , arcEdge = (start, end) } + + -- Array of locations for points in the original polygon. + ptLocationsO = V.generate nO ptLocationO + ptLocationO 0 = (original ^. outerVertex 0 . core) + ptLocationO i + | frac <= 0 = ptLocationsO V.! (parentO i) + | frac >= 1 = (original ^. outerVertex i . core) + | otherwise = (interpolate frac (getLineO i)) + where + dParent = distanceTreeSum V.! parentO i + dSelf = oDistance VU.! i + frac = realToFrac ((visibleDist - dParent) / dSelf) + + -- Locations for original points and steiner points. + ptLocation 0 = (p ^. outerVertex 0 . core) + ptLocation i + | frac <= 0 = ptLocationsO V.! (parent i) + | frac >= 1 = (p ^. outerVertex i . core) + | otherwise = (interpolate frac (getLineP i)) + where + dParent = distanceTreeSum V.! parent i + dSelf = sqrt $ realToFrac $ sqSegmentLength $ getLineP i + frac = realToFrac ((visibleDist - dParent) / dSelf) + + oDistance = VU.generate nO $ \i -> + case i of + 0 -> 0 + _ -> sqrt $ realToFrac $ sqSegmentLength $ getLineO i + distanceTreeSum = V.generate nO $ \i -> + case i of + 0 -> 0 + _ -> distanceTreeSum V.! parentO i + oDistance VU.! i + +commonParent :: SimplePolygon Parent r -> Int -> Int -> Int +commonParent p a b = worker 0 (parents a) (parents b) + where + worker _shared (x:xs) (y:ys) + | x == y = worker x xs ys + worker shared _ _ = shared + parents 0 = [0] + parents i = parents (p ^. outerVertex i . extra) ++ [i] + +-- | \( O(n \log n) \) +inflate :: (Real r, Fractional r) => Double -> SimplePolygon () r -> SimplePolygon (Arc r) r +inflate t p = annotate t marked steiner + where + marked = markParents (sssp (triangulate p)) p + steiner = addSteinerPoints marked diff --git a/src/Data/Geometry/Polygon/Monotone.hs b/src/Data/Geometry/Polygon/Monotone.hs new file mode 100644 --- /dev/null +++ b/src/Data/Geometry/Polygon/Monotone.hs @@ -0,0 +1,118 @@ +-------------------------------------------------------------------------------- +-- | +-- Module : Data.Geometry.Polygon.Monotone +-- Copyright : (C) 1ndy +-- License : see the LICENSE file +-- Maintainer : David Himmelstrup +-- +-- A polygon is monotone in a certain direction if rays orthogonal to that +-- direction intersects the polygon at most twice. See +-- +-- +-------------------------------------------------------------------------------- +module Data.Geometry.Polygon.Monotone + ( isMonotone + , randomMonotone + , randomMonotoneDirected + , monotoneFrom + , randomNonZeroVector + ) where + +import Control.Monad.Random +import Data.Ext +import qualified Data.Foldable as F +import Data.Geometry.Line (Line (..)) +import Data.Geometry.LineSegment +import Data.Geometry.Point +import Data.Geometry.Polygon.Core +import Data.Geometry.Polygon.Extremes +import Data.Geometry.Vector +import Data.Intersection +import Data.List +import Data.Vinyl +import Data.Vinyl.CoRec +import Prelude hiding (max, min) + +-- | \( O(n \log n) \) +-- A polygon is monotone if a straight line in a given direction +-- cannot have more than two intersections. +isMonotone :: (Fractional r, Ord r) => Vector 2 r -> SimplePolygon p r -> Bool +-- Check for each vertex that the number of intersections with the +-- line starting at the vertex and going out in the given direction +-- intersects with the edges of the polygon no more than 2 times. +isMonotone direction p = all isMonotoneAt (map _core $ toPoints p) + where + isMonotoneAt pt = + sum (map (intersectionsThrough pt) (F.toList $ outerBoundaryEdges p)) <= 2 + intersectionsThrough pt edge = + match (Data.Intersection.intersect edge line) $ + H (\NoIntersection -> 0) + :& H (\Point{} -> 1) + -- This happens when an edge is parallel with the given direction. + -- I think it's correct to count it as a single intersection. + :& H (\LineSegment{} -> 1) + :& RNil + where + line = Line pt (rot90 direction) + rot90 (Vector2 x y) = Vector2 (-y) x + +{- Algorithm overview: + + 1. Create N `Point 2 Rational` (N >= 3) + 2. Create a random `Vector 2 Rational` + 3. Find the extremes (min and max) of the points when sorted in the direction of the vector. + We already have code for this. See `maximumBy (cmpExtreme vector)` and + `minimumBy (cmpExtreme vector)`. + 4. Take out the two extremal points from the set. + 5. Partition the remaining points according to whether they're on the left side or right side + of the imaginary line between the two extremal points. + 6. Sort the two partitioned sets, one in the direction of the vector and one in the opposite + direction. + 7. Connect the points, starting from the minimal extreme point, going through the set of points + that are increasing in the direction of the vector, then to the maximal point, and finally + down through the points that are decreasing in the direction of the vector. +-} +-- | \( O(n \log n) \) +-- Generate a random N-sided polygon that is monotone in a random direction. +randomMonotone :: (RandomGen g, Random r, Ord r, Num r) => Int -> Rand g (SimplePolygon () r) +randomMonotone nVertices = randomMonotoneDirected nVertices =<< randomNonZeroVector + +-- Pick a random vector and then call 'randomMonotone'. +-- | \( O(n \log n) \) +-- Generate a random N-sided polygon that is monotone in the given direction. +randomMonotoneDirected :: (RandomGen g, Random r, Ord r, Num r) + => Int -> Vector 2 r -> Rand g (SimplePolygon () r) +randomMonotoneDirected nVertices direction = do + points <- replicateM nVertices getRandom + return (monotoneFrom direction points) + +-- | \( O(n \log n) \) +-- Assemble a given set of points in a polygon that is monotone in the given direction. +monotoneFrom :: (Ord r, Num r) => Vector 2 r -> [Point 2 r] -> SimplePolygon () r +monotoneFrom direction vertices = fromPoints ([min] ++ rightHalf ++ [max] ++ leftHalf) + where + specialPoints = map (\x -> x :+ ()) vertices + min = Data.List.minimumBy (cmpExtreme direction) specialPoints + max = Data.List.maximumBy (cmpExtreme direction) specialPoints + -- 4 + pointsWithoutExtremes = filter (\x -> x /= min && x /= max) specialPoints + -- 5, 6 + (leftHalfUnsorted,rightHalfUnsorted) = Data.List.partition (toTheLeft min max) pointsWithoutExtremes + leftHalf = sortBy (flip $ cmpExtreme direction) leftHalfUnsorted + rightHalf = sortBy (cmpExtreme direction) rightHalfUnsorted + +------------------------------------------------------------------------------------------------- +-- helper functions + +-- for partitioning points +toTheLeft :: (Ord r, Num r) => Point 2 r :+ () -> Point 2 r :+ () -> Point 2 r :+ () -> Bool +toTheLeft min max x = ccw' min max x == CCW + +-- | \( O(1) \) +-- Create a random 2D vector which has a non-zero magnitude. +randomNonZeroVector :: (RandomGen g, Random r, Eq r, Num r) => Rand g (Vector 2 r) +randomNonZeroVector = do + v <- getRandom + if (quadrance v==0) + then randomNonZeroVector + else pure v diff --git a/src/Data/Geometry/PrioritySearchTree.hs b/src/Data/Geometry/PrioritySearchTree.hs --- a/src/Data/Geometry/PrioritySearchTree.hs +++ b/src/Data/Geometry/PrioritySearchTree.hs @@ -41,7 +41,7 @@ } deriving (Show,Eq) instance Bifunctor NodeData where - bimap f g (NodeData x m) = NodeData (g x) ((bimap (fmap g) f) <$> m) + bimap f g (NodeData x m) = NodeData (g x) (bimap (fmap g) f <$> m) maxVal :: Lens' (NodeData p r) (Maybe (Point 2 r :+ p)) maxVal = lens _maxVal (\(NodeData x _) m -> NodeData x m) @@ -97,7 +97,7 @@ -- TODO: In case we have multiple points with the same x-coord, these points -- are not really in decreasing y-order. Node l d r | py > d^?maxVal._Just.core.yCoord -> - node' l (d&maxVal .~ Just p) r (d^.maxVal) + node' l (d&maxVal ?~ p) r (d^.maxVal) -- push the existing point down | otherwise -> node' l d r (Just p) diff --git a/src/Data/Geometry/Properties.hs b/src/Data/Geometry/Properties.hs --- a/src/Data/Geometry/Properties.hs +++ b/src/Data/Geometry/Properties.hs @@ -1,6 +1,5 @@ {-# LANGUAGE ImpredicativeTypes #-} {-# LANGUAGE UnicodeSyntax #-} -{-# LANGUAGE DefaultSignatures #-} -------------------------------------------------------------------------------- -- | -- Module : Data.Geometry.Properties diff --git a/src/Data/Geometry/QuadTree.hs b/src/Data/Geometry/QuadTree.hs --- a/src/Data/Geometry/QuadTree.hs +++ b/src/Data/Geometry/QuadTree.hs @@ -1,5 +1,12 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Data.Geometry.QuadTree +-- Copyright : (C) Frank Staals +-- License : see the LICENSE file +-- Maintainer : Frank Staals +-------------------------------------------------------------------------------- module Data.Geometry.QuadTree-- ( module Data.Geometry.QuadTree.Cell -- , module Data.Geometry.QuadTree.Quadrants -- , module Data.Geometry.QuadTree.Split @@ -78,6 +85,7 @@ where c = fitsRectangle $ boundingBoxList (view core <$> pts) +{- HLINT ignore findLeaf -} -- | Locates the cell containing the given point, if it exists. -- -- running time: \(O(h)\), where \(h\) is the height of the quadTree @@ -147,7 +155,7 @@ GT -> Positive fromSignum :: (Num a, Eq a) => (b -> a) -> b -> Sign -fromSignum f = \x -> case signum (f x) of +fromSignum f x = case signum (f x) of -1 -> Negative 0 -> Zero 1 -> Positive diff --git a/src/Data/Geometry/QuadTree/Cell.hs b/src/Data/Geometry/QuadTree/Cell.hs --- a/src/Data/Geometry/QuadTree/Cell.hs +++ b/src/Data/Geometry/QuadTree/Cell.hs @@ -1,4 +1,11 @@ {-# LANGUAGE TemplateHaskell #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Data.Geometry.QuadTree.Cell +-- Copyright : (C) Frank Staals +-- License : see the LICENSE file +-- Maintainer : Frank Staals +-------------------------------------------------------------------------------- module Data.Geometry.QuadTree.Cell where import Control.Lens (makeLenses, (^.),(&),(%~),ix, to) @@ -41,7 +48,7 @@ type instance IntersectionOf (Point 2 r) (Cell r) = '[ NoIntersection, Point 2 r] -instance (Ord r, Fractional r) => (Point 2 r) `IsIntersectableWith` (Cell r) where +instance (Ord r, Fractional r) => Point 2 r `IsIntersectableWith` Cell r where nonEmptyIntersection = defaultNonEmptyIntersection p `intersect` c = p `intersect` toBox c @@ -55,7 +62,7 @@ cellWidth (Cell w _) = pow w toBox :: Fractional r => Cell r -> Box 2 () r -toBox (Cell w p) = box (ext $ p) (ext $ p .+^ Vector2 (pow w) (pow w)) +toBox (Cell w p) = box (ext p) (ext $ p .+^ Vector2 (pow w) (pow w)) inCell :: (Fractional r, Ord r) => Point 2 r :+ p -> Cell r -> Bool inCell (p :+ _) c = p `inBox` toBox c diff --git a/src/Data/Geometry/QuadTree/Quadrants.hs b/src/Data/Geometry/QuadTree/Quadrants.hs --- a/src/Data/Geometry/QuadTree/Quadrants.hs +++ b/src/Data/Geometry/QuadTree/Quadrants.hs @@ -1,3 +1,10 @@ +-------------------------------------------------------------------------------- +-- | +-- Module : Data.Geometry.QuadTree.Quadrants +-- Copyright : (C) Frank Staals +-- License : see the LICENSE file +-- Maintainer : Frank Staals +-------------------------------------------------------------------------------- module Data.Geometry.QuadTree.Quadrants( pattern Quadrants , Quadrants , module Data.Geometry.Box.Corners diff --git a/src/Data/Geometry/QuadTree/Split.hs b/src/Data/Geometry/QuadTree/Split.hs --- a/src/Data/Geometry/QuadTree/Split.hs +++ b/src/Data/Geometry/QuadTree/Split.hs @@ -1,4 +1,11 @@ {-# LANGUAGE TemplateHaskell #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Data.Geometry.QuadTree.Split +-- Copyright : (C) Frank Staals +-- License : see the LICENSE file +-- Maintainer : Frank Staals +-------------------------------------------------------------------------------- module Data.Geometry.QuadTree.Split where import Control.Lens (makePrisms,(^.)) @@ -22,10 +29,11 @@ -- | Split only when the Cell-width is at least wMin limitWidthTo :: WidthIndex -- ^ smallest allowed width of a cell (i.e. width of a leaf) -> Limiter r i v p -limitWidthTo wMin f = \c pts -> case f c pts of - No p -> No (Right p) - Yes v qs | wMin < c^.cellWidthIndex -> Yes v qs - | otherwise -> No (Left pts) +limitWidthTo wMin f c pts = + case f c pts of + No p -> No (Right p) + Yes v qs | wMin < c^.cellWidthIndex -> Yes v qs + | otherwise -> No (Left pts) -- note that it is important that we still evaluate the function so -- that we can distinguish at the last level i.e. between a regular -- " we are done splitting (No (Right p))" and a "we are no longer diff --git a/src/Data/Geometry/QuadTree/Tree.hs b/src/Data/Geometry/QuadTree/Tree.hs --- a/src/Data/Geometry/QuadTree/Tree.hs +++ b/src/Data/Geometry/QuadTree/Tree.hs @@ -1,5 +1,12 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Data.Geometry.QuadTree.Tree +-- Copyright : (C) Frank Staals +-- License : see the LICENSE file +-- Maintainer : Frank Staals +-------------------------------------------------------------------------------- module Data.Geometry.QuadTree.Tree where diff --git a/src/Data/Geometry/RangeTree.hs b/src/Data/Geometry/RangeTree.hs --- a/src/Data/Geometry/RangeTree.hs +++ b/src/Data/Geometry/RangeTree.hs @@ -1,4 +1,11 @@ {-# LANGUAGE UndecidableInstances #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Data.Geometry.RangeTree +-- Copyright : (C) Frank Staals +-- License : see the LICENSE file +-- Maintainer : Frank Staals +-------------------------------------------------------------------------------- module Data.Geometry.RangeTree where import Control.Lens hiding (element) @@ -13,8 +20,6 @@ import Data.Measured.Class import Data.Proxy import Data.Range -import Data.Semigroup.Foldable -import Data.Vector.Fixed.Cont (Peano, PeanoNum(..)) import GHC.TypeLits import Prelude hiding (last,init,head) diff --git a/src/Data/Geometry/RangeTree/Generic.hs b/src/Data/Geometry/RangeTree/Generic.hs --- a/src/Data/Geometry/RangeTree/Generic.hs +++ b/src/Data/Geometry/RangeTree/Generic.hs @@ -1,9 +1,15 @@ +-------------------------------------------------------------------------------- +-- | +-- Module : Data.Geometry.RangeTree.Generic +-- Copyright : (C) Frank Staals +-- License : see the LICENSE file +-- Maintainer : Frank Staals +-------------------------------------------------------------------------------- module Data.Geometry.RangeTree.Generic where import Control.Lens import Data.BinaryTree import Data.Ext -import Data.Geometry.Point import Data.Geometry.Properties import Data.Geometry.RangeTree.Measure import Data.List.NonEmpty (NonEmpty(..)) @@ -13,7 +19,6 @@ import Data.Measured.Size import Data.Semigroup import Data.Semigroup.Foldable -import qualified Data.Set as Set import Data.Util -------------------------------------------------------------------------------- diff --git a/src/Data/Geometry/RangeTree/Measure.hs b/src/Data/Geometry/RangeTree/Measure.hs --- a/src/Data/Geometry/RangeTree/Measure.hs +++ b/src/Data/Geometry/RangeTree/Measure.hs @@ -1,3 +1,11 @@ +{-# OPTIONS_GHC -Wno-orphans #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Data.Geometry.RangeTree.Measure +-- Copyright : (C) Frank Staals +-- License : see the LICENSE file +-- Maintainer : Frank Staals +-------------------------------------------------------------------------------- module Data.Geometry.RangeTree.Measure where import Data.Measured.Class diff --git a/src/Data/Geometry/SegmentTree.hs b/src/Data/Geometry/SegmentTree.hs --- a/src/Data/Geometry/SegmentTree.hs +++ b/src/Data/Geometry/SegmentTree.hs @@ -1,3 +1,10 @@ +-------------------------------------------------------------------------------- +-- | +-- Module : Data.Geometry.SegmentTree +-- Copyright : (C) Frank Staals +-- License : see the LICENSE file +-- Maintainer : Frank Staals +-------------------------------------------------------------------------------- module Data.Geometry.SegmentTree( module Data.Geometry.SegmentTree.Generic ) where diff --git a/src/Data/Geometry/SegmentTree/Generic.hs b/src/Data/Geometry/SegmentTree/Generic.hs --- a/src/Data/Geometry/SegmentTree/Generic.hs +++ b/src/Data/Geometry/SegmentTree/Generic.hs @@ -189,7 +189,7 @@ insert i (SegmentTree t) = SegmentTree $ insertRoot t where ri@(Range a b) = asRange i - insertRoot t' = maybe t' (flip insert' t') $ getRange t' + insertRoot t' = maybe t' (`insert'` t') $ getRange t' insert' inR lf@(Leaf nd@(LeafData rr _)) | coversAtomic ri inR rr = Leaf $ nd&leafAssoc %~ insertAssoc i diff --git a/src/Data/Geometry/Slab.hs b/src/Data/Geometry/Slab.hs --- a/src/Data/Geometry/Slab.hs +++ b/src/Data/Geometry/Slab.hs @@ -1,5 +1,12 @@ {-# Language ScopedTypeVariables #-} {-# Language TemplateHaskell #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Data.Geometry.Slab +-- Copyright : (C) Frank Staals +-- License : see the LICENSE file +-- Maintainer : Frank Staals +-------------------------------------------------------------------------------- module Data.Geometry.Slab where import Control.Lens (makeLenses, (^.),(%~),(.~),(&), both, from) @@ -56,15 +63,15 @@ '[Rectangle (a,a) r] -instance Ord r => (Slab o a r) `IsIntersectableWith` (Slab o a r) where +instance Ord r => Slab o a r `IsIntersectableWith` Slab o a r where nonEmptyIntersection = defaultNonEmptyIntersection (Slab i) `intersect` (Slab i') = match (i `intersect` i') $ - (H $ \NoIntersection -> coRec NoIntersection) - :& (H $ \i'' -> coRec (Slab i'' :: Slab o a r)) + H (\NoIntersection -> coRec NoIntersection) + :& H (\i'' -> coRec (Slab i'' :: Slab o a r)) :& RNil -instance (Slab Horizontal a r) `IsIntersectableWith` (Slab Vertical a r) where +instance Slab Horizontal a r `IsIntersectableWith` Slab Vertical a r where nonEmptyIntersection _ _ _ = True (Slab h) `intersect` (Slab v) = coRec $ box low high @@ -98,18 +105,18 @@ [NoIntersection, Line 2 r, LineSegment 2 a r] instance (Fractional r, Ord r, HasBoundingLines o) => - Line 2 r `IsIntersectableWith` (Slab o a r) where + Line 2 r `IsIntersectableWith` Slab o a r where nonEmptyIntersection = defaultNonEmptyIntersection l@(Line p _) `intersect` s = match (l `intersect` a) $ - (H $ \NoIntersection -> if p `inSlab` s then coRec l else coRec NoIntersection) - :& (H $ \pa -> match (l `intersect` b) $ - (H $ \NoIntersection -> coRec NoIntersection) - :& (H $ \pb -> coRec $ lineSegment' pa pb) - :& (H $ \_ -> coRec l) + H (\NoIntersection -> if p `inSlab` s then coRec l else coRec NoIntersection) + :& H (\pa -> match (l `intersect` b) $ + H coRec -- NoIntersection + :& H (coRec . lineSegment' pa) + :& H (\_ -> coRec l) :& RNil ) - :& (H $ \_ -> coRec l) + :& H (\_ -> coRec l) :& RNil where (a :+ _,b :+ _) = boundingLines s @@ -125,17 +132,17 @@ [NoIntersection, SubLine 2 () s r] instance (Fractional r, Ord r, HasBoundingLines o) => - SubLine 2 a r r `IsIntersectableWith` (Slab o a r) where + SubLine 2 a r r `IsIntersectableWith` Slab o a r where nonEmptyIntersection = defaultNonEmptyIntersection sl@(SubLine l _) `intersect` s = match (l `intersect` s) $ - (H $ \NoIntersection -> coRec NoIntersection) - :& (H $ \(Line _ _) -> coRec $ dropExtra sl) - :& (H $ \seg -> match (sl `intersect` (seg^._SubLine)) $ - (H $ \NoIntersection -> coRec NoIntersection) - :& (H $ \p@(Point2 _ _) -> coRec $ singleton p) - :& (H $ \ss -> coRec $ dropExtra ss) + H (\NoIntersection -> coRec NoIntersection) + :& H (\(Line _ _) -> coRec $ dropExtra sl) + :& H (\seg -> match (sl `intersect` (seg^._SubLine)) $ + H (\NoIntersection -> coRec NoIntersection) + :& H (\p@Point2{} -> coRec $ singleton p) + :& H ( coRec . dropExtra) :& RNil) :& RNil where @@ -146,12 +153,12 @@ [NoIntersection, LineSegment 2 () r] instance (Fractional r, Ord r, HasBoundingLines o) => - LineSegment 2 a r `IsIntersectableWith` (Slab o a r) where + LineSegment 2 a r `IsIntersectableWith` Slab o a r where nonEmptyIntersection = defaultNonEmptyIntersection seg `intersect` slab = match ((seg^._SubLine) `intersect` slab) $ - (H $ \NoIntersection -> coRec NoIntersection) - :& (H $ \sl -> coRec $ sl^. from _SubLine) + H (\NoIntersection -> coRec NoIntersection) + :& H (\sl -> coRec $ sl^. from _SubLine) :& RNil diff --git a/src/Data/Geometry/SubLine.hs b/src/Data/Geometry/SubLine.hs --- a/src/Data/Geometry/SubLine.hs +++ b/src/Data/Geometry/SubLine.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE UndecidableInstances #-} -------------------------------------------------------------------------------- -- | @@ -10,7 +9,22 @@ -- SubLine; a part of a line -- -------------------------------------------------------------------------------- -module Data.Geometry.SubLine where +module Data.Geometry.SubLine + ( SubLine(..) + , line + , subRange + , fixEndPoints + , dropExtra + , _unBounded + , toUnbounded + , fromUnbounded + , onSubLine + , onSubLineUB + , onSubLine2 + , onSubLine2UB + , getEndPointsUnBounded + , fromLine + ) where import Control.Lens import Data.Bifunctor @@ -27,8 +41,6 @@ import Data.Vinyl.CoRec import Test.QuickCheck(Arbitrary(..)) -import Data.Ratio - -------------------------------------------------------------------------------- -- | Part of a line. The interval is ranged based on the vector of the @@ -36,8 +48,15 @@ data SubLine d p s r = SubLine { _line :: Line d r , _subRange :: Interval p s } -makeLenses ''SubLine +-- | Line part of SubLine. +line :: Lens (SubLine d1 p s r1) (SubLine d2 p s r2) (Line d1 r1) (Line d2 r2) +line = lens _line (\sub l -> SubLine l (_subRange sub)) + +-- | Interval part of SubLine. +subRange :: Lens (SubLine d p1 s1 r) (SubLine d p2 s2 r) (Interval p1 s1) (Interval p2 s2) +subRange = lens _subRange (SubLine . _line) + type instance Dimension (SubLine d p s r) = d @@ -57,7 +76,7 @@ fixEndPoints sl = sl&subRange %~ f where ptAt = flip pointAt (sl^.line) - label (c :+ e) = (c :+ (ptAt c :+ e)) + label (c :+ e) = c :+ (ptAt c :+ e) f ~(Interval l u) = Interval (l&unEndPoint %~ label) (u&unEndPoint %~ label) @@ -65,6 +84,7 @@ dropExtra :: SubLine d p s r -> SubLine d () s r dropExtra = over subRange (first (const ())) +-- | Prism for downcasting an unbounded subline to a subline. _unBounded :: Prism' (SubLine d p (UnBounded r) r) (SubLine d p r r) _unBounded = prism' toUnbounded fromUnbounded @@ -88,10 +108,14 @@ -- lies on the subline, i.e. in the interval r onSubLineUB :: (Ord r, Fractional r) => Point 2 r -> SubLine 2 p (UnBounded r) r -> Bool -p `onSubLineUB` (SubLine l r) = case toOffset p l of - Nothing -> False - Just x -> Val x `inInterval` r +p `onSubLineUB` (SubLine l r) = + p `onLine2` l && + Val (toOffset' p l) `inInterval` r +inSubLineIntervalUB :: (Ord r, Fractional r) + => Point 2 r -> SubLine 2 p (UnBounded r) r -> Bool +p `inSubLineIntervalUB` (SubLine l r) = Val (toOffset' p l) `inInterval` r + -- | given point p, and a Subline l r such that p lies on line l, test if it -- lies on the subline, i.e. in the interval r onSubLine2 :: (Ord r, Num r) => Point 2 r -> SubLine 2 p r r -> Bool @@ -118,19 +142,20 @@ , SubLine 2 p s r ] +{- HLINT ignore "Redundant bracket" -} instance (Ord r, Fractional r) => - (SubLine 2 p r r) `IsIntersectableWith` (SubLine 2 p r r) where + SubLine 2 p r r `IsIntersectableWith` SubLine 2 p r r where nonEmptyIntersection = defaultNonEmptyIntersection sl@(SubLine l r) `intersect` sm@(SubLine m _) = match (l `intersect` m) $ - (H $ \NoIntersection -> coRec NoIntersection) - :& (H $ \p@(Point _) -> if onSubLine2 p sl && onSubLine2 p sm + H (\NoIntersection -> coRec NoIntersection) + :& H (\p@(Point _) -> if onSubLine2 p sl && onSubLine2 p sm then coRec p else coRec NoIntersection) - :& (H $ \_ -> match (r `intersect` s'') $ - (H $ \NoIntersection -> coRec NoIntersection) - :& (H $ \i -> coRec $ SubLine l i) + :& H (\_ -> match (r `intersect` s'') $ + H coRec -- NoIntersection + :& H (coRec . SubLine l) :& RNil ) :& RNil @@ -141,17 +166,17 @@ &end.core .~ toOffset' (s'^.end.extra.core) l instance (Ord r, Fractional r) => - (SubLine 2 p (UnBounded r) r) `IsIntersectableWith` (SubLine 2 p (UnBounded r) r) where + SubLine 2 p (UnBounded r) r `IsIntersectableWith` SubLine 2 p (UnBounded r) r where nonEmptyIntersection = defaultNonEmptyIntersection sl@(SubLine l r) `intersect` sm@(SubLine m _) = match (l `intersect` m) $ - (H $ \NoIntersection -> coRec NoIntersection) - :& (H $ \p@(Point _) -> if onSubLine2UB p sl && onSubLine2UB p sm + H (\NoIntersection -> coRec NoIntersection) + :& H (\p@(Point _) -> if inSubLineIntervalUB p sl && inSubLineIntervalUB p sm then coRec p else coRec NoIntersection) - :& (H $ \_ -> match (r `intersect` s'') $ - (H $ \NoIntersection -> coRec NoIntersection) - :& (H $ \i -> coRec $ SubLine l i) + :& H (\_ -> match (r `intersect` s'') $ + H coRec -- NoIntersection + :& H (coRec . SubLine l) :& RNil ) :& RNil @@ -168,6 +193,7 @@ where f = flip pointAt (sl^.line) +-- | Create a SubLine that covers the original line from -infinity to +infinity. fromLine :: Arity d => Line d r -> SubLine d () (UnBounded r) r fromLine l = SubLine l (ClosedInterval (ext MinInfinity) (ext MaxInfinity)) @@ -185,6 +211,6 @@ -- testzz = let f = bimap (fmap Val) (const ()) -- in -testz :: SubLine 2 () Rational Rational -testz = SubLine (Line (Point2 0 0) (Vector2 10 0)) - (Interval (Closed (0 % 1 :+ ())) (Closed (1 % 1 :+ ()))) +-- testz :: SubLine 2 () Rational Rational +-- testz = SubLine (Line (Point2 0 0) (Vector2 10 0)) +-- (Interval (Closed (0 % 1 :+ ())) (Closed (1 % 1 :+ ()))) diff --git a/src/Data/Geometry/Transformation.hs b/src/Data/Geometry/Transformation.hs --- a/src/Data/Geometry/Transformation.hs +++ b/src/Data/Geometry/Transformation.hs @@ -1,5 +1,12 @@ {-# LANGUAGE Unsafe #-} {-# LANGUAGE UndecidableInstances #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Data.Geometry.Transformation +-- Copyright : (C) Frank Staals +-- License : see the LICENSE file +-- Maintainer : Frank Staals +-------------------------------------------------------------------------------- module Data.Geometry.Transformation where import Control.Lens (iso,set,Iso,imap) @@ -12,6 +19,10 @@ import Data.Proxy import GHC.TypeLits +{- $setup +>>> import Data.Geometry.LineSegment +>>> import Data.Ext +-} -------------------------------------------------------------------------------- -- * Transformations @@ -19,6 +30,7 @@ -- | A type representing a Transformation for d dimensional objects newtype Transformation d r = Transformation { _transformationMatrix :: Matrix (d + 1) (d + 1) r } +-- | Transformations and Matrices are isomorphic. transformationMatrix :: Iso (Transformation d r) (Transformation d s) (Matrix (d + 1) (d + 1) r) (Matrix (d + 1) (d + 1) s) transformationMatrix = iso _transformationMatrix Transformation @@ -42,7 +54,7 @@ -- | Compute the inverse transformation -- -- >>> inverseOf $ translation (Vector2 (10.0) (5.0)) --- Transformation {_transformationMatrix = Matrix Vector3 [Vector3 [1.0,0.0,-10.0],Vector3 [0.0,1.0,-5.0],Vector3 [0.0,0.0,1.0]]} +-- Transformation {_transformationMatrix = Matrix (Vector3 (Vector3 1.0 0.0 (-10.0)) (Vector3 0.0 1.0 (-5.0)) (Vector3 0.0 0.0 1.0))} inverseOf :: (Fractional r, Invertible (d + 1) r) => Transformation d r -> Transformation d r inverseOf = Transformation . inverse' . _transformationMatrix @@ -54,11 +66,19 @@ class IsTransformable g where transformBy :: Transformation (Dimension g) (NumType g) -> g -> g +-- | Apply a transformation to a collection of objects. +-- +-- >>> transformAllBy (uniformScaling 2) [Point1 1, Point1 2, Point1 3] +-- [Point1 2.0,Point1 4.0,Point1 6.0] transformAllBy :: (Functor c, IsTransformable g) => Transformation (Dimension g) (NumType g) -> c g -> c g transformAllBy t = fmap (transformBy t) - +-- | Apply transformation to a PointFunctor, ie something that contains +-- points. Polygons, triangles, line segments, etc, are all PointFunctors. +-- +-- >>> transformPointFunctor (uniformScaling 2) $ OpenLineSegment (Point1 1 :+ ()) (Point1 2 :+ ()) +-- OpenLineSegment (Point1 2.0 :+ ()) (Point1 4.0 :+ ()) transformPointFunctor :: ( PointFunctor g, Fractional r, d ~ Dimension (g r) , Arity d, Arity (d + 1) ) => Transformation d r -> g r -> g r @@ -78,15 +98,31 @@ -------------------------------------------------------------------------------- -- * Common transformations +-- | Create translation transformation from a vector. +-- +-- >>> transformBy (translation $ Vector2 1 2) $ Point2 2 3 +-- Point2 3.0 5.0 translation :: (Num r, Arity d, Arity (d + 1)) => Vector d r -> Transformation d r translation v = Transformation . Matrix $ imap transRow (snoc v 1) - +-- | Create scaling transformation from a vector. +-- +-- >>> transformBy (scaling $ Vector2 2 (-1)) $ Point2 2 3 +-- Point2 4.0 (-3.0) scaling :: (Num r, Arity d, Arity (d + 1)) => Vector d r -> Transformation d r scaling v = Transformation . Matrix $ imap mkRow (snoc v 1) +-- | Create scaling transformation from a scalar that is applied +-- to all dimensions. +-- +-- >>> transformBy (uniformScaling 5) $ Point2 2 3 +-- Point2 10.0 15.0 +-- >>> uniformScaling 5 == scaling (Vector2 5 5) +-- True +-- >>> uniformScaling 5 == scaling (Vector3 5 5 5) +-- True uniformScaling :: (Num r, Arity d, Arity (d + 1)) => r -> Transformation d r uniformScaling = scaling . pure @@ -94,17 +130,29 @@ -------------------------------------------------------------------------------- -- * Functions that execute transformations +-- | Translate a given point. +-- +-- >>> translateBy (Vector2 1 2) $ Point2 2 3 +-- Point2 3.0 5.0 translateBy :: ( IsTransformable g, Num (NumType g) , Arity (Dimension g), Arity (Dimension g + 1) ) => Vector (Dimension g) (NumType g) -> g -> g translateBy = transformBy . translation +-- | Scale a given point. +-- +-- >>> scaleBy (Vector2 2 (-1)) $ Point2 2 3 +-- Point2 4.0 (-3.0) scaleBy :: ( IsTransformable g, Num (NumType g) , Arity (Dimension g), Arity (Dimension g + 1) ) => Vector (Dimension g) (NumType g) -> g -> g scaleBy = transformBy . scaling +-- | Scale a given point uniformly in all dimensions. +-- +-- >>> scaleUniformlyBy 5 $ Point2 2 3 +-- Point2 10.0 15.0 scaleUniformlyBy :: ( IsTransformable g, Num (NumType g) , Arity (Dimension g), Arity (Dimension g + 1) ) => NumType g -> g -> g diff --git a/src/Data/Geometry/Triangle.hs b/src/Data/Geometry/Triangle.hs --- a/src/Data/Geometry/Triangle.hs +++ b/src/Data/Geometry/Triangle.hs @@ -1,36 +1,37 @@ {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE UndecidableInstances #-} +-- | Triangles in \(d\)-dimensional space. module Data.Geometry.Triangle where -import Control.DeepSeq +import Control.DeepSeq (NFData) import Control.Lens -import Data.Bifoldable -import Data.Bifunctor +import Data.Bifoldable (Bifoldable (bifoldMap)) +import Data.Bifunctor (Bifunctor (first)) import Data.Bitraversable -import Data.Either (partitionEithers) +import Data.Either (partitionEithers) import Data.Ext -import Data.Geometry.Ball (Disk, disk) -import Data.Geometry.Boundary +import Data.Geometry.Ball (Disk, disk) +import Data.Geometry.Boundary (PointLocationResult (..)) +import Data.Geometry.Box (IsBoxable (..)) import Data.Geometry.HyperPlane -import Data.Geometry.Line +import Data.Geometry.Line (Line (Line)) import Data.Geometry.LineSegment import Data.Geometry.Point import Data.Geometry.Properties import Data.Geometry.Transformation import Data.Geometry.Vector -import qualified Data.Geometry.Vector as V -import qualified Data.List as List -import Data.Maybe (mapMaybe) -import Data.Util -import Data.Vinyl -import Data.Vinyl.CoRec -import GHC.Generics (Generic) -import GHC.TypeLits +import qualified Data.Geometry.Vector as V +import qualified Data.List as List +import Data.Maybe (mapMaybe) +import Data.Util (Three, pattern Three) +import Data.Vinyl (Rec (RNil, (:&))) +import Data.Vinyl.CoRec (Handler (H), match) +import GHC.Generics (Generic) +import GHC.TypeLits (type (+)) -------------------------------------------------------------------------------- --- | Triangles in \(d\)-dimensional space. +-- | A triangle in \(d\)-dimensional space. data Triangle d p r = Triangle !(Point d r :+ p) !(Point d r :+ p) !(Point d r :+ p) @@ -62,6 +63,7 @@ type instance NumType (Triangle d p r) = r type instance Dimension (Triangle d p r) = d +-- | A \(d\)-dimensional triangle is isomorphic to a triple of \(d\)-dimensional points. _TriangleThreePoints :: Iso' (Triangle d p r) (Three (Point d r :+ p)) _TriangleThreePoints = iso (\(Triangle p q r) -> Three p q r) (\(Three p q r) -> Triangle p q r) @@ -77,7 +79,7 @@ where Triangle' p q r = Triangle (ext p) (ext q) (ext r) - +-- | Get the three line-segments that make up the sides of a triangle. sideSegments :: Triangle d p r -> [LineSegment d p r] sideSegments (Triangle p q r) = [ClosedLineSegment p q, ClosedLineSegment q r, ClosedLineSegment r p] @@ -101,7 +103,7 @@ isDegenerateTriangle :: (Num r, Eq r) => Triangle 2 p r -> Bool isDegenerateTriangle = (== 0) . doubleArea --- | get the inscribed disk. Returns Nothing if the triangle is degenerate, +-- | Get the inscribed disk. Returns Nothing if the triangle is degenerate, -- i.e. if the points are colinear. inscribedDisk :: (Eq r, Fractional r) => Triangle 2 p r -> Maybe (Disk () r) @@ -144,18 +146,33 @@ inTriangle :: (Ord r, Fractional r) => Point 2 r -> Triangle 2 p r -> PointLocationResult inTriangle q t - | all (`inRange` (OpenRange 0 1)) [a,b,c] = Inside - | all (`inRange` (ClosedRange 0 1)) [a,b,c] = OnBoundary + | all (`inRange` OpenRange 0 1) [a,b,c] = Inside + | all (`inRange` ClosedRange 0 1) [a,b,c] = OnBoundary | otherwise = Outside where Vector3 a b c = toBarricentric q t +inTriangleRelaxed :: (Ord r, Num r) + => Point 2 r -> Triangle 2 p r -> PointLocationResult +inTriangleRelaxed q (Triangle a b c) + | ab == CoLinear && bc == ca = OnBoundary + | bc == CoLinear && ca == ab = OnBoundary + | ca == CoLinear && bc == ab = OnBoundary + | ab == bc && bc == ca = Inside + | otherwise = Outside + where + ab = ccw (a^.core) (b^.core) q + bc = ccw (b^.core) (c^.core) q + ca = ccw (c^.core) (a^.core) q + -- | Test if a point lies inside or on the boundary of a triangle onTriangle :: (Ord r, Fractional r) => Point 2 r -> Triangle 2 p r -> Bool q `onTriangle` t = let Vector3 a b c = toBarricentric q t - in all (`inRange` (ClosedRange 0 1)) [a,b,c] + in all (`inRange` ClosedRange 0 1) [a,b,c] +onTriangleRelaxed :: (Ord r, Num r) => Point 2 r -> Triangle 2 p r -> Bool +q `onTriangleRelaxed` t = inTriangleRelaxed q t /= Outside -- myQ :: Point 2 Rational -- myQ = read "Point2 [(-5985) % 16,(-14625) % 1]" @@ -165,7 +182,7 @@ type instance IntersectionOf (Line 2 r) (Triangle 2 p r) = [ NoIntersection, Point 2 r, LineSegment 2 () r ] -instance (Fractional r, Ord r) => (Line 2 r) `IsIntersectableWith` (Triangle 2 p r) where +instance (Fractional r, Ord r) => Line 2 r `IsIntersectableWith` Triangle 2 p r where nonEmptyIntersection = defaultNonEmptyIntersection l `intersect` (Triangle p q r) = @@ -180,9 +197,9 @@ collect :: LineSegment 2 p r -> Maybe (Either (Point 2 r) (LineSegment 2 p r)) collect s = match (s `intersect` l) $ - (H $ \NoIntersection -> Nothing) - :& (H $ \(a :: Point 2 r) -> Just $ Left a) - :& (H $ \(e :: LineSegment 2 p r) -> Just $ Right e) + H (\NoIntersection -> Nothing) + :& H (\(a :: Point 2 r) -> Just $ Left a) + :& H (\(e :: LineSegment 2 p r) -> Just $ Right e) :& RNil @@ -190,14 +207,15 @@ type instance IntersectionOf (Line 3 r) (Triangle 3 p r) = [ NoIntersection, Point 3 r, LineSegment 3 () r ] -instance (Fractional r, Ord r) => (Line 3 r) `IsIntersectableWith` (Triangle 3 p r) where +{- HLINT ignore "Use const" -} +instance (Fractional r, Ord r) => Line 3 r `IsIntersectableWith` Triangle 3 p r where nonEmptyIntersection = defaultNonEmptyIntersection l@(Line a v) `intersect` t@(Triangle (p :+ _) (q :+ _) (r :+ _)) = match (l `intersect` h) $ - (H $ \NoIntersection -> coRec NoIntersection) - :& (H $ \i@(Point3 _ _ _) -> if onTriangle' i then coRec i else coRec NoIntersection) - :& (H $ \_ -> intersect2d) + H (\NoIntersection -> coRec NoIntersection) + :& H (\i@Point3{} -> if onTriangle' i then coRec i else coRec NoIntersection) + :& H (\_ -> intersect2d) :& RNil where h@(Plane _ n) = supportingPlane t @@ -210,13 +228,13 @@ -- test if the point in terms of its 2d coords lies in side the projected triangle onTriangle' :: Point 3 r -> Bool - onTriangle' i = (project i) `onTriangle` t' + onTriangle' i = project i `onTriangle` t' -- FIXME! these vectors may not be unit vectors. How do we deal with -- that? (and does that really matter here?) transf :: Transformation 3 r transf = let u = p .-. q - in rotateTo (Vector3 u (n `cross` u) n) |.| translation ((-1) *^ (toVec q)) + in rotateTo (Vector3 u (n `cross` u) n) |.| translation ((-1) *^ toVec q) -- inverse of the transformation above. invTrans :: Transformation 3 r invTrans = inverseOf transf @@ -233,8 +251,11 @@ intersect2d :: Intersection (Line 3 r) (Triangle 3 p r) intersect2d = match (l' `intersect` t') $ - (H $ \NoIntersection -> coRec NoIntersection) - :& (H $ \i@(Point2 _ _) -> coRec $ lift i) - :& (H $ \(LineSegment s e) -> coRec $ LineSegment (s&unEndPoint.core %~ lift) - (e&unEndPoint.core %~ lift)) + H (\NoIntersection -> coRec NoIntersection) + :& H (\i@(Point2 _ _) -> coRec $ lift i) + :& H (\(LineSegment s e) -> coRec $ LineSegment (s&unEndPoint.core %~ lift) + (e&unEndPoint.core %~ lift)) :& RNil + +instance (Arity d, Ord r) => IsBoxable (Triangle d p r) where + boundingBox (Triangle a b c) = boundingBox a <> boundingBox b <> boundingBox c diff --git a/src/Data/Geometry/Vector.hs b/src/Data/Geometry/Vector.hs --- a/src/Data/Geometry/Vector.hs +++ b/src/Data/Geometry/Vector.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -------------------------------------------------------------------------------- -- | @@ -17,35 +17,42 @@ , quadrance, qdA, distanceA , dot, norm, signorm , isScalarMultipleOf - , scalarMultiple + , scalarMultiple, sameDirection -- reexports , FV.replicate , xComponent, yComponent, zComponent ) where -import Control.Applicative (liftA2) -import Control.Lens (Lens') +import Control.Applicative (liftA2) +import Control.Lens (Lens') import Control.Monad.State -import qualified Data.Foldable as F +import qualified Data.Foldable as F import Data.Geometry.Properties import Data.Geometry.Vector.VectorFamily -import Data.Geometry.Vector.VectorFixed (C(..)) -import qualified Data.Vector.Fixed as FV +import Data.Geometry.Vector.VectorFixed (C (..)) +import qualified Data.Vector.Fixed as FV import GHC.TypeLits -import Linear.Affine (Affine(..), qdA, distanceA) -import Linear.Metric (dot,norm,signorm,quadrance) -import Linear.Vector as LV hiding (E(..)) -import System.Random (Random(..)) -import Test.QuickCheck (Arbitrary(..),infiniteList) +import Linear.Affine (Affine (..), distanceA, qdA) +import Linear.Metric (dot, norm, quadrance, signorm) +import Linear.Vector as LV hiding (E (..)) +import System.Random (Random (..)) +import Test.QuickCheck (Arbitrary (..), Arbitrary1 (..), infiniteList, + infiniteListOf) -------------------------------------------------------------------------------- +-- $setup +-- >>> import Control.Lens + type instance Dimension (Vector d r) = d type instance NumType (Vector d r) = r instance (Arbitrary r, Arity d) => Arbitrary (Vector d r) where arbitrary = vectorFromListUnsafe <$> infiniteList +instance (Arity d) => Arbitrary1 (Vector d) where + liftArbitrary gen = vectorFromListUnsafe <$> infiniteListOf gen + instance (Random r, Arity d) => Random (Vector d r) where randomR (lows,highs) g0 = flip runState g0 $ FV.zipWithM (\l h -> state $ randomR (l,h)) lows highs @@ -79,7 +86,7 @@ => Vector d r -> Vector d r -> Bool u `isScalarMultipleOf` v = let d = u `dot` v num = quadrance u * quadrance v - in num == 0 || 1 == d*d / num + in num == 0 || num == d*d -- u `isScalarMultipleOf` v = isJust $ scalarMultiple u v {-# SPECIALIZE isScalarMultipleOf :: (Eq r, Fractional r) => Vector 2 r -> Vector 2 r -> Bool #-} @@ -146,17 +153,46 @@ scalarMultiple' :: (Eq r, Fractional r) => Vector 2 r -> Vector 2 r -> Maybe r #-} +-- | Given two colinar vectors, u and v, test if they point in the same direction, i.e. +-- iff scalarMultiple' u v == Just lambda, with lambda > 0 +-- +-- pre: u and v are colinear, u and v are non-zero +sameDirection :: (Eq r, Num r, Arity d) => Vector d r -> Vector d r -> Bool +sameDirection u v = and $ FV.zipWith (\ux vx -> signum ux == signum vx) u v + +-- sameDirectionProp :: (Eq r, Fractional r, Arity d) +-- => Vector d r -> Vector d r -> Bool +-- sameDirectionProp u v = sameDirection u v == maybe False ((/= (-1)) . signum) (scalarMultiple' u v) + -------------------------------------------------------------------------------- -- * Helper functions specific to two and three dimensional vectors +-- | Shorthand to access the first component +-- +-- >>> Vector3 1 2 3 ^. xComponent +-- 1 +-- >>> Vector2 1 2 & xComponent .~ 10 +-- Vector2 10 2 xComponent :: (1 <= d, Arity d) => Lens' (Vector d r) r xComponent = element (C :: C 0) {-# INLINABLE xComponent #-} +-- | Shorthand to access the second component +-- +-- >>> Vector3 1 2 3 ^. yComponent +-- 2 +-- >>> Vector2 1 2 & yComponent .~ 10 +-- Vector2 1 10 yComponent :: (2 <= d, Arity d) => Lens' (Vector d r) r yComponent = element (C :: C 1) {-# INLINABLE yComponent #-} +-- | Shorthand to access the third component +-- +-- >>> Vector3 1 2 3 ^. zComponent +-- 3 +-- >>> Vector3 1 2 3 & zComponent .~ 10 +-- Vector3 1 2 10 zComponent :: (3 <= d, Arity d) => Lens' (Vector d r) r zComponent = element (C :: C 2) {-# INLINABLE zComponent #-} diff --git a/src/Data/Geometry/Vector/VectorFamily.hs b/src/Data/Geometry/Vector/VectorFamily.hs --- a/src/Data/Geometry/Vector/VectorFamily.hs +++ b/src/Data/Geometry/Vector/VectorFamily.hs @@ -15,31 +15,29 @@ module Data.Geometry.Vector.VectorFamily where import Control.DeepSeq -import Control.Lens hiding (element) +import Control.Lens hiding (element) +import Control.Monad import Data.Aeson --- import Data.Aeson (ToJSON(..),FromJSON(..)) -import qualified Data.Foldable as F -import qualified Data.List as L -import Data.Geometry.Vector.VectorFixed (C(..)) +import qualified Data.Foldable as F +import Data.Functor.Classes +import Data.Geometry.Vector.VectorFamilyPeano (ImplicitArity, VectorFamily (..), + VectorFamilyF) import qualified Data.Geometry.Vector.VectorFamilyPeano as Fam -import Data.Geometry.Vector.VectorFamilyPeano ( VectorFamily(..) - , VectorFamilyF - , ImplicitArity - ) -import qualified Data.Vector.Fixed as V -import Data.Vector.Fixed.Cont (Peano) +import Data.Geometry.Vector.VectorFixed (C (..)) +import Data.Hashable +import Data.List +import qualified Data.List as L +import Data.Proxy +import qualified Data.Vector.Fixed as V +import Data.Vector.Fixed.Cont (Peano) import GHC.TypeLits -import Linear.Affine (Affine(..)) +import Linear.Affine (Affine (..)) import Linear.Metric -import qualified Linear.V2 as L2 -import qualified Linear.V3 as L3 -import qualified Linear.V4 as L4 +import qualified Linear.V2 as L2 +import qualified Linear.V3 as L3 +import qualified Linear.V4 as L4 import Linear.Vector -import Text.ParserCombinators.ReadP (ReadP, string,pfail) -import Text.ParserCombinators.ReadPrec (lift) -import Text.Read (Read(..),readListPrecDefault, readPrec_to_P,minPrec) -import Data.Proxy -import Data.Hashable +import Text.Read (Read (..), readListPrecDefault) -------------------------------------------------------------------------------- -- * d dimensional Vectors @@ -56,8 +54,9 @@ type instance Index (Vector d r) = Int type instance IxValue (Vector d r) = r -unV :: Lens (Vector d r) (Vector d s) (VectorFamily (Peano d) r) (VectorFamily (Peano d) s) -unV = lens _unV (const MKVector) +-- | Vectors are isomorphic to a definition determined by 'VectorFamily'. +unV :: Iso (Vector d r) (Vector d s) (VectorFamily (Peano d) r) (VectorFamily (Peano d) s) +unV = iso _unV MKVector {-# INLINE unV #-} -- type Arity d = (ImplicitArity (Peano d), KnownNat d) @@ -66,6 +65,7 @@ deriving instance (Eq r, Arity d) => Eq (Vector d r) +deriving instance Arity d => Eq1 (Vector d) deriving instance (Ord r, Arity d) => Ord (Vector d r) deriving instance Arity d => Functor (Vector d) @@ -99,22 +99,50 @@ inspect = V.inspect . _unV basicIndex = V.basicIndex . _unV -instance (Arity d, Show r) => Show (Vector d r) where - show v = mconcat [ "Vector", show $ F.length v , " " - , show $ F.toList v ] +-- instance (Arity d, Show r) => Show (Vector d r) where +-- show v = mconcat [ "Vector", show $ F.length v , " " +-- , show $ F.toList v ] +-- instance (Read r, Arity d) => Read (Vector d r) where +-- readPrec = lift readVec +-- where +-- readVec :: (Arity d, Read r) => ReadP (Vector d r) +-- readVec = do let d = natVal (Proxy :: Proxy d) +-- _ <- string $ "Vector" <> show d <> " " +-- rs <- readPrec_to_P readPrec minPrec +-- case vectorFromList rs of +-- Just v -> pure v +-- _ -> pfail +-- readListPrec = readListPrecDefault + +instance (Show r, Arity d) => Show (Vector d r) where + showsPrec = liftShowsPrec showsPrec showList + +instance (Arity d) => Show1 (Vector d) where + liftShowsPrec sp _ d v = showParen (d > 10) $ + showString constr . showChar ' ' . + unwordsS (map (sp 11) (F.toList v)) + where + constr = "Vector" <> show (fromIntegral (natVal @d Proxy)) + unwordsS = foldr (.) id . intersperse (showChar ' ') + instance (Read r, Arity d) => Read (Vector d r) where - readPrec = lift readVec + readPrec = liftReadPrec readPrec readListPrec readListPrec = readListPrecDefault -readVec :: forall d r. (Arity d, Read r) => ReadP (Vector d r) -readVec = do let d = natVal (Proxy :: Proxy d) - _ <- string $ "Vector" <> show d <> " " - rs <- readPrec_to_P readPrec minPrec - case vectorFromList rs of - Just v -> pure v - _ -> pfail +instance (Arity d) => Read1 (Vector d) where + liftReadPrec rp _rl = readData $ + readUnaryWith (replicateM d rp) constr $ \rs -> + case vectorFromList rs of + Just p -> p + _ -> error "internal error in Data.Geometry.Vector read instance." + where + d = fromIntegral (natVal (Proxy :: Proxy d)) + constr = "Vector" <> show d + liftReadListPrec = liftReadListPrecDefault + + deriving instance (FromJSON r, Arity d) => FromJSON (Vector d r) instance (ToJSON r, Arity d) => ToJSON (Vector d r) where toJSON = toJSON . _unV @@ -125,39 +153,48 @@ -------------------------------------------------------------------------------- -- * Convenience "constructors" +-- | Constant sized vector with d elements. pattern Vector :: VectorFamilyF (Peano d) r -> Vector d r pattern Vector v = MKVector (VectorFamily v) {-# COMPLETE Vector #-} +-- | Constant sized vector with 1 element. pattern Vector1 :: r -> Vector 1 r pattern Vector1 x = (Vector (Identity x)) {-# COMPLETE Vector1 #-} +-- | Constant sized vector with 2 elements. pattern Vector2 :: r -> r -> Vector 2 r pattern Vector2 x y = (Vector (L2.V2 x y)) {-# COMPLETE Vector2 #-} +-- | Constant sized vector with 3 elements. pattern Vector3 :: r -> r -> r -> Vector 3 r pattern Vector3 x y z = (Vector (L3.V3 x y z)) {-# COMPLETE Vector3 #-} +-- | Constant sized vector with 4 elements. pattern Vector4 :: r -> r -> r -> r -> Vector 4 r pattern Vector4 x y z w = (Vector (L4.V4 x y z w)) {-# COMPLETE Vector4 #-} -------------------------------------------------------------------------------- +-- | \( O(n) \) Convert from a list to a non-empty vector. vectorFromList :: Arity d => [r] -> Maybe (Vector d r) vectorFromList = V.fromListM +-- | \( O(n) \) Convert from a list to a non-empty vector. vectorFromListUnsafe :: Arity d => [r] -> Vector d r vectorFromListUnsafe = V.fromList +-- | \( O(n) \) Pop the first element off a vector. destruct :: (Arity d, Arity (d + 1)) => Vector (d + 1) r -> (r, Vector d r) destruct v = (L.head $ F.toList v, vectorFromListUnsafe . tail $ F.toList v) -- FIXME: this implementaion of tail is not particularly nice +-- | \( O(1) \) First element. Since arity is at least 1, this function is total. head :: (Arity d, 1 <= d) => Vector d r -> r head = view $ element (C :: C 0) @@ -174,15 +211,16 @@ -- | Similar to 'element' above. Except that we don't have a static guarantee -- that the index is in bounds. Hence, we can only return a Traversal element' :: forall d r. Arity d => Int -> Traversal' (Vector d r) r -element' i = unV.(e (C :: C d) i) +element' i = unV.e (C :: C d) i where e :: Arity d => proxy d -> Int -> Traversal' (VectorFamily (Peano d) r) r - e _ = Fam.element' + e _ = ix {-# INLINE element' #-} -------------------------------------------------------------------------------- -- * Snoccing and consindg +-- | \( O(n) \) Prepend an element. cons :: (Arity d, Arity (d+1)) => r -> Vector d r -> Vector (d + 1) r cons x = vectorFromListUnsafe . (x:) . F.toList @@ -195,6 +233,7 @@ init :: (Arity d, Arity (d + 1)) => Vector (d + 1) r -> Vector d r init = vectorFromListUnsafe . L.init . F.toList +-- | \( O(1) \) Last element. Since the vector is non-empty, runtime bounds checks are bypassed. last :: forall d r. (KnownNat d, Arity (d + 1)) => Vector (d + 1) r -> r last = view $ element (C :: C d) diff --git a/src/Data/Geometry/Vector/VectorFamilyPeano.hs b/src/Data/Geometry/Vector/VectorFamilyPeano.hs --- a/src/Data/Geometry/Vector/VectorFamilyPeano.hs +++ b/src/Data/Geometry/Vector/VectorFamilyPeano.hs @@ -1,6 +1,19 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE UndecidableInstances #-} -module Data.Geometry.Vector.VectorFamilyPeano where +-------------------------------------------------------------------------------- +-- | +-- Module : Data.Geometry.Vector.VectorFamilyPeano +-- Copyright : (C) Frank Staals +-- License : see the LICENSE file +-- Maintainer : Frank Staals +-------------------------------------------------------------------------------- +module Data.Geometry.Vector.VectorFamilyPeano + ( ImplicitArity + , VectorFamily(VectorFamily) + , VectorFamilyF + , FromPeano + , Two + ) where import Control.Applicative (liftA2) import Control.DeepSeq @@ -10,6 +23,7 @@ import qualified Data.Foldable as F import qualified Data.Geometry.Vector.VectorFixed as FV import Data.Proxy +import Data.Functor.Classes import qualified Data.Vector.Fixed as V import Data.Vector.Fixed.Cont (PeanoNum(..), Fun(..)) import GHC.TypeLits @@ -92,6 +106,15 @@ (SS (SS (SS (SS (SS _))))) -> u == v {-# INLINE (==) #-} +instance (ImplicitArity d) => Eq1 (VectorFamily d) where + liftEq eq (VectorFamily u) (VectorFamily v) = case (implicitPeano :: SingPeano d) of + SZ -> liftEq eq u v + (SS SZ) -> liftEq eq u v + (SS (SS SZ)) -> liftEq eq u v + (SS (SS (SS SZ))) -> liftEq eq u v + (SS (SS (SS (SS SZ)))) -> liftEq eq u v + (SS (SS (SS (SS (SS _))))) -> liftEq eq u v + instance (Ord r, ImplicitArity d) => Ord (VectorFamily d r) where (VectorFamily u) `compare` (VectorFamily v) = case (implicitPeano :: SingPeano d) of SZ -> u `compare` v @@ -216,13 +239,13 @@ {-# INLINE element' #-} elem0 :: Int -> Traversal' (VectorFamily Z r) r -elem0 _ = \_ v -> pure v +elem0 _ _ = pure {-# INLINE elem0 #-} -- zero length vectors don't store any elements elem1 :: Int -> Traversal' (VectorFamily One r) r elem1 = \case - 0 -> unVF.(lens runIdentity (\_ -> Identity)) + 0 -> unVF.lens runIdentity (const Identity) _ -> \_ v -> pure v {-# INLINE elem1 #-} @@ -287,14 +310,14 @@ vectorFromList :: ImplicitArity d => [r] -> Maybe (VectorFamily d r) vectorFromList = V.fromListM -vectorFromListUnsafe :: ImplicitArity d => [r] -> VectorFamily d r -vectorFromListUnsafe = V.fromList +-- vectorFromListUnsafe :: ImplicitArity d => [r] -> VectorFamily d r +-- vectorFromListUnsafe = V.fromList --- | Get the head and tail of a vector -destruct :: (ImplicitArity d, ImplicitArity (S d)) - => VectorFamily (S d) r -> (r, VectorFamily d r) -destruct v = (head $ F.toList v, vectorFromListUnsafe . tail $ F.toList v) - -- FIXME: this implementaion of tail is not particularly nice +-- -- | Get the head and tail of a vector +-- destruct :: (ImplicitArity d, ImplicitArity (S d)) +-- => VectorFamily (S d) r -> (r, VectorFamily d r) +-- destruct v = (head $ F.toList v, vectorFromListUnsafe . tail $ F.toList v) +-- -- FIXME: this implementaion of tail is not particularly nice -- snoc :: (ImplicitArity d, ImplicitArity (S d)) -- => VectorFamily d r -> r -> VectorFamily (S d) r diff --git a/src/Data/Geometry/Vector/VectorFixed.hs b/src/Data/Geometry/Vector/VectorFixed.hs --- a/src/Data/Geometry/Vector/VectorFixed.hs +++ b/src/Data/Geometry/Vector/VectorFixed.hs @@ -1,5 +1,12 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE UndecidableInstances #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Data.Geometry.Vector.VectorFixed +-- Copyright : (C) Frank Staals +-- License : see the LICENSE file +-- Maintainer : Frank Staals +-------------------------------------------------------------------------------- module Data.Geometry.Vector.VectorFixed where import Control.DeepSeq @@ -9,6 +16,7 @@ import Data.Proxy import qualified Data.Vector.Fixed as V import Data.Vector.Fixed (Arity) +import Data.Functor.Classes import Data.Vector.Fixed.Boxed import GHC.Generics (Generic) import GHC.TypeLits @@ -46,7 +54,7 @@ element' :: forall d r. Arity d => Int -> Traversal' (Vector d r) r element' i f v | 0 <= i && i < fromInteger (natVal (C :: C d)) = f (v V.! i) - <&> \a -> (v&V.element i .~ a) + <&> \a -> v&V.element i .~ a -- Implementation based on that of Ixed Vector in Control.Lens.At | otherwise = pure v @@ -64,6 +72,11 @@ ] deriving instance (Eq r, Arity d) => Eq (Vector d r) + +-- FIXME: Upstream Eq1 instance to 'fixed-vector' package. +instance Arity d => Eq1 (Vector d) where + liftEq eq (Vector lhs) (Vector rhs) = V.and $ V.zipWith eq lhs rhs + deriving instance (Ord r, Arity d) => Ord (Vector d r) -- deriving instance Arity d => Functor (Vector d) @@ -125,7 +138,7 @@ -- | Cross product of two three-dimensional vectors cross :: Num r => Vector 3 r -> Vector 3 r -> Vector 3 r -u `cross` v = fromV3 $ (toV3 u) `L3.cross` (toV3 v) +u `cross` v = fromV3 $ toV3 u `L3.cross` toV3 v -------------------------------------------------------------------------------- diff --git a/src/Data/Geometry/VerticalRayShooting.hs b/src/Data/Geometry/VerticalRayShooting.hs new file mode 100644 --- /dev/null +++ b/src/Data/Geometry/VerticalRayShooting.hs @@ -0,0 +1,12 @@ +-------------------------------------------------------------------------------- +-- | +-- Module : Data.Geometry.VerticalRayShooting +-- Copyright : (C) Frank Staals +-- License : see the LICENSE file +-- Maintainer : Frank Staals +-------------------------------------------------------------------------------- +module Data.Geometry.VerticalRayShooting + ( module Data.Geometry.VerticalRayShooting.PersistentSweep + ) where + +import Data.Geometry.VerticalRayShooting.PersistentSweep diff --git a/src/Data/Geometry/VerticalRayShooting/PersistentSweep.hs b/src/Data/Geometry/VerticalRayShooting/PersistentSweep.hs new file mode 100644 --- /dev/null +++ b/src/Data/Geometry/VerticalRayShooting/PersistentSweep.hs @@ -0,0 +1,230 @@ +{-# Language TemplateHaskell #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Data.Geometry.VerticalRayShooting.PersistentSweep +-- Copyright : (C) Frank Staals +-- License : see the LICENSE file +-- Maintainer : Frank Staals +-------------------------------------------------------------------------------- +module Data.Geometry.VerticalRayShooting.PersistentSweep + ( VerticalRayShootingStructure(VerticalRayShootingStructure), StatusStructure + , leftMost, sweepStruct + + -- * Building the Data Structure + , verticalRayShootingStructure + -- * Querying the Data Structure + , segmentAbove, segmentAboveOrOn + , findSlab + , lookupAbove, lookupAboveOrOn, searchInSlab + , ordAt, yCoordAt + ) where + +import Algorithms.BinarySearch (binarySearchIn) +import Control.Lens hiding (contains, below) +import Data.Ext +import Data.Foldable (toList) +import Data.Geometry.Line +import Data.Geometry.LineSegment +import Data.Geometry.Point +import qualified Data.List as List +import Data.List.NonEmpty (NonEmpty(..)) +import qualified Data.List.NonEmpty as NonEmpty +import Data.Maybe (mapMaybe) +import Data.Ord (comparing) +import Data.Semigroup.Foldable +import qualified Data.Set as SS -- status struct +import qualified Data.Set.Util as SS +import qualified Data.Vector as V + + +import Data.RealNumber.Rational + +type R = RealNumber 5 +-------------------------------------------------------------------------------- + +-- | The vertical ray shooting data structure +data VerticalRayShootingStructure p e r = + VerticalRayShootingStructure { _leftMost :: r + , _sweepStruct :: V.Vector (r :+ StatusStructure p e r) + -- ^ entry (r :+ s) means that "just" left of "r" the + -- status structure is 's', i.e up to 'r' + } deriving (Show,Eq) + +type StatusStructure p e r = SS.Set (LineSegment 2 p r :+ e) + +makeLensesWith (lensRules&generateUpdateableOptics .~ False) ''VerticalRayShootingStructure + +-------------------------------------------------------------------------------- +-- * Building the DS + +-- | Given a set of \(n\) interiorly pairwise disjoint *closed* segments, +-- compute a vertical ray shooting data structure. (i.e. the +-- endpoints of the segments may coincide). +-- +-- pre: no vertical segments +-- +-- running time: \(O(n\log n)\). +-- space: \(O(n\log n)\). +verticalRayShootingStructure :: (Ord r, Fractional r, Foldable1 t) + => t (LineSegment 2 p r :+ e) + -> VerticalRayShootingStructure p e r +verticalRayShootingStructure ss = VerticalRayShootingStructure (eventX e) (sweep' events) + where + events@(e :| _) = fmap combine + . NonEmpty.groupAllWith1 eventX + . foldMap1 toEvents + . NonEmpty.fromList -- precondition guarantees that this is safe + . mapMaybe reOrient . toList + $ ss + sweep' = V.fromList . toList . sweep + + reOrient s'@(s :+ z) = case (s^.start.core.xCoord) `compare` (s^.end.core.xCoord) of + LT -> Just s' + GT -> let s'' = s&start .~ (s^.end) -- flip the segment + &end .~ (s^.start) + in Just $ s'' :+ z + EQ -> Nothing -- precondition says this won't happen, but kill + -- them anyway + +-- | Given a bunch of events happening at the same time, merge them into a single event +-- where we apply all actions. +combine :: NonEmpty (Event p e r) -> Event p e r +combine es@((x :+ _) :| _) = x :+ foldMap1 eventActions es + +-- | Given a line segment construct the two events; i.e. when we +-- insert it and when we delete it. +toEvents :: Ord r => LineSegment 2 p r :+ e -> NonEmpty (Event p e r) +toEvents s@(LineSegment' p q :+ _) = NonEmpty.fromList [ (p^.core.xCoord) :+ Insert s :| [] + , (q^.core.xCoord) :+ Delete s :| [] + ] + +---------------------------------------- + +data Action a = Insert a | Delete a deriving (Show,Eq) + +{- HLINT ignore "Avoid lambda using `infix`" -} +interpret :: Action a -> (a -> a -> Ordering) -> SS.Set a -> SS.Set a +interpret = \case + Insert s -> \cmp -> SS.insertBy cmp s + Delete s -> \cmp -> SS.deleteAllBy cmp s + + +type Event p e r = r :+ NonEmpty (Action (LineSegment 2 p r :+ e)) + +eventX :: Event p e r -> r +eventX = view core + +eventActions :: Event p e r -> NonEmpty (Action (LineSegment 2 p r :+ e)) +eventActions = view extra + +---------------------------------------- + +-- | Runs the sweep building the data structure from left to right. +sweep :: (Ord r, Fractional r) + => NonEmpty (Event p e r) -> NonEmpty (r :+ StatusStructure p e r) +sweep es = NonEmpty.fromList + . snd . List.mapAccumL h SS.empty + $ zip (toList es) (NonEmpty.tail es) + where + h ss evts = let x :+ ss' = handle ss evts in (ss',x :+ ss') + +-- | Given the current status structure (for left of the next event +-- 'l'), and the next two events (l,r); essentially defining the slab +-- between l and r, we construct the status structure for in the slab (l,r). +-- returns the right boundary and this status structure. +handle :: (Ord r, Fractional r) + => StatusStructure p e r + -> (Event p e r, Event p e r) + -> r :+ StatusStructure p e r +handle ss ( l :+ acts + , r :+ _) = let mid = (l+r)/2 + runActionAt x act = interpret act (ordAt x) + in r :+ foldr (runActionAt mid) ss (orderActs acts) + -- run deletions first + +-- | orders the actions to put insertions first and then all deletions +orderActs :: NonEmpty (Action a) -> NonEmpty (Action a) +orderActs acts = let (dels,ins) = NonEmpty.partition (\case + Delete _ -> True + Insert _ -> False + ) acts + in NonEmpty.fromList $ ins <> dels + + +-------------------------------------------------------------------------------- +-- * Querying the DS + +-- | Find the segment vertically strictly above query point q, if it +-- exists. +-- +-- \(O(\log n)\) +segmentAbove :: (Ord r, Num r) => Point 2 r -> VerticalRayShootingStructure p e r + -> Maybe (LineSegment 2 p r :+ e) +segmentAbove q ds = findSlab q ds >>= lookupAbove q + +-- | Find the segment vertically query point q, if it exists. +-- +-- \(O(\log n)\) +segmentAboveOrOn :: (Ord r, Num r) + => Point 2 r -> VerticalRayShootingStructure p e r + -> Maybe (LineSegment 2 p r :+ e) +segmentAboveOrOn q ds = findSlab q ds >>= lookupAboveOrOn q + + + +-- | Given a query point, find the (data structure of the) slab containing the query point +-- +-- \(O(\log n)\) +findSlab :: Ord r + => Point 2 r -> VerticalRayShootingStructure p e r -> Maybe (StatusStructure p e r) +findSlab q ds | q^.xCoord < ds^.leftMost = Nothing + | otherwise = view extra + <$> binarySearchIn (q `leftOf `) (ds^.sweepStruct) + where + q' `leftOf` (r :+ _) = q'^.xCoord <= r + +-------------------------------------------------------------------------------- +-- * Querying in a single slab + +-- | Finds the segment containing or above the query point 'q' +-- +-- \(O(\log n)\) +lookupAboveOrOn :: (Ord r, Num r) + => Point 2 r -> StatusStructure p e r -> Maybe (LineSegment 2 p r :+ e) +lookupAboveOrOn q = searchInSlab (not . (q `liesAbove`)) + +-- | Finds the first segment strictly above q +-- +-- \(O(\log n)\) +lookupAbove :: (Ord r, Num r) + => Point 2 r -> StatusStructure p e r -> Maybe (LineSegment 2 p r :+ e) +lookupAbove q = searchInSlab (q `liesBelow`) + +-- | generic searching function +searchInSlab :: Num r => (Line 2 r -> Bool) + -> StatusStructure p e r -> Maybe (LineSegment 2 p r :+ e) +searchInSlab p = binarySearchIn (p . supportingLine . view core) + + +---------------------------------------------------------------------------------- + +type Compare a = a -> a -> Ordering + +-- | Compare based on the y-coordinate of the intersection with the horizontal +-- line through y +ordAt :: (Fractional r, Ord r) => r -> Compare (LineSegment 2 p r :+ e) +ordAt x = comparing (yCoordAt x) + + +-- | Given an x-coordinate and a line segment that intersects the vertical line +-- through x, compute the y-coordinate of this intersection point. +-- +-- note that we will pretend that the line segment is closed, even if it is not +yCoordAt :: (Fractional r, Ord r) => r -> LineSegment 2 p r :+ e -> r +yCoordAt x (LineSegment' (Point2 px py :+ _) (Point2 qx qy :+ _) :+ _) + | px == qx = py `max` qy -- s is vertical, since by the precondition it + -- intersects we return the y-coord of the topmost + -- endpoint. + | otherwise = py + alpha * (qy - py) + where + alpha = (x - px) / (qx - px) diff --git a/src/Data/PlaneGraph.hs b/src/Data/PlaneGraph.hs --- a/src/Data/PlaneGraph.hs +++ b/src/Data/PlaneGraph.hs @@ -1,6 +1,4 @@ -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE OverloadedStrings #-} -------------------------------------------------------------------------------- -- | -- Module : Data.PlaneGraph diff --git a/src/Data/PlaneGraph/Core.hs b/src/Data/PlaneGraph/Core.hs --- a/src/Data/PlaneGraph/Core.hs +++ b/src/Data/PlaneGraph/Core.hs @@ -1,6 +1,6 @@ -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} -------------------------------------------------------------------------------- -- | -- Module : Data.PlaneGraph.Core @@ -58,33 +58,29 @@ ) where -import Control.Lens hiding (holes, holesOf, (.=)) +import Control.Lens hiding (holes, holesOf, (.=)) import Data.Aeson -import qualified Data.CircularSeq as C import Data.Ext -import qualified Data.Foldable as F -import Data.Function (on) +import qualified Data.Foldable as F +import Data.Function (on) import Data.Geometry.Box import Data.Geometry.Interval -import Data.Geometry.Line (cmpSlope, supportingLine) +import Data.Geometry.Line (cmpSlope, supportingLine) import Data.Geometry.LineSegment hiding (endPoints) import Data.Geometry.Point import Data.Geometry.Polygon import Data.Geometry.Properties -import qualified Data.List.NonEmpty as NonEmpty -import qualified Data.Map as M -import Data.Ord (comparing) -import qualified Data.PlanarGraph as PG -import Data.PlanarGraph( PlanarGraph, planarGraph, dual - , Dart(..), VertexId(..), FaceId(..), Arc(..) - , Direction(..), twin - , World(..) - , FaceId', VertexId' - , HasDataOf(..) - ) +import qualified Data.List.NonEmpty as NonEmpty +import qualified Data.Map as M +import Data.Ord (comparing) +import Data.PlanarGraph (Arc (..), Dart (..), Direction (..), FaceId (..), + FaceId', HasDataOf (..), PlanarGraph, VertexId (..), + VertexId', World (..), dual, planarGraph, twin) +import qualified Data.PlanarGraph as PG import Data.Util -import qualified Data.Vector as V -import GHC.Generics (Generic) +import qualified Data.Vector as V +import Data.Vector.Circular (CircularVector) +import GHC.Generics (Generic) -------------------------------------------------------------------------------- @@ -182,15 +178,16 @@ -> f -- ^ data inside -> f -- ^ data outside the polygon -> PlaneGraph s p () f r -fromSimplePolygon p (SimplePolygon vs) iD oD = PlaneGraph g' +fromSimplePolygon p poly iD oD = PlaneGraph g' where + vs = poly ^. outerBoundaryVector g = fromVertices p vs fData' = V.fromList [iD, oD] g' = g & PG.faceData .~ fData' -- | Constructs a planar from the given vertices fromVertices :: proxy s - -> C.CSeq (Point 2 r :+ p) + -> CircularVector (Point 2 r :+ p) -> PlanarGraph s Primal (VertexData r p) () () fromVertices _ vs = g&PG.vertexData .~ vData' where @@ -223,7 +220,7 @@ sing x = x NonEmpty.:| [] - vts = map (\(p,sp) -> (p,map (^.extra) . sortAround (ext p) <$> sp)) + vts = map (\(p,sp) -> (p,map (^.extra) . sortAround' (ext p) <$> sp)) . M.assocs $ pts -- vertex Data vxData = V.fromList . map (\(p,sp) -> VertexData p (sp^._1)) $ vts @@ -272,10 +269,10 @@ -- | Enumerate all vertices, together with their vertex data -- -- >>> mapM_ print $ vertices smallG --- (VertexId 0,VertexData {_location = Point2 [0,0], _vData = 0}) --- (VertexId 1,VertexData {_location = Point2 [2,2], _vData = 1}) --- (VertexId 2,VertexData {_location = Point2 [2,0], _vData = 2}) --- (VertexId 3,VertexData {_location = Point2 [-1,4], _vData = 3}) +-- (VertexId 0,VertexData {_location = Point2 0 0, _vData = 0}) +-- (VertexId 1,VertexData {_location = Point2 2 2, _vData = 1}) +-- (VertexId 2,VertexData {_location = Point2 2 0, _vData = 2}) +-- (VertexId 3,VertexData {_location = Point2 (-1) 4, _vData = 3}) vertices :: PlaneGraph s v e f r -> V.Vector (VertexId' s, VertexData r v) vertices = PG.vertices . _graph @@ -565,7 +562,7 @@ => (VertexId' s -> v -> m v') -> PlaneGraph s v e f r -> m (PlaneGraph s v' e f r) -traverseVertices f = itraverseOf (vertexData.itraversed) (\i -> f (VertexId i)) +traverseVertices f = itraverseOf (vertexData.itraversed) (f . VertexId) -- | Traverses the darts -- @@ -636,7 +633,7 @@ -- compare lexicographically; i.e. if same x-coord prefer the one with the -- smallest y-coord d :+ _ = V.maximumBy (cmpSlope `on` (^.extra)) - . fmap (\d' -> d' :+ (edgeSegment d' ps)^.core.to supportingLine) + . fmap (\d' -> d' :+ edgeSegment d' ps ^. core.to supportingLine) $ incidentEdges v ps -- based on the approach sketched at https://cstheory.stackexchange.com/questions/27586/finding-outer-face-in-plane-graph-embedded-planar-graph -- basically: find the leftmost vertex, find the incident edge with the largest slope @@ -650,11 +647,11 @@ -- | Reports all edges as line segments -- -- >>> mapM_ print $ edgeSegments smallG --- (Dart (Arc 0) +1,LineSegment (Closed (Point2 [0,0] :+ 0)) (Closed (Point2 [2,0] :+ 2)) :+ "0->2") --- (Dart (Arc 1) +1,LineSegment (Closed (Point2 [0,0] :+ 0)) (Closed (Point2 [2,2] :+ 1)) :+ "0->1") --- (Dart (Arc 2) +1,LineSegment (Closed (Point2 [0,0] :+ 0)) (Closed (Point2 [-1,4] :+ 3)) :+ "0->3") --- (Dart (Arc 4) +1,LineSegment (Closed (Point2 [2,2] :+ 1)) (Closed (Point2 [2,0] :+ 2)) :+ "1->2") --- (Dart (Arc 3) +1,LineSegment (Closed (Point2 [2,2] :+ 1)) (Closed (Point2 [-1,4] :+ 3)) :+ "1->3") +-- (Dart (Arc 0) +1,ClosedLineSegment (Point2 0 0 :+ 0) (Point2 2 0 :+ 2) :+ "0->2") +-- (Dart (Arc 1) +1,ClosedLineSegment (Point2 0 0 :+ 0) (Point2 2 2 :+ 1) :+ "0->1") +-- (Dart (Arc 2) +1,ClosedLineSegment (Point2 0 0 :+ 0) (Point2 (-1) 4 :+ 3) :+ "0->3") +-- (Dart (Arc 4) +1,ClosedLineSegment (Point2 2 2 :+ 1) (Point2 2 0 :+ 2) :+ "1->2") +-- (Dart (Arc 3) +1,ClosedLineSegment (Point2 2 2 :+ 1) (Point2 (-1) 4 :+ 3) :+ "1->3") edgeSegments :: PlaneGraph s v e f r -> V.Vector (Dart s, LineSegment 2 v r :+ e) edgeSegments ps = fmap withSegment . edges $ ps where @@ -683,7 +680,7 @@ -> SimplePolygon v r :+ f rawFaceBoundary i ps = pg :+ (ps^.dataOf i) where - pg = fromPoints . F.toList . fmap (\j -> ps^.graph.dataOf j.to vtxDataToExt) + pg = unsafeFromPoints . F.toList . fmap (\j -> ps^.graph.dataOf j.to vtxDataToExt) . boundaryVertices i $ ps -- | Alias for rawFace Boundary diff --git a/src/Data/PlaneGraph/IO.hs b/src/Data/PlaneGraph/IO.hs --- a/src/Data/PlaneGraph/IO.hs +++ b/src/Data/PlaneGraph/IO.hs @@ -16,7 +16,6 @@ import Data.Aeson import Data.Bifunctor import qualified Data.ByteString as B -import Data.Ext import Data.Geometry.Point import qualified Data.List as List import qualified Data.PlanarGraph.AdjRep as PGA @@ -123,11 +122,11 @@ location' = V.create $ do a <- MV.new (length vs) forM_ vs $ \(Vtx i p _ _) -> - MV.write a i $ ext p + MV.write a i p pure a -- sort the adjacencies around every vertex v sort' (Vtx v p ajs x) = Vtx v p (List.sortBy (around p) ajs) x - around p (a,_) (b,_) = ccwCmpAround (ext p) (location' V.! a) (location' V.! b) + around p (a,_) (b,_) = ccwCmpAround p (location' V.! a) (location' V.! b) -- note: since the graph is planar, there should not be -- any pairs of points for which ccwCmpAround returns EQ -- hence, no need to pick a secondary comparison diff --git a/src/Graphics/Camera.hs b/src/Graphics/Camera.hs --- a/src/Graphics/Camera.hs +++ b/src/Graphics/Camera.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE TemplateHaskell #-} -------------------------------------------------------------------------------- -- | -- Module : Graphics.Camera @@ -32,7 +31,7 @@ -- | A basic camera data type. The fields stored are: -- -- * the camera position, --- * the raw camera normal, i.e. a unit vecotr into the center of the screen, +-- * the raw camera normal, i.e. a unit vector into the center of the screen, -- * the raw view up vector indicating which side points "upwards" in the scene, -- * the viewplane depth (i.e. the distance from the camera position to the plane on which we project), -- * the near distance (everything closer than this is clipped), @@ -53,8 +52,38 @@ ---------------------------------------- -- * Field Accessor Lenses -makeLenses ''Camera +-- Lemmih: Writing out the lenses by hand so they can be documented. +-- makeLenses ''Camera +-- | Camera position. +cameraPosition :: Lens' (Camera r) (Point 3 r) +cameraPosition = lens _cameraPosition (\cam p -> cam{_cameraPosition=p}) + +-- | Raw camera normal, i.e. a unit vector into the center of the screen. +rawCameraNormal :: Lens' (Camera r) (Vector 3 r) +rawCameraNormal = lens _rawCameraNormal (\cam r -> cam{_rawCameraNormal=r}) + +-- | Raw view up vector indicating which side points "upwards" in the scene. +rawViewUp :: Lens' (Camera r) (Vector 3 r) +rawViewUp = lens _rawViewUp (\cam r -> cam{_rawViewUp=r}) + +-- | Viewplane depth (i.e. the distance from the camera position to the plane on which we project). +viewPlaneDepth :: Lens' (Camera r) r +viewPlaneDepth = lens _viewPlaneDepth (\cam v -> cam{_viewPlaneDepth=v}) + +-- | Near distance (everything closer than this is clipped). +nearDist :: Lens' (Camera r) r +nearDist = lens _nearDist (\cam n -> cam{_nearDist=n}) + +-- | Far distance (everything further away than this is clipped). +farDist :: Lens' (Camera r) r +farDist = lens _farDist (\cam f -> cam{_farDist=f}) + +-- | Screen dimensions. +screenDimensions :: Lens' (Camera r) (Vector 2 r) +screenDimensions = lens _screenDimensions (\cam d -> cam{_screenDimensions=d}) + + -------------------------------------------------------------------------------- -- * Accessor Lenses @@ -82,8 +111,7 @@ -- | Translates world coordinates into view coordinates worldToView :: Fractional r => Camera r -> Transformation 3 r -worldToView c = rotateCoordSystem c - |.| (translation $ (-1) *^ c^.cameraPosition.vector) +worldToView c = rotateCoordSystem c |.| translation ((-1) *^ c^.cameraPosition.vector) -- | Transformation into viewport coordinates toViewPort :: Fractional r => Camera r -> Transformation 3 r diff --git a/test/Algorithms/Geometry/LineSegmentIntersection/manual.ipe b/test/Algorithms/Geometry/LineSegmentIntersection/manual.ipe deleted file mode 100644 --- a/test/Algorithms/Geometry/LineSegmentIntersection/manual.ipe +++ /dev/null @@ -1,324 +0,0 @@ - - - - - - - -0 0 m --1 0.333 l --1 -0.333 l -h - - - - -0 0 m --1 0.333 l --1 -0.333 l -h - - - - -0 0 m --1 0.333 l --0.8 0 l --1 -0.333 l -h - - - - -0 0 m --1 0.333 l --0.8 0 l --1 -0.333 l -h - - - - -0.6 0 0 0.6 0 0 e -0.4 0 0 0.4 0 0 e - - - - -0.6 0 0 0.6 0 0 e - - - - - -0.5 0 0 0.5 0 0 e - - -0.6 0 0 0.6 0 0 e -0.4 0 0 0.4 0 0 e - - - - - --0.6 -0.6 m -0.6 -0.6 l -0.6 0.6 l --0.6 0.6 l -h --0.4 -0.4 m -0.4 -0.4 l -0.4 0.4 l --0.4 0.4 l -h - - - - --0.6 -0.6 m -0.6 -0.6 l -0.6 0.6 l --0.6 0.6 l -h - - - - - --0.5 -0.5 m -0.5 -0.5 l -0.5 0.5 l --0.5 0.5 l -h - - --0.6 -0.6 m -0.6 -0.6 l -0.6 0.6 l --0.6 0.6 l -h --0.4 -0.4 m -0.4 -0.4 l -0.4 0.4 l --0.4 0.4 l -h - - - - - - --0.43 -0.57 m -0.57 0.43 l -0.43 0.57 l --0.57 -0.43 l -h - - --0.43 0.57 m -0.57 -0.43 l -0.43 -0.57 l --0.57 0.43 l -h - - - - - -0 0 m --1 0.333 l --1 -0.333 l -h - - - - -0 0 m --1 0.333 l --0.8 0 l --1 -0.333 l -h - - - - -0 0 m --1 0.333 l --0.8 0 l --1 -0.333 l -h - - - - --1 0.333 m -0 0 l --1 -0.333 l - - - - -0 0 m --1 0.333 l --1 -0.333 l -h --1 0 m --2 0.333 l --2 -0.333 l -h - - - - -0 0 m --1 0.333 l --1 -0.333 l -h --1 0 m --2 0.333 l --2 -0.333 l -h - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -16 16 m -144 80 l - - -128 32 m -256 112 l - - -144 80 m -225.708 52.1085 l - - -144 80 m -148.537 86.7918 l - - -144 80 m -140.284 85.5945 l - - -137.686 70.5482 m -173.031 38.3458 l - - -89.5694 78.2992 m -186.333 44.2802 l - - -75.255 80.7127 m -75.255 24.0132 l - - -35.9103 40.8867 m -180.812 40.8867 l - - -82.6725 35.3346 m -57.1425 25.6907 l - - -40.6648 34.541 m -144.411 12.4306 l - - - diff --git a/test/Algorithms/Geometry/LineSegmentIntersection/selfIntersections.ipe b/test/Algorithms/Geometry/LineSegmentIntersection/selfIntersections.ipe deleted file mode 100644 --- a/test/Algorithms/Geometry/LineSegmentIntersection/selfIntersections.ipe +++ /dev/null @@ -1,313 +0,0 @@ - - - - - - - -0 0 m --1 0.333 l --1 -0.333 l -h - - - - -0 0 m --1 0.333 l --1 -0.333 l -h - - - - -0 0 m --1 0.333 l --0.8 0 l --1 -0.333 l -h - - - - -0 0 m --1 0.333 l --0.8 0 l --1 -0.333 l -h - - - - -0.6 0 0 0.6 0 0 e -0.4 0 0 0.4 0 0 e - - - - -0.6 0 0 0.6 0 0 e - - - - - -0.5 0 0 0.5 0 0 e - - -0.6 0 0 0.6 0 0 e -0.4 0 0 0.4 0 0 e - - - - - --0.6 -0.6 m -0.6 -0.6 l -0.6 0.6 l --0.6 0.6 l -h --0.4 -0.4 m -0.4 -0.4 l -0.4 0.4 l --0.4 0.4 l -h - - - - --0.6 -0.6 m -0.6 -0.6 l -0.6 0.6 l --0.6 0.6 l -h - - - - - --0.5 -0.5 m -0.5 -0.5 l -0.5 0.5 l --0.5 0.5 l -h - - --0.6 -0.6 m -0.6 -0.6 l -0.6 0.6 l --0.6 0.6 l -h --0.4 -0.4 m -0.4 -0.4 l -0.4 0.4 l --0.4 0.4 l -h - - - - - - --0.43 -0.57 m -0.57 0.43 l -0.43 0.57 l --0.57 -0.43 l -h - - --0.43 0.57 m -0.57 -0.43 l -0.43 -0.57 l --0.57 0.43 l -h - - - - - -0 0 m --1 0.333 l --1 -0.333 l -h - - - - -0 0 m --1 0.333 l --0.8 0 l --1 -0.333 l -h - - - - -0 0 m --1 0.333 l --0.8 0 l --1 -0.333 l -h - - - - --1 0.333 m -0 0 l --1 -0.333 l - - - - -0 0 m --1 0.333 l --1 -0.333 l -h --1 0 m --2 0.333 l --2 -0.333 l -h - - - - -0 0 m --1 0.333 l --1 -0.333 l -h --1 0 m --2 0.333 l --2 -0.333 l -h - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -96 704 m -192 816 l -352 656 l -208 640 l -336 784 l -h - - -144 592 m -336 624 l -320 544 l -240 624 l -h - - -80 624 m -32 576 l -128 576 l -h - - -64 784 m -32 752 l -32 688 l -64 672 l -144 672 l -96 688 l -80 768 l -128 768 l -112 800 l -h - - - diff --git a/test/Algorithms/Geometry/LinearProgramming/manual.ipe b/test/Algorithms/Geometry/LinearProgramming/manual.ipe deleted file mode 100644 --- a/test/Algorithms/Geometry/LinearProgramming/manual.ipe +++ /dev/null @@ -1,370 +0,0 @@ - - - - - - - -0 0 m --1 0.333 l --1 -0.333 l -h - - - - -0 0 m --1 0.333 l --1 -0.333 l -h - - - - -0 0 m --1 0.333 l --0.8 0 l --1 -0.333 l -h - - - - -0 0 m --1 0.333 l --0.8 0 l --1 -0.333 l -h - - - - -0.6 0 0 0.6 0 0 e -0.4 0 0 0.4 0 0 e - - - - -0.6 0 0 0.6 0 0 e - - - - - -0.5 0 0 0.5 0 0 e - - -0.6 0 0 0.6 0 0 e -0.4 0 0 0.4 0 0 e - - - - - --0.6 -0.6 m -0.6 -0.6 l -0.6 0.6 l --0.6 0.6 l -h --0.4 -0.4 m -0.4 -0.4 l -0.4 0.4 l --0.4 0.4 l -h - - - - --0.6 -0.6 m -0.6 -0.6 l -0.6 0.6 l --0.6 0.6 l -h - - - - - --0.5 -0.5 m -0.5 -0.5 l -0.5 0.5 l --0.5 0.5 l -h - - --0.6 -0.6 m -0.6 -0.6 l -0.6 0.6 l --0.6 0.6 l -h --0.4 -0.4 m -0.4 -0.4 l -0.4 0.4 l --0.4 0.4 l -h - - - - - - --0.43 -0.57 m -0.57 0.43 l -0.43 0.57 l --0.57 -0.43 l -h - - --0.43 0.57 m -0.57 -0.43 l -0.43 -0.57 l --0.57 0.43 l -h - - - - - -0 0 m --1 0.333 l --1 -0.333 l -h - - - - -0 0 m --1 0.333 l --0.8 0 l --1 -0.333 l -h - - - - -0 0 m --1 0.333 l --0.8 0 l --1 -0.333 l -h - - - - --1 0.333 m -0 0 l --1 -0.333 l - - - - -0 0 m --1 0.333 l --1 -0.333 l -h --1 0 m --2 0.333 l --2 -0.333 l -h - - - - -0 0 m --1 0.333 l --1 -0.333 l -h --1 0 m --2 0.333 l --2 -0.333 l -h - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -80 512 m -496 688 l - - -32 656 m -400 496 l - - -192 512 m -512 592 l - - -80 544 m -448 512 l - - -48 608 m -400 768 l - - -64 784 m -512 672 l - - -64 720 m -560 688 l - - - - - - - -46.1048 614.582 m -429.2 688.899 l - - -41.4414 741.953 m -423.596 711.062 l - - -121.985 842 m -859.993 369.865 l - - - - - - -22.6642 533.532 m -595 760.836 l - - -0 803.856 m -595 555.084 l - - --29.9681 598.468 m -794.006 675.181 l - - -411.476 809.515 m -595 311.453 l - - -0 382.909 m -437.853 1024.64 l - - --16.5606 862.606 m -411.101 433.915 l - - -95.0642 522.237 m -857.65 676.395 l - - -277.375 460.704 m -642.518 950.636 l - - -450.168 450.864 m -868.112 754.196 l - - -28.6395 500.773 m -594.217 555.411 l - - - - diff --git a/test/Algorithms/Geometry/LowerEnvelope/manual.ipe b/test/Algorithms/Geometry/LowerEnvelope/manual.ipe deleted file mode 100644 --- a/test/Algorithms/Geometry/LowerEnvelope/manual.ipe +++ /dev/null @@ -1,299 +0,0 @@ - - - - - - - -0 0 m --1 0.333 l --1 -0.333 l -h - - - - -0 0 m --1 0.333 l --1 -0.333 l -h - - - - -0 0 m --1 0.333 l --0.8 0 l --1 -0.333 l -h - - - - -0 0 m --1 0.333 l --0.8 0 l --1 -0.333 l -h - - - - -0.6 0 0 0.6 0 0 e -0.4 0 0 0.4 0 0 e - - - - -0.6 0 0 0.6 0 0 e - - - - - -0.5 0 0 0.5 0 0 e - - -0.6 0 0 0.6 0 0 e -0.4 0 0 0.4 0 0 e - - - - - --0.6 -0.6 m -0.6 -0.6 l -0.6 0.6 l --0.6 0.6 l -h --0.4 -0.4 m -0.4 -0.4 l -0.4 0.4 l --0.4 0.4 l -h - - - - --0.6 -0.6 m -0.6 -0.6 l -0.6 0.6 l --0.6 0.6 l -h - - - - - --0.5 -0.5 m -0.5 -0.5 l -0.5 0.5 l --0.5 0.5 l -h - - --0.6 -0.6 m -0.6 -0.6 l -0.6 0.6 l --0.6 0.6 l -h --0.4 -0.4 m -0.4 -0.4 l -0.4 0.4 l --0.4 0.4 l -h - - - - - - --0.43 -0.57 m -0.57 0.43 l -0.43 0.57 l --0.57 -0.43 l -h - - --0.43 0.57 m -0.57 -0.43 l -0.43 -0.57 l --0.57 0.43 l -h - - - - - -0 0 m --1 0.333 l --1 -0.333 l -h - - - - -0 0 m --1 0.333 l --0.8 0 l --1 -0.333 l -h - - - - -0 0 m --1 0.333 l --0.8 0 l --1 -0.333 l -h - - - - --1 0.333 m -0 0 l --1 -0.333 l - - - - -0 0 m --1 0.333 l --1 -0.333 l -h --1 0 m --2 0.333 l --2 -0.333 l -h - - - - -0 0 m --1 0.333 l --1 -0.333 l -h --1 0 m --2 0.333 l --2 -0.333 l -h - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -80 496 m -304 624 l - - -320 512 m -176 624 l - - -80 560 m -368 560 l - - -80 512 m -320 608 l - - - - - - diff --git a/test/Algorithms/Geometry/PolygonTriangulation/monotone.ipe b/test/Algorithms/Geometry/PolygonTriangulation/monotone.ipe deleted file mode 100644 --- a/test/Algorithms/Geometry/PolygonTriangulation/monotone.ipe +++ /dev/null @@ -1,364 +0,0 @@ - - - - - - - -0 0 m --1 0.333 l --1 -0.333 l -h - - - - -0 0 m --1 0.333 l --1 -0.333 l -h - - - - -0 0 m --1 0.333 l --0.8 0 l --1 -0.333 l -h - - - - -0 0 m --1 0.333 l --0.8 0 l --1 -0.333 l -h - - - - -0.6 0 0 0.6 0 0 e -0.4 0 0 0.4 0 0 e - - - - -0.6 0 0 0.6 0 0 e - - - - - -0.5 0 0 0.5 0 0 e - - -0.6 0 0 0.6 0 0 e -0.4 0 0 0.4 0 0 e - - - - - --0.6 -0.6 m -0.6 -0.6 l -0.6 0.6 l --0.6 0.6 l -h --0.4 -0.4 m -0.4 -0.4 l -0.4 0.4 l --0.4 0.4 l -h - - - - --0.6 -0.6 m -0.6 -0.6 l -0.6 0.6 l --0.6 0.6 l -h - - - - - --0.5 -0.5 m -0.5 -0.5 l -0.5 0.5 l --0.5 0.5 l -h - - --0.6 -0.6 m -0.6 -0.6 l -0.6 0.6 l --0.6 0.6 l -h --0.4 -0.4 m -0.4 -0.4 l -0.4 0.4 l --0.4 0.4 l -h - - - - - - --0.43 -0.57 m -0.57 0.43 l -0.43 0.57 l --0.57 -0.43 l -h - - --0.43 0.57 m -0.57 -0.43 l -0.43 -0.57 l --0.57 0.43 l -h - - - - - -0 0 m --1 0.333 l --1 -0.333 l -h - - - - -0 0 m --1 0.333 l --0.8 0 l --1 -0.333 l -h - - - - -0 0 m --1 0.333 l --0.8 0 l --1 -0.333 l -h - - - - --1 0.333 m -0 0 l --1 -0.333 l - - - - -0 0 m --1 0.333 l --1 -0.333 l -h --1 0 m --2 0.333 l --2 -0.333 l -h - - - - -0 0 m --1 0.333 l --1 -0.333 l -h --1 0 m --2 0.333 l --2 -0.333 l -h - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -176 736 m -240 688 l -240 608 l -128 576 l -64 640 l -80 720 l -128 752 l -h - - -240 608 m -64 640 l - - -64 640 m -240 688 l - - -240 688 m -80 720 l - - -80 720 m -176 736 l - - -160 384 m -352 384 l -128 176 l -224 320 l -48 400 l -h - - -384 480 m -256 416 l - - -256 416 m -192 480 l - - -320 320 m -256 320 l -224 320 l -128 240 l -64 224 l -256 192 l -h - - -256 320 m -128 240 l - - -128 240 m -320 320 l - - -256 192 m -128 240 l - - -320 320 m -256 320 l -224 320 l -128 240 l -64 224 l -256 192 l -h - - -464 160 m -336 208 l - - -336 80 m -336 208 l - - -368 80 m -336 208 l - - - diff --git a/test/Algorithms/Geometry/PolygonTriangulation/simplepolygon6.ipe b/test/Algorithms/Geometry/PolygonTriangulation/simplepolygon6.ipe deleted file mode 100644 --- a/test/Algorithms/Geometry/PolygonTriangulation/simplepolygon6.ipe +++ /dev/null @@ -1,297 +0,0 @@ - - - - - - - -0 0 m --1 0.333 l --1 -0.333 l -h - - - - -0 0 m --1 0.333 l --1 -0.333 l -h - - - - -0 0 m --1 0.333 l --0.8 0 l --1 -0.333 l -h - - - - -0 0 m --1 0.333 l --0.8 0 l --1 -0.333 l -h - - - - -0.6 0 0 0.6 0 0 e -0.4 0 0 0.4 0 0 e - - - - -0.6 0 0 0.6 0 0 e - - - - - -0.5 0 0 0.5 0 0 e - - -0.6 0 0 0.6 0 0 e -0.4 0 0 0.4 0 0 e - - - - - --0.6 -0.6 m -0.6 -0.6 l -0.6 0.6 l --0.6 0.6 l -h --0.4 -0.4 m -0.4 -0.4 l -0.4 0.4 l --0.4 0.4 l -h - - - - --0.6 -0.6 m -0.6 -0.6 l -0.6 0.6 l --0.6 0.6 l -h - - - - - --0.5 -0.5 m -0.5 -0.5 l -0.5 0.5 l --0.5 0.5 l -h - - --0.6 -0.6 m -0.6 -0.6 l -0.6 0.6 l --0.6 0.6 l -h --0.4 -0.4 m -0.4 -0.4 l -0.4 0.4 l --0.4 0.4 l -h - - - - - - --0.43 -0.57 m -0.57 0.43 l -0.43 0.57 l --0.57 -0.43 l -h - - --0.43 0.57 m -0.57 -0.43 l -0.43 -0.57 l --0.57 0.43 l -h - - - - - -0 0 m --1 0.333 l --1 -0.333 l -h - - - - -0 0 m --1 0.333 l --0.8 0 l --1 -0.333 l -h - - - - -0 0 m --1 0.333 l --0.8 0 l --1 -0.333 l -h - - - - --1 0.333 m -0 0 l --1 -0.333 l - - - - -0 0 m --1 0.333 l --1 -0.333 l -h --1 0 m --2 0.333 l --2 -0.333 l -h - - - - -0 0 m --1 0.333 l --1 -0.333 l -h --1 0 m --2 0.333 l --2 -0.333 l -h - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -80 544 m -320 527 l -208 496 l -48 432 l -16 560 l -h - - -80 544 m -208 496 l - - -208 496 m -16 560 l - - - diff --git a/test/Algorithms/Geometry/RedBlueSeparator/manual.ipe b/test/Algorithms/Geometry/RedBlueSeparator/manual.ipe deleted file mode 100644 --- a/test/Algorithms/Geometry/RedBlueSeparator/manual.ipe +++ /dev/null @@ -1,355 +0,0 @@ - - - - - - - -0 0 m --1 0.333 l --1 -0.333 l -h - - - - -0 0 m --1 0.333 l --1 -0.333 l -h - - - - -0 0 m --1 0.333 l --0.8 0 l --1 -0.333 l -h - - - - -0 0 m --1 0.333 l --0.8 0 l --1 -0.333 l -h - - - - -0.6 0 0 0.6 0 0 e -0.4 0 0 0.4 0 0 e - - - - -0.6 0 0 0.6 0 0 e - - - - - -0.5 0 0 0.5 0 0 e - - -0.6 0 0 0.6 0 0 e -0.4 0 0 0.4 0 0 e - - - - - --0.6 -0.6 m -0.6 -0.6 l -0.6 0.6 l --0.6 0.6 l -h --0.4 -0.4 m -0.4 -0.4 l -0.4 0.4 l --0.4 0.4 l -h - - - - --0.6 -0.6 m -0.6 -0.6 l -0.6 0.6 l --0.6 0.6 l -h - - - - - --0.5 -0.5 m -0.5 -0.5 l -0.5 0.5 l --0.5 0.5 l -h - - --0.6 -0.6 m -0.6 -0.6 l -0.6 0.6 l --0.6 0.6 l -h --0.4 -0.4 m -0.4 -0.4 l -0.4 0.4 l --0.4 0.4 l -h - - - - - - --0.43 -0.57 m -0.57 0.43 l -0.43 0.57 l --0.57 -0.43 l -h - - --0.43 0.57 m -0.57 -0.43 l -0.43 -0.57 l --0.57 0.43 l -h - - - - - -0 0 m --1 0.333 l --1 -0.333 l -h - - - - -0 0 m --1 0.333 l --0.8 0 l --1 -0.333 l -h - - - - -0 0 m --1 0.333 l --0.8 0 l --1 -0.333 l -h - - - - --1 0.333 m -0 0 l --1 -0.333 l - - - - -0 0 m --1 0.333 l --1 -0.333 l -h --1 0 m --2 0.333 l --2 -0.333 l -h - - - - -0 0 m --1 0.333 l --1 -0.333 l -h --1 0 m --2 0.333 l --2 -0.333 l -h - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - diff --git a/test/Algorithms/Geometry/SmallestEnclosingDisk/manual.ipe b/test/Algorithms/Geometry/SmallestEnclosingDisk/manual.ipe deleted file mode 100644 --- a/test/Algorithms/Geometry/SmallestEnclosingDisk/manual.ipe +++ /dev/null @@ -1,369 +0,0 @@ - - - - - - - -0 0 m --1 0.333 l --1 -0.333 l -h - - - - -0 0 m --1 0.333 l --1 -0.333 l -h - - - - -0 0 m --1 0.333 l --0.8 0 l --1 -0.333 l -h - - - - -0 0 m --1 0.333 l --0.8 0 l --1 -0.333 l -h - - - - -0.6 0 0 0.6 0 0 e -0.4 0 0 0.4 0 0 e - - - - -0.6 0 0 0.6 0 0 e - - - - - -0.5 0 0 0.5 0 0 e - - -0.6 0 0 0.6 0 0 e -0.4 0 0 0.4 0 0 e - - - - - --0.6 -0.6 m -0.6 -0.6 l -0.6 0.6 l --0.6 0.6 l -h --0.4 -0.4 m -0.4 -0.4 l -0.4 0.4 l --0.4 0.4 l -h - - - - --0.6 -0.6 m -0.6 -0.6 l -0.6 0.6 l --0.6 0.6 l -h - - - - - --0.5 -0.5 m -0.5 -0.5 l -0.5 0.5 l --0.5 0.5 l -h - - --0.6 -0.6 m -0.6 -0.6 l -0.6 0.6 l --0.6 0.6 l -h --0.4 -0.4 m -0.4 -0.4 l -0.4 0.4 l --0.4 0.4 l -h - - - - - - --0.43 -0.57 m -0.57 0.43 l -0.43 0.57 l --0.57 -0.43 l -h - - --0.43 0.57 m -0.57 -0.43 l -0.43 -0.57 l --0.57 0.43 l -h - - - - - -0 0 m --1 0.333 l --1 -0.333 l -h - - - - -0 0 m --1 0.333 l --0.8 0 l --1 -0.333 l -h - - - - -0 0 m --1 0.333 l --0.8 0 l --1 -0.333 l -h - - - - --1 0.333 m -0 0 l --1 -0.333 l - - - - -0 0 m --1 0.333 l --1 -0.333 l -h --1 0 m --2 0.333 l --2 -0.333 l -h - - - - -0 0 m --1 0.333 l --1 -0.333 l -h --1 0 m --2 0.333 l --2 -0.333 l -h - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -129.39 0 0 129.39 241.143 728 e - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -102.465 0 0 102.465 382.758 550.831 e - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - diff --git a/test/Data/Geometry/Polygon/Convex/convexTests.ipe b/test/Data/Geometry/Polygon/Convex/convexTests.ipe deleted file mode 100644 --- a/test/Data/Geometry/Polygon/Convex/convexTests.ipe +++ /dev/null @@ -1,308 +0,0 @@ - - - - - - - -0 0 m --1 0.333 l --1 -0.333 l -h - - - - -0 0 m --1 0.333 l --1 -0.333 l -h - - - - -0 0 m --1 0.333 l --0.8 0 l --1 -0.333 l -h - - - - -0 0 m --1 0.333 l --0.8 0 l --1 -0.333 l -h - - - - -0.6 0 0 0.6 0 0 e -0.4 0 0 0.4 0 0 e - - - - -0.6 0 0 0.6 0 0 e - - - - - -0.5 0 0 0.5 0 0 e - - -0.6 0 0 0.6 0 0 e -0.4 0 0 0.4 0 0 e - - - - - --0.6 -0.6 m -0.6 -0.6 l -0.6 0.6 l --0.6 0.6 l -h --0.4 -0.4 m -0.4 -0.4 l -0.4 0.4 l --0.4 0.4 l -h - - - - --0.6 -0.6 m -0.6 -0.6 l -0.6 0.6 l --0.6 0.6 l -h - - - - - --0.5 -0.5 m -0.5 -0.5 l -0.5 0.5 l --0.5 0.5 l -h - - --0.6 -0.6 m -0.6 -0.6 l -0.6 0.6 l --0.6 0.6 l -h --0.4 -0.4 m -0.4 -0.4 l -0.4 0.4 l --0.4 0.4 l -h - - - - - - --0.43 -0.57 m -0.57 0.43 l -0.43 0.57 l --0.57 -0.43 l -h - - --0.43 0.57 m -0.57 -0.43 l -0.43 -0.57 l --0.57 0.43 l -h - - - - - -0 0 m --1 0.333 l --1 -0.333 l -h - - - - -0 0 m --1 0.333 l --0.8 0 l --1 -0.333 l -h - - - - -0 0 m --1 0.333 l --0.8 0 l --1 -0.333 l -h - - - - --1 0.333 m -0 0 l --1 -0.333 l - - - - -0 0 m --1 0.333 l --1 -0.333 l -h --1 0 m --2 0.333 l --2 -0.333 l -h - - - - -0 0 m --1 0.333 l --1 -0.333 l -h --1 0 m --2 0.333 l --2 -0.333 l -h - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -144 720 m -224 768 l -368 672 l -320 592 l -240 544 l -112 528 l -96 640 l -h - - -224 656 m -352 784 l -416 816 l -544 800 l -576 752 l -592 720 l -592 672 l -576 640 l -544 608 l -480 560 l -400 544 l -320 544 l -272 560 l -240 608 l -h - - - diff --git a/test/Data/Geometry/Polygon/star_shaped.ipe b/test/Data/Geometry/Polygon/star_shaped.ipe deleted file mode 100644 --- a/test/Data/Geometry/Polygon/star_shaped.ipe +++ /dev/null @@ -1,339 +0,0 @@ - - - - - - - -0 0 m --1 0.333 l --1 -0.333 l -h - - - - -0 0 m --1 0.333 l --1 -0.333 l -h - - - - -0 0 m --1 0.333 l --0.8 0 l --1 -0.333 l -h - - - - -0 0 m --1 0.333 l --0.8 0 l --1 -0.333 l -h - - - - -0.6 0 0 0.6 0 0 e -0.4 0 0 0.4 0 0 e - - - - -0.6 0 0 0.6 0 0 e - - - - - -0.5 0 0 0.5 0 0 e - - -0.6 0 0 0.6 0 0 e -0.4 0 0 0.4 0 0 e - - - - - --0.6 -0.6 m -0.6 -0.6 l -0.6 0.6 l --0.6 0.6 l -h --0.4 -0.4 m -0.4 -0.4 l -0.4 0.4 l --0.4 0.4 l -h - - - - --0.6 -0.6 m -0.6 -0.6 l -0.6 0.6 l --0.6 0.6 l -h - - - - - --0.5 -0.5 m -0.5 -0.5 l -0.5 0.5 l --0.5 0.5 l -h - - --0.6 -0.6 m -0.6 -0.6 l -0.6 0.6 l --0.6 0.6 l -h --0.4 -0.4 m -0.4 -0.4 l -0.4 0.4 l --0.4 0.4 l -h - - - - - - --0.43 -0.57 m -0.57 0.43 l -0.43 0.57 l --0.57 -0.43 l -h - - --0.43 0.57 m -0.57 -0.43 l -0.43 -0.57 l --0.57 0.43 l -h - - - - - -0 0 m --1 0.333 l --1 -0.333 l -h - - - - -0 0 m --1 0.333 l --0.8 0 l --1 -0.333 l -h - - - - -0 0 m --1 0.333 l --0.8 0 l --1 -0.333 l -h - - - - --1 0.333 m -0 0 l --1 -0.333 l - - - - -0 0 m --1 0.333 l --1 -0.333 l -h --1 0 m --2 0.333 l --2 -0.333 l -h - - - - -0 0 m --1 0.333 l --1 -0.333 l -h --1 0 m --2 0.333 l --2 -0.333 l -h - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -176 752 m -208 688 l -160 624 l -288 672 l -304 752 l -256 736 l -h - - -384 784 m -448 624 l -368 576 l -512 624 l -448 704 l -560 672 l -528 576 l -592 688 l -h - - -240 544 m -80 416 l -224 336 l -320 336 l -208 416 l -352 416 l -320 320 l -480 400 l -448 496 l -320 496 l -256 464 l -h - - -176 272 m -144 80 l -400 176 l -h - - -432 272 m -480 144 l -528 192 l -496 192 l -512 240 l -480 224 l -h - - -64 656 m -32 592 l -80 640 l -144 640 l -80 656 l -96 704 l -80 672 l -h - - - diff --git a/test/Data/Geometry/arrangement.ipe b/test/Data/Geometry/arrangement.ipe deleted file mode 100644 --- a/test/Data/Geometry/arrangement.ipe +++ /dev/null @@ -1,296 +0,0 @@ - - - - - - - -0 0 m --1 0.333 l --1 -0.333 l -h - - - - -0 0 m --1 0.333 l --1 -0.333 l -h - - - - -0 0 m --1 0.333 l --0.8 0 l --1 -0.333 l -h - - - - -0 0 m --1 0.333 l --0.8 0 l --1 -0.333 l -h - - - - -0.6 0 0 0.6 0 0 e -0.4 0 0 0.4 0 0 e - - - - -0.6 0 0 0.6 0 0 e - - - - - -0.5 0 0 0.5 0 0 e - - -0.6 0 0 0.6 0 0 e -0.4 0 0 0.4 0 0 e - - - - - --0.6 -0.6 m -0.6 -0.6 l -0.6 0.6 l --0.6 0.6 l -h --0.4 -0.4 m -0.4 -0.4 l -0.4 0.4 l --0.4 0.4 l -h - - - - --0.6 -0.6 m -0.6 -0.6 l -0.6 0.6 l --0.6 0.6 l -h - - - - - --0.5 -0.5 m -0.5 -0.5 l -0.5 0.5 l --0.5 0.5 l -h - - --0.6 -0.6 m -0.6 -0.6 l -0.6 0.6 l --0.6 0.6 l -h --0.4 -0.4 m -0.4 -0.4 l -0.4 0.4 l --0.4 0.4 l -h - - - - - - --0.43 -0.57 m -0.57 0.43 l -0.43 0.57 l --0.57 -0.43 l -h - - --0.43 0.57 m -0.57 -0.43 l -0.43 -0.57 l --0.57 0.43 l -h - - - - - -0 0 m --1 0.333 l --1 -0.333 l -h - - - - -0 0 m --1 0.333 l --0.8 0 l --1 -0.333 l -h - - - - -0 0 m --1 0.333 l --0.8 0 l --1 -0.333 l -h - - - - --1 0.333 m -0 0 l --1 -0.333 l - - - - -0 0 m --1 0.333 l --1 -0.333 l -h --1 0 m --2 0.333 l --2 -0.333 l -h - - - - -0 0 m --1 0.333 l --1 -0.333 l -h --1 0 m --2 0.333 l --2 -0.333 l -h - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -80 560 m -368 800 l - - -160 768 m -416 608 l - - -80 624 m -400 672 l - - -224 576 m -336 736 l - - - diff --git a/test/Data/Geometry/arrangement.ipe.out.ipe b/test/Data/Geometry/arrangement.ipe.out.ipe deleted file mode 100644 --- a/test/Data/Geometry/arrangement.ipe.out.ipe +++ /dev/null @@ -1,247 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -0.6 0 0 0.6 0 0 e 0.4 0 0 0.4 0 0 e - - - -0.6 0 0 0.6 0 0 e - - - -0.5 0 0 0.5 0 0 e - -0.6 0 0 0.6 0 0 e 0.4 0 0 0.4 0 0 e - - - --0.6 -0.6 m 0.6 -0.6 l 0.6 0.6 l -0.6 0.6 l h --0.4 -0.4 m 0.4 -0.4 l 0.4 0.4 l -0.4 0.4 l h - - --0.6 -0.6 m 0.6 -0.6 l 0.6 0.6 l -0.6 0.6 l h - - --0.5 -0.5 m 0.5 -0.5 l 0.5 0.5 l -0.5 0.5 l h - --0.6 -0.6 m 0.6 -0.6 l 0.6 0.6 l -0.6 0.6 l h --0.4 -0.4 m 0.4 -0.4 l 0.4 0.4 l -0.4 0.4 l h - - --0.43 -0.57 m 0.57 0.43 l 0.43 0.57 l -0.57 -0.43 l h - --0.43 0.57 m 0.57 -0.43 l 0.43 -0.57 l -0.57 0.43 l h - - - -0 0 m -1.0 0.333 l -1.0 -0.333 l h - - -0 0 m -1.0 0.333 l -1.0 -0.333 l h - - -0 0 m -1.0 0.333 l -0.8 0 l -1.0 -0.333 l h - - -0 0 m -1.0 0.333 l -0.8 0 l -1.0 -0.333 l h - - -0 0 m -1.0 0.333 l -1.0 -0.333 l h - - -0 0 m -1.0 0.333 l -0.8 0 l -1.0 -0.333 l h - - -0 0 m -1.0 0.333 l -0.8 0 l -1.0 -0.333 l h - - --1.0 0.333 m 0 0 l -1.0 -0.333 l - - -0 0 m -1.0 0.333 l -1.0 -0.333 l h --1 0 m -2.0 0.333 l -2.0 -0.333 l h - - - -0 0 m -1.0 0.333 l -1.0 -0.333 l h --1 0 m -2.0 0.333 l -2.0 -0.333 l h - - - - - - -172.658536585365 637.215447154471 m -173.658536585365 638.048780487804 l -173.658536585365 638.048780487804 m -256.914285714285 707.428571428571 l -256.914285714285 707.428571428571 m -302.000073125007 745.000060937506 l -302.000073125007 745.000060937506 m -303.200073125007 746.000060937506 l -195.199902499989 746.000060937506 m -256.914285714285 707.428571428571 l -256.914285714285 707.428571428571 m -278.447793072843 693.970129329472 l -278.447793072843 693.970129329472 m -330.322580645161 661.548387096774 l -330.322580645161 661.548387096774 m -331.322580645161 660.923387096774 l -172.658536585365 637.898780487804 m -173.658536585365 638.048780487804 l -173.658536585365 638.048780487804 m -258.512437254286 650.776865588142 l -258.512437254286 650.776865588142 m -330.322580645161 661.548387096774 l -330.322580645161 661.548387096774 m -331.322580645161 661.698387096774 l -252.176396921200 637.048780487804 m -258.512437254286 650.776865588142 l -258.512437254286 650.776865588142 m -278.447793072843 693.970129329472 l -278.447793072843 693.970129329472 m -302.000073125007 745.000060937506 l -302.000073125007 745.000060937506 m -302.461611663469 746.000060937506 l -172.658536585365 746.000060937506 m -195.199902499989 746.000060937506 l -195.199902499989 746.000060937506 m -302.461611663469 746.000060937506 l -302.461611663469 746.000060937506 m -303.200073125007 746.000060937506 l -303.200073125007 746.000060937506 m -331.322580645161 746.000060937506 l -331.322580645161 746.000060937506 m -331.322580645161 661.698387096774 l -331.322580645161 661.698387096774 m -331.322580645161 660.923387096774 l -331.322580645161 660.923387096774 m -331.322580645161 637.048780487804 l -331.322580645161 637.048780487804 m -252.176396921200 637.048780487804 l -252.176396921200 637.048780487804 m -172.658536585365 637.048780487804 l -172.658536585365 637.048780487804 m -172.658536585365 637.215447154471 l -172.658536585365 637.215447154471 m -172.658536585365 637.898780487804 l -172.658536585365 637.898780487804 m -172.658536585365 746.000060937506 l -172.658536585365 637.215447154471 m -173.658536585365 638.048780487804 l -258.512437254286 650.776865588142 l -252.176396921200 637.048780487804 l -172.658536585365 637.048780487804 l -h -172.658536585365 637.898780487804 m -173.658536585365 638.048780487804 l -172.658536585365 637.215447154471 l -h -172.658536585365 746.000060937506 m -195.199902499989 746.000060937506 l -256.914285714285 707.428571428571 l -173.658536585365 638.048780487804 l -172.658536585365 637.898780487804 l -h -256.914285714285 707.428571428571 m -278.447793072843 693.970129329472 l -258.512437254286 650.776865588142 l -173.658536585365 638.048780487804 l -h -302.461611663469 746.000060937506 m -302.000073125007 745.000060937506 l -256.914285714285 707.428571428571 l -195.199902499989 746.000060937506 l -h -258.512437254286 650.776865588142 m -330.322580645161 661.548387096774 l -331.322580645161 660.923387096774 l -331.322580645161 637.048780487804 l -252.176396921200 637.048780487804 l -h -302.000073125007 745.000060937506 m -278.447793072843 693.970129329472 l -256.914285714285 707.428571428571 l -h -278.447793072843 693.970129329472 m -330.322580645161 661.548387096774 l -258.512437254286 650.776865588142 l -h -302.000073125007 745.000060937506 m -303.200073125007 746.000060937506 l -331.322580645161 746.000060937506 l -331.322580645161 661.698387096774 l -330.322580645161 661.548387096774 l -278.447793072843 693.970129329472 l -h -302.461611663469 746.000060937506 m -303.200073125007 746.000060937506 l -302.000073125007 745.000060937506 l -h -331.322580645161 661.698387096774 m -331.322580645161 660.923387096774 l -330.322580645161 661.548387096774 l -h - diff --git a/test/Data/Geometry/pointInPolygon.ipe b/test/Data/Geometry/pointInPolygon.ipe deleted file mode 100644 --- a/test/Data/Geometry/pointInPolygon.ipe +++ /dev/null @@ -1,311 +0,0 @@ - - - - - - - -0 0 m --1 0.333 l --1 -0.333 l -h - - - - -0 0 m --1 0.333 l --1 -0.333 l -h - - - - -0 0 m --1 0.333 l --0.8 0 l --1 -0.333 l -h - - - - -0 0 m --1 0.333 l --0.8 0 l --1 -0.333 l -h - - - - -0.6 0 0 0.6 0 0 e -0.4 0 0 0.4 0 0 e - - - - -0.6 0 0 0.6 0 0 e - - - - - -0.5 0 0 0.5 0 0 e - - -0.6 0 0 0.6 0 0 e -0.4 0 0 0.4 0 0 e - - - - - --0.6 -0.6 m -0.6 -0.6 l -0.6 0.6 l --0.6 0.6 l -h --0.4 -0.4 m -0.4 -0.4 l -0.4 0.4 l --0.4 0.4 l -h - - - - --0.6 -0.6 m -0.6 -0.6 l -0.6 0.6 l --0.6 0.6 l -h - - - - - --0.5 -0.5 m -0.5 -0.5 l -0.5 0.5 l --0.5 0.5 l -h - - --0.6 -0.6 m -0.6 -0.6 l -0.6 0.6 l --0.6 0.6 l -h --0.4 -0.4 m -0.4 -0.4 l -0.4 0.4 l --0.4 0.4 l -h - - - - - - --0.43 -0.57 m -0.57 0.43 l -0.43 0.57 l --0.57 -0.43 l -h - - --0.43 0.57 m -0.57 -0.43 l -0.43 -0.57 l --0.57 0.43 l -h - - - - - -0 0 m --1 0.333 l --1 -0.333 l -h - - - - -0 0 m --1 0.333 l --0.8 0 l --1 -0.333 l -h - - - - -0 0 m --1 0.333 l --0.8 0 l --1 -0.333 l -h - - - - --1 0.333 m -0 0 l --1 -0.333 l - - - - -0 0 m --1 0.333 l --1 -0.333 l -h --1 0 m --2 0.333 l --2 -0.333 l -h - - - - -0 0 m --1 0.333 l --1 -0.333 l -h --1 0 m --2 0.333 l --2 -0.333 l -h - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -208 752 m -304 688 l -224 592 l -48 736 l -h - - - - - - - - -496 736 m -432 624 l -512 608 l -h - - - - - - - - - - - - - - - - - - - diff --git a/test/Data/Geometry/pointInTriangle.ipe b/test/Data/Geometry/pointInTriangle.ipe deleted file mode 100644 --- a/test/Data/Geometry/pointInTriangle.ipe +++ /dev/null @@ -1,310 +0,0 @@ - - - - - - - -0 0 m --1 0.333 l --1 -0.333 l -h - - - - -0 0 m --1 0.333 l --1 -0.333 l -h - - - - -0 0 m --1 0.333 l --0.8 0 l --1 -0.333 l -h - - - - -0 0 m --1 0.333 l --0.8 0 l --1 -0.333 l -h - - - - -0.6 0 0 0.6 0 0 e -0.4 0 0 0.4 0 0 e - - - - -0.6 0 0 0.6 0 0 e - - - - - -0.5 0 0 0.5 0 0 e - - -0.6 0 0 0.6 0 0 e -0.4 0 0 0.4 0 0 e - - - - - --0.6 -0.6 m -0.6 -0.6 l -0.6 0.6 l --0.6 0.6 l -h --0.4 -0.4 m -0.4 -0.4 l -0.4 0.4 l --0.4 0.4 l -h - - - - --0.6 -0.6 m -0.6 -0.6 l -0.6 0.6 l --0.6 0.6 l -h - - - - - --0.5 -0.5 m -0.5 -0.5 l -0.5 0.5 l --0.5 0.5 l -h - - --0.6 -0.6 m -0.6 -0.6 l -0.6 0.6 l --0.6 0.6 l -h --0.4 -0.4 m -0.4 -0.4 l -0.4 0.4 l --0.4 0.4 l -h - - - - - - --0.43 -0.57 m -0.57 0.43 l -0.43 0.57 l --0.57 -0.43 l -h - - --0.43 0.57 m -0.57 -0.43 l -0.43 -0.57 l --0.57 0.43 l -h - - - - - -0 0 m --1 0.333 l --1 -0.333 l -h - - - - -0 0 m --1 0.333 l --0.8 0 l --1 -0.333 l -h - - - - -0 0 m --1 0.333 l --0.8 0 l --1 -0.333 l -h - - - - --1 0.333 m -0 0 l --1 -0.333 l - - - - -0 0 m --1 0.333 l --1 -0.333 l -h --1 0 m --2 0.333 l --2 -0.333 l -h - - - - -0 0 m --1 0.333 l --1 -0.333 l -h --1 0 m --2 0.333 l --2 -0.333 l -h - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -304 720 m -224 592 l -48 736 l -h - - - - - - - - -496 736 m -432 624 l -512 608 l -h - - - - - - - - - - - - - - - - - - - diff --git a/test/Data/PlaneGraph/myPlaneGraph.yaml b/test/Data/PlaneGraph/myPlaneGraph.yaml deleted file mode 100644 --- a/test/Data/PlaneGraph/myPlaneGraph.yaml +++ /dev/null @@ -1,90 +0,0 @@ -adjacencies: -- adj: - - - 4 - - [] - - - 2 - - [] - - - 1 - - [] - - - 3 - - [] - id: 0 - loc: - - 0 - - 0 - vData: - - [] - - [] - - [] - - [] -- adj: - - - 2 - - [] - - - 3 - - [] - - - 0 - - [] - id: 1 - loc: - - 10 - - 10 - vData: - - [] - - [] - - [] -- adj: - - - 1 - - [] - - - 0 - - [] - - - 4 - - [] - id: 2 - loc: - - 12 - - 10 - vData: - - [] - - [] - - [] -- adj: - - - 0 - - [] - - - 1 - - [] - id: 3 - loc: - - 13 - - 20 - vData: - - [] - - [] -- adj: - - - 2 - - [] - - - 0 - - [] - id: 4 - loc: - - 20 - - 5 - vData: - - [] - - [] -faces: -- fData: [] - incidentEdge: - - 0 - - 4 -- fData: [] - incidentEdge: - - 0 - - 2 -- fData: [] - incidentEdge: - - 0 - - 1 -- fData: [] - incidentEdge: - - 0 - - 3 diff --git a/test/Data/PlaneGraph/small.yaml b/test/Data/PlaneGraph/small.yaml deleted file mode 100644 --- a/test/Data/PlaneGraph/small.yaml +++ /dev/null @@ -1,58 +0,0 @@ -ajacencies: -- adj: - - - 2 - - 0->2 - - - 1 - - 0->1 - - - 3 - - 0->3 - id: 0 - loc: - - 0 - - 0 - vData: 0 -- adj: - - - 0 - - 1->0 - - - 2 - - 1->2 - - - 3 - - 1->3 - id: 1 - loc: - - 2 - - 2 - vData: 1 -- adj: - - - 0 - - 2->0 - - - 1 - - 2->1 - id: 2 - loc: - - 2 - - 0 - vData: 2 -- adj: - - - 0 - - 3->0 - - - 1 - - 3->1 - id: 3 - loc: - - -1 - - 4 - vData: 3 -faces: -- fData: OuterFace - incidentEdge: - - 0 - - 2 -- fData: A - incidentEdge: - - 0 - - 1 -- fData: B - incidentEdge: - - 0 - - 3 diff --git a/test/Data/PlaneGraph/testsegs.png b/test/Data/PlaneGraph/testsegs.png deleted file mode 100644 Binary files a/test/Data/PlaneGraph/testsegs.png and /dev/null differ