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/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,52 @@ +module Algorithms.Geometry.LineSegmentIntersection.Bench (benchmark) where + +import qualified Algorithms.Geometry.LineSegmentIntersection.BentleyOttmann as BONew +import qualified Algorithms.Geometry.LineSegmentIntersection.BentleyOttmannNoExt as BONoExt +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 = map ext <$> 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 (map (^.core) segs) + , bench "NoExt" $ nf BONoExt.intersections (map (^.core) segs) + , bench "New" $ nf BONew.intersections segs + ] + +sort' :: Ord r => [LineSegment 2 () r :+ ()] -> [Point 2 r] +sort' = List.sort . concatMap (\s -> s^..core.endPoints.core) diff --git a/benchmark/Algorithms/Geometry/LineSegmentIntersection/BentleyOttmannNoExt.hs b/benchmark/Algorithms/Geometry/LineSegmentIntersection/BentleyOttmannNoExt.hs new file mode 100644 --- /dev/null +++ b/benchmark/Algorithms/Geometry/LineSegmentIntersection/BentleyOttmannNoExt.hs @@ -0,0 +1,440 @@ +{-# 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.BentleyOttmannNoExt + ( intersections + , interiorIntersections + ) where + +import Algorithms.Geometry.LineSegmentIntersection.TypesNoExt +import Control.Lens hiding (contains) +import Data.Ext +import qualified Data.Foldable as F +import Data.Function (on) +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.Set as EQ -- event queue +import qualified Data.Set as SS -- status struct +import qualified Data.Set.Util as SS -- status struct +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 SS.empty + 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 isInteriorIntersection . 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, Fractional 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 + -- FIXME: this seems to keep the segments on decreasing y, increasing x. shouldn't we + -- sort them cyclically around p instead? + 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 + +-- | 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 + _ -> [] + +-------------------------------------------------------------------------------- + + +-------------------------------------------------------------------------------- +-- * The Main Sweep + +type EventQueue p r = EQ.Set (Event p r) +type StatusStructure p r = SS.Set (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 + + +-- data AssocKind b a = Start b a | End b a | Neighter a + +-- -- | test if the given segment has p as its endpoint, an construct the +-- -- appropriate associated representing that. +-- mkAssociated :: Point 2 r -> LineSegment 2 p r -> AssocKind (LineSegment 2 p r) +-- mkAssociated p s@(LineSegment a b) +-- | p == a^.unEndPoint.core = Start a s +-- | p == b^.unEndPoint.core = End b s +-- | otherwise = Neighter s + +-- -- -- | We need to report a segment as an segment for starting point p if +-- -- -- it is a closed segment starting at p, or an open segment starting +-- -- -- at p that intersects with some other segment. since the segments +-- -- -- are given in sorted order around s, we can just look at the next +-- -- -- segment to see if we should report such an open-ended segment. +-- -- shouldReportStart :: Point 2 r -> [LineSegment 2 p r] -> Associated p r +-- -- shouldReportStart p = go . map (categorize p) +-- -- where +-- -- go [] = mempty +-- -- go (s:ss) = let (xs,ys) = List.span overlapsWith s ss +-- -- in case s of +-- -- Start (Closed _) s' -> Asso + + + + + + +-- -- (s@(LineSegment a b):ss) +-- -- | p == a^.unEndPoint.core = + + +-- -- if isClosed a || overlapsWithNext ss +-- -- then Associated [s] [] [] <> go ss +-- -- -- | p == b^.unEndPoint.core = Associated [] [s] [] + + + + + + + +-- _ [] = mempty +-- go certainlyReport (s:ss) = let x = mkAssociated p s +-- x' = then x else mempty +-- in + + + +-- case shouldReport mp s of + + + + + +-- mkAssociated mp s <> go (Just s) ss + + +-- mkAsscoiated _ s@(LineSegment a b) +-- | p == a^.unEndPoint.core = if isClosed a || + + + +-- = Associated [s] [] [] +-- | p == b^.unEndPoint.core = Associated [] [s] [] +-- | otherwise = mempty + +-- _ [] = [] + + + +-- shouldReportStart _ [] = [] +-- shouldReportStart p (s:ss) = case hasStartingPoint p s of +-- Nothing -> shouldReportStart ss -- don't report the seg +-- Just (Closed _, s) -> s : shouldReportStart ss +-- Just (Open _, ) + + +-- -- [s] | isClosedStart p s = [s] +-- -- | otherwise = [] +-- -- shouldReportStart p (s:s':ss) | isStart p s = + + + +-- (s:ss) = isClosedStart p s || + + +-- shouldReport :: Eq r => Point 2 r -> [LineSegment 2 p r] -> Associated p r +-- shouldReport p = foldMap (\(s,c) -> case c of +-- Start' -> Associated [s] [] [] +-- End' -> Associated [] [s] [] +-- Neighter -> Associated [] [] [s] +-- ) +-- . overlapsOr (\(LineSegment a b,c) -> case c of +-- Start' -> isClosed a +-- End' -> isClosed b +-- Neighter -> False +-- ) (overlap p) +-- . map (\s -> (s, categorize p s)) + +overlap :: Point 2 r -> (LineSegment 2 q r, Cat) -> (LineSegment 2 q r, Cat) -> Bool +overlap p s1 s2 = go (toStart s1) (toStart s2) + where + toStart (s@(LineSegment a b),c) = case c of + Start' -> (s,False) + End' -> (LineSegment b a,False) -- flip to start + Neighter -> (s, True) + go = undefined + + + + +data Cat = Start' | End' | Neighter + +categorize p (LineSegment a b) + | p == a^.unEndPoint.core = Start' + | p == b^.unEndPoint.core = End' + | otherwise = Neighter + + + +overlapsOr :: (a -> Bool) + -> (a -> a -> Bool) + -> [a] + -> [a] +overlapsOr p q = map fst . filter snd . map (\((a,b),b') -> (a, b || b')) + . overlapsWithNeighbour (q `on` fst) + . map (\x -> (x, p x)) + +overlapsWithNeighbour :: (a -> a -> Bool) -> [a] -> [(a,Bool)] +overlapsWithNeighbour p = go0 + where + go0 = \case + [] -> [] + (x:xs) -> go x False xs + + go x b = \case + [] -> [] + (y:ys) -> let b' = p x y + in (x,b || b') : go y b' ys + + + + + + + + + +annotateReport :: (a -> Bool) -> [a] -> [(a,Bool)] +annotateReport p = map (\x -> (x, p x)) + + +overlapsWithNext' :: (a -> a -> Bool) -> [a] -> [(a,Bool)] +overlapsWithNext' p = go + where + go = \case + [] -> [] + [x] -> [(x,False)] + (x:xs@(y:_)) -> (x,p x y) : go xs + +overlapsWithPrev' :: (a -> a -> Bool) -> [a] -> [(a,Bool)] +overlapsWithPrev' p = go0 + where + go0 = \case + [] -> [] + (x:xs) -> (x,False) : go x xs + + go x = \case + [] -> [] + (y:ys) -> (y,p x y) : go y ys + + + + + + +overlapsWithNeighbour2 p = map (\((a,b),b') -> (a, b || b')) + . overlapsWithNext' (p `on` fst) + . overlapsWithPrev' p + +shouldBe :: Eq a => a -> a -> Bool +shouldBe = (==) + +propSameAsSeparate p xs = overlapsWithNeighbour p xs `shouldBe` overlapsWithNeighbour2 p xs + +test' = overlapsWithNeighbour (==) testOverlapNext +testOverlapNext = [1,2,3,3,3,5,6,6,8,10,11,34,2,2,3] + +-- reportOverlappingBy :: Eq a => (a -> Bool) -> [a] -> [a] +-- reportOverlappingBy p = \case +-- [] -> [] +-- (x:xs) -> L.span + + +-- | 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 + + + -- starts'' = shouldReport p . SS.toAscList $ newSegs + -- FIXME: we should look at the starts in-order (around p). + -- closed endpoints we should report anyway. For an open endpoint + -- we should check if it overlaps with a sucessor or predecessor + -- to see if we have to report it. + + -- I think we could get those from the 'toStatusStruct' structure below + + -- any (closed) ending segments at this event point. + closedEnds = filter (isClosedStart p) ends + + toReport = case starts' <> contains' of + (_:_:_) -> [mkIntersectionPoint p (starts' <> closedEnds) contains] + _ -> [] + + -- new status structure + ss' = before `SS.join` newSegs `SS.join` 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' = SS.lookupMin newSegs + s'' = SS.lookupMax newSegs + in catMaybes [ app (findNewEvent p) sl s' + , app (findNewEvent p) s'' sr + ] + sl = SS.lookupMax before + sr = SS.lookupMin 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 <> F.toList 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.spanAntitone (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 `SS.join` hors + -- ss { SS.nav = ordAtNav $ p^.yCoord } `SS.join` hors + where + (hors',rest) = L.partition isHorizontal xs + ss = SS.fromListBy (ordAtY $ 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 (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 + + + +type R = Rational + +seg1, seg2 :: LineSegment 2 () R +seg1 = ClosedLineSegment (ext $ Point2 0 0) (ext $ Point2 0 10) +seg2 = ClosedLineSegment (ext $ Point2 0 1) (ext $ Point2 0 5) 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,225 @@ +{-# 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.TypesNoExt( Intersections + , IntersectionPoint(..) + , Associated(..) + , mkIntersectionPoint + ) +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 + +-------------------------------------------------------------------------------- + +-- todo; use an old copy of the imports as well. + +-- | 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 isInteriorIntersection . intersections + +isInteriorIntersection :: Associated p r -> Bool +isInteriorIntersection = not . null . _interiorTo + + +-- | 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, Fractional 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 + _ -> [] + +-------------------------------------------------------------------------------- +-- * 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 + (_:_:_) -> [mkIntersectionPoint p (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 (ordAtY $ 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/LineSegmentIntersection/TypesNoExt.hs b/benchmark/Algorithms/Geometry/LineSegmentIntersection/TypesNoExt.hs new file mode 100644 --- /dev/null +++ b/benchmark/Algorithms/Geometry/LineSegmentIntersection/TypesNoExt.hs @@ -0,0 +1,200 @@ +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE TemplateHaskell #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Algorithms.Geometry.LineSegmentIntersection.Types +-- Copyright : (C) Frank Staals +-- License : see the LICENSE file +-- Maintainer : Frank Staals +-------------------------------------------------------------------------------- +module Algorithms.Geometry.LineSegmentIntersection.TypesNoExt where + +-- import Algorithms.DivideAndConquer +import Control.DeepSeq +import Control.Lens +import Data.Ext +import Data.Bifunctor +import Data.Geometry.Interval +import Data.Geometry.LineSegment +import Data.Geometry.Point +import qualified Data.Map as Map +import qualified Data.Set as Set +import Data.Ord (comparing, Down(..)) +import GHC.Generics +import Data.Vinyl.CoRec +import Data.Vinyl +import Data.Intersection + + +---------------------------------------------------------------------------------- + + +-- FIXME: What do we do when one segmnet lies *on* the other one. For +-- the short segment it should be an "around start", but then the +-- startpoints do not match. +-- +-- for the long one it's an "on" segment, but they do not intersect + + +-- | Assumes that two segments have the same start point +newtype AroundStart a = AroundStart a deriving (Show,Read,NFData) + +instance Eq r => Eq (AroundStart (LineSegment 2 p r)) where + -- | equality on endpoint + (AroundStart s) == (AroundStart s') = s^.end.core == s'^.end.core + +instance (Ord r, Num r) => Ord (AroundStart (LineSegment 2 p r)) where + -- | ccw ordered around their suposed common startpoint + (AroundStart s) `compare` (AroundStart s') = + ccwCmpAround (s^.start.core) (s^.end.core) (s'^.end.core) + +---------------------------------------- + +-- | Assumes that two segments have the same end point +newtype AroundEnd a = AroundEnd a deriving (Show,Read,NFData) + +instance Eq r => Eq (AroundEnd (LineSegment 2 p r)) where + -- | equality on endpoint + (AroundEnd s) == (AroundEnd s') = s^.start.core == s'^.start.core + +instance (Ord r, Num r) => Ord (AroundEnd (LineSegment 2 p r)) where + -- | ccw ordered around their suposed common end point + (AroundEnd s) `compare` (AroundEnd s') = + ccwCmpAround (s^.end.core) (s^.start.core) (s'^.start.core) + +-------------------------------------------------------------------------------- + +-- | Assumes that two segments intersect in a single point. +newtype AroundIntersection a = AroundIntersection a deriving (Show,Read,NFData) + +instance Eq r => Eq (AroundIntersection (LineSegment 2 p r)) where + -- | equality ignores the p type + (AroundIntersection s) == (AroundIntersection s') = first (const ()) s == first (const ()) s' + +instance (Ord r, Fractional r) => Ord (AroundIntersection (LineSegment 2 p r)) where + -- | ccw ordered around their common intersection point. + l@(AroundIntersection s) `compare` r@(AroundIntersection s') = match (s `intersect` s') $ + H (\NoIntersection -> error "AroundIntersection: segments do not intersect!") + :& H (\p -> cmpAroundP p s s') + :& H (\_ -> (squaredLength s) `compare` (squaredLength s')) + -- if s and s' just happen to be the same length but + -- intersect in different behaviour from using (==). + -- but that situation doese not satisfy the precondition + -- of aroundIntersection anyway. + :& RNil + where + squaredLength (LineSegment' a b) = squaredEuclideanDist (a^.core) (b^.core) + +-- | compare around p +cmpAroundP :: (Ord r, Num r) => Point 2 r -> LineSegment 2 p r -> LineSegment 2 p r -> Ordering +cmpAroundP p s s' = ccwCmpAround p (s^.start.core) (s'^.start.core) + + +-- seg1 = ClosedLineSegment (ext $ Point2 0 0) (ext $ Point2 0 10) +-- seg2 = ClosedLineSegment (ext $ Point2 0 0) (ext $ Point2 0 10) + + +-------------------------------------------------------------------------------- + + + +-- | The line segments that contain a given point p may either have p +-- as the endpoint or have p in their interior. +-- +-- if somehow the segment is degenerate, and p is both the start and +-- end it is reported only as the start point. +data Associated p r = + Associated { _startPointOf :: Set.Set (AroundEnd (LineSegment 2 p r)) + -- ^ segments for which the intersection point is the + -- start point (i.e. s^.start.core == p) + , _endPointOf :: Set.Set (AroundStart (LineSegment 2 p r)) + -- ^ segments for which the intersection point is the end + -- point (i.e. s^.end.core == p) + , _interiorTo :: Set.Set (AroundIntersection (LineSegment 2 p r)) + } deriving stock (Show, Read, Generic, Eq) + +makeLenses ''Associated + + + +-- | Reports whether this associated has any interior intersections +-- +-- \(O(1)\) +isInteriorIntersection :: Associated p r -> Bool +isInteriorIntersection = not . null . _interiorTo + + +-- | test if the given segment has p as its endpoint, an construct the +-- appropriate associated representing that. +-- +-- pre: p intersects the segment +mkAssociated :: (Ord r, Fractional r) + => Point 2 r -> LineSegment 2 p r -> Associated p r +mkAssociated p s@(LineSegment a b) + | p == a^.unEndPoint.core = mempty&startPointOf .~ Set.singleton (AroundEnd s) + | p == b^.unEndPoint.core = mempty&endPointOf .~ Set.singleton (AroundStart s) + | otherwise = mempty&interiorTo .~ Set.singleton (AroundIntersection s) + + +-- | test if the given segment has p as its endpoint, an construct the +-- appropriate associated representing that. +-- +-- If p is not one of the endpoints we concstruct an empty Associated! +-- +mkAssociated' :: (Ord r, Fractional r) => Point 2 r -> LineSegment 2 p r -> Associated p r +mkAssociated' p s = (mkAssociated p s)&interiorTo .~ mempty + +instance (Ord r, Fractional r) => Semigroup (Associated p r) where + (Associated ss es is) <> (Associated ss' es' is') = + Associated (ss <> ss') (es <> es') (is <> is') + +instance (Ord r, Fractional r) => Monoid (Associated p r) where + mempty = Associated mempty mempty mempty + +instance (NFData p, NFData r) => NFData (Associated p r) + +-- | For each intersection point the segments intersecting there. +type Intersections p r = Map.Map (Point 2 r) (Associated p r) + +-- | An intersection point together with all segments intersecting at +-- this point. +data IntersectionPoint p r = + IntersectionPoint { _intersectionPoint :: !(Point 2 r) + , _associatedSegs :: !(Associated p r) + } deriving (Show,Read,Eq,Generic) +makeLenses ''IntersectionPoint + +instance (NFData p, NFData r) => NFData (IntersectionPoint p r) + + +-- sameOrder :: (Ord r, Num r, Eq p) => Point 2 r +-- -> [LineSegment 2 p r] -> [LineSegment 2 p r] -> Bool +-- sameOrder c ss ss' = f ss == f ss' +-- where +-- f = map (^.extra) . sortAround' (ext c) . map (\s -> s^.end.core :+ s) + + + + +-- | Given a point p, and a bunch of segments that suposedly intersect +-- at p, correctly categorize them. +mkIntersectionPoint :: (Ord r, Fractional r) + => Point 2 r + -> [LineSegment 2 p r] -- ^ uncategorized + -> [LineSegment 2 p r] -- ^ segments we know contain p, + -> IntersectionPoint p r +mkIntersectionPoint p as cs = IntersectionPoint p $ foldMap (mkAssociated p) $ as <> cs + + -- IntersectionPoint p + -- $ Associated mempty mempty (Set.fromAscList cs') + -- <> foldMap (mkAssociated p) as + -- where + -- cs' = map AroundIntersection . List.sortBy (cmpAroundP p) $ cs + -- -- TODO: In the bentley ottman algo we already know the sorted order of the segments + -- -- so we can likely save the additional sort + + + +-- | 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 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 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,311 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +module Algorithms.Geometry.PolygonTriangulation.MakeMonotoneOld where + +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 +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 :: forall proxy s t p r. (Fractional r, Ord r) + => proxy s -> Polygon t p r + -> PlanarSubdivision s p PolygonEdgeType PolygonFaceData r +makeMonotone _ pg = let (e:es) = listEdges pg + in constructSubdivision @s 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 (ordAtY $ 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 (ordAtY $ 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 b/changelog new file mode 100644 --- /dev/null +++ b/changelog @@ -0,0 +1,199 @@ +#+STARTUP: showeverything + +* Changelog + +** 0.14 + +- Allow the associated/extra data of linesegments and intervals to + differ when testing for intersections. +- Intersection testing between line segments and rectangles +- Testing if lines and/or line segments intersect no longer requires a + Fractional constraint; Num is sufficient. However, in turn we now do + need Ord rather than just Eq. That seemed a worthwile tradeoff though. +- Cleaning up the public API by hiding several internal modules. +- Introduced the 'HasSquaredEuclideanDistance' class describing + geometry types for which we can compute the squared distance from a + point to a geometry, and added instances for some of the basic + geometries. +- Fixed a bug in computing lengths to open line segments. +- Removed some proxy arguments, in e.g. Data.Geometry.Point.coord, + rather than take a Proxy to specify which coordinate we want, use + type applications. +- Support for GHC 9.0 and 9.2 +- Better support for open-ended line segments in the Bentley Ottmann + line segment intersection algorithm. + +** 0.13 + +- Moved 'intersects' from the HasIntersectionWith class into a new + class IsIntersectableWith. This allows separate (weaker) constraints + for checking *if* geometries intersect rather than computing exact + intersections. +- New BezierSpline features. +- "Zoom to fit" transformation. +- Many fixes related to PlaneGraph/PlanarSubdivison; i.e. bugs in + which order the vertices/darts where reported when traversing a + face. The polygon representing the outer boundary now is some area + inside a bounding polygon. +- Fixed a bug in the DelaunayTriangulation. +- Preliminary implementations for updating planar subdivisions + (e.g. subdividing edges). + +** 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 +- Testing if a point lies above/below a line is now in a typeclass, + moreover there now is also an instance of this typeclass for + planes. Hence, we can test if a point in R^3 lies above or below a + plane. +- Bugfixes in the incomingEdges and outgoingEdges functions in + Planar/Plane graphs and Planar subdivisions +- Added separate data types for Sides and Corners of Rectangles. +- More functionality for working with Halfspaces +- Fixed a bug in computing the intersection of overlapping + linesegments +- PolyLine.fromPoints now returns a Maybe PolyLine rather than a + Polyine. Use fromPointsUnsafe for the old behavior. +- Interval now no longer exports its constructor. Use the provided + patterns instead. +- Added an OpenLineSegment pattern/constructor +- The corners and sides functions in Box now return specific types + representing those rather than four tuples. +- Added a BezierSpline module and data type (Thanks to Maarten). +- Added a QuadTree implementation. It can be built from a set of + points, and to represent the zeroset of some function. +- Added a Naive implementation of Convex hull in R^3. Note however + that it works only for points in general position. In particular, no + four points should be coplanar. +- Added a Data.Geometry.Directions module that defines cardinal and + InterCardinal directions. +- Added an Ellipse type (mostly so that hgeometry-ipe can read + ellipses) +- Added FunctorWithIndex, FoldableWithIndex, and TraversableWithIndex + instances for Vector, and removed specifically exporting imap; we + can now just use those functions from the Lens package. + +** 0.10 + +- renamed the smallest enclosing ball to RIC +- improved tangency finding on convex hulls/chains +- changes to how we order points in ccwCmpAround and cwCmpAround; + these will report EQ if points appear at the same angle from the + center point. +- new functions ccwCmpAroundWith and cwCmpAroundWith that allow you to + specify the direction corresponding to "zero". +- bugfixes, in particular triangulating a polygon with holes now works properly. +- removed some unused dependencies +- we are no longer depending on ghc-plugins; as a result hgeometry + now also compiles with ghcjs +- more ToJSON/FromJSON instances. +- removed the 'point2' and 'point3' functions in favor of the pattern + synonyms Point2 and Point3. + +** 0.9 + +- Implemented 2D Linear Programming using randomized incremental + construction (in \(O(n)\) expected time). This allows us to solve + the following problems + - testing starshapedness of simple polygons in expected linear time + - testing if we can separate a set of red and a set of blue points + in expected linear time. +- Data types for halfspaces + +** 0.8 + +- Compatibility with GHC 8.6 +- Added \(O(n\log n)\) time closest pair algorithm. +- Added arrangement data type +- Various Bugfixes +- Added Camera data type with some world to screen transformations. +- Additional read/show instances +- Updated some of the show instances for Ipe related types. + +** 0.7 + + +- Compatibility with GHC 8.0-8.4 +- Implemented more Algorithms and Data Structures. This includes + * Polygon triangulation +- A new implementation of PlanarSubdivision that now also supports disconnected + subdivsions. +- Performance improvements by changing to a different Vector + implementation. For low dimensional vectors (of dimension at most four) we + now essentially use the types from + [linear](https://hackage.haskell.org/package/linear), this gives significant + speedups on several small benchmarks. +- bugfixes. + +** 0.6 + +- Implemented more Algorithms and Data Structures. This includes + * Bentley-Ottmannn line-segment intersection, + * Well-Separated Pair decompositions, + * extremal point/tangents for Convex hulls, + * Minkowski sum for convex polygons, + * one dimensional segment trees, + * one dimensional interval trees, and a + * KD-tree. +- Several bug fixes, including a very stupid bug in Box +- Separate ConvexPolygon type. +- More thorough testing for some of the algorithms. +- Started work on a proper representation for planar subdivsions. This includes + a representation of planar graphs that support querying if two vertices are + connected by an edge in $O(1)$ time. +- Dropped support for GHC 7.8 + +** 0.5 + +- Implemented several algorithms, including Delaunay Triangulation, EMST, and +Douglas Peucker. +- Revamped the data types for Intersections + +** 0. + +- Major rewrite from scratch, providing much stronger type-level + guarantees. Incompatible with older versions. +- Convex Hull and Smallest enclosing disk algorithms. +- HGeometry now includes some very experimental and preliminary support for + reading and writing Ipe7 files. + +** 0.2 & 0.3 + +- Internal releases. + +** 0.1.1 + +- Fixed a bug in point on n the line segment test +- Generalized the types of inCircle, inDisc, onCircle, onDisc etc. We now need + only that the type representing precision model implements the typeclass + `Num` instead of `Floating'. + +** 0.1 + +- Initial release. diff --git a/changelog.org b/changelog.org --- a/changelog.org +++ b/changelog.org @@ -2,6 +2,103 @@ * Changelog +** 0.14 + +- Allow the associated/extra data of linesegments and intervals to + differ when testing for intersections. +- Intersection testing between line segments and rectangles +- Testing if lines and/or line segments intersect no longer requires a + Fractional constraint; Num is sufficient. However, in turn we now do + need Ord rather than just Eq. That seemed a worthwile tradeoff though. +- Cleaning up the public API by hiding several internal modules. +- Introduced the 'HasSquaredEuclideanDistance' class describing + geometry types for which we can compute the squared distance from a + point to a geometry, and added instances for some of the basic + geometries. +- Fixed a bug in computing lengths to open line segments. +- Removed some proxy arguments, in e.g. Data.Geometry.Point.coord, + rather than take a Proxy to specify which coordinate we want, use + type applications. +- Support for GHC 9.0 and 9.2 +- Better support for open-ended line segments in the Bentley Ottmann + line segment intersection algorithm. + +** 0.13 + +- Moved 'intersects' from the HasIntersectionWith class into a new + class IsIntersectableWith. This allows separate (weaker) constraints + for checking *if* geometries intersect rather than computing exact + intersections. +- New BezierSpline features. +- "Zoom to fit" transformation. +- Many fixes related to PlaneGraph/PlanarSubdivison; i.e. bugs in + which order the vertices/darts where reported when traversing a + face. The polygon representing the outer boundary now is some area + inside a bounding polygon. +- Fixed a bug in the DelaunayTriangulation. +- Preliminary implementations for updating planar subdivisions + (e.g. subdividing edges). + +** 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 +- Testing if a point lies above/below a line is now in a typeclass, + moreover there now is also an instance of this typeclass for + planes. Hence, we can test if a point in R^3 lies above or below a + plane. +- Bugfixes in the incomingEdges and outgoingEdges functions in + Planar/Plane graphs and Planar subdivisions +- Added separate data types for Sides and Corners of Rectangles. +- More functionality for working with Halfspaces +- Fixed a bug in computing the intersection of overlapping + linesegments +- PolyLine.fromPoints now returns a Maybe PolyLine rather than a + Polyine. Use fromPointsUnsafe for the old behavior. +- Interval now no longer exports its constructor. Use the provided + patterns instead. +- Added an OpenLineSegment pattern/constructor +- The corners and sides functions in Box now return specific types + representing those rather than four tuples. +- Added a BezierSpline module and data type (Thanks to Maarten). +- Added a QuadTree implementation. It can be built from a set of + points, and to represent the zeroset of some function. +- Added a Naive implementation of Convex hull in R^3. Note however + that it works only for points in general position. In particular, no + four points should be coplanar. +- Added a Data.Geometry.Directions module that defines cardinal and + InterCardinal directions. +- Added an Ellipse type (mostly so that hgeometry-ipe can read + ellipses) +- Added FunctorWithIndex, FoldableWithIndex, and TraversableWithIndex + instances for Vector, and removed specifically exporting imap; we + can now just use those functions from the Lens package. + ** 0.10 - renamed the smallest enclosing ball to RIC diff --git a/docs/Data/Geometry/PlanarSubdivision/mySubdiv.jpg b/docs/Data/Geometry/PlanarSubdivision/mySubdiv.jpg new file mode 100644 Binary files /dev/null and b/docs/Data/Geometry/PlanarSubdivision/mySubdiv.jpg differ diff --git a/docs/Data/PlaneGraph/planegraph.png b/docs/Data/PlaneGraph/planegraph.png new file mode 100644 Binary files /dev/null and b/docs/Data/PlaneGraph/planegraph.png differ diff --git a/doctests.hs b/doctests.hs --- a/doctests.hs +++ b/doctests.hs @@ -29,10 +29,11 @@ , "DeriveFunctor" , "DeriveFoldable" , "DeriveTraversable" - , "AutoDeriveTypeable" , "DeriveGeneric" , "FlexibleInstances" , "FlexibleContexts" + , "DerivingStrategies" + , "DerivingVia" ] files :: [String] @@ -63,6 +64,12 @@ , "Data.Geometry.Polygon" , "Data.Geometry.Ball" , "Data.Geometry.Box" + , "Data.Geometry.HyperPlane" -- , "Algorithms.Geometry.HiddenSurfaceRemoval.HiddenSurfaceRemoval" + , "Algorithms.Geometry.ConvexHull.Naive" + , "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,6 @@ +cabal-version: 2.4 name: hgeometry -version: 0.10.0.0 +version: 0.14 synopsis: Geometric Algorithms, Data structures, and Data types. description: HGeometry provides some basic geometry types, and geometric algorithms and @@ -8,46 +9,23 @@ asymptotic running time guarantees. Note that HGeometry is still highly experimental, don't be surprised to find bugs. homepage: https://fstaals.net/software/hgeometry -license: BSD3 +license: BSD-3-Clause license-file: LICENSE author: Frank Staals maintainer: frank@fstaals.net -- copyright: -tested-with: GHC >= 8.2 +tested-with: GHC >= 8.8 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 changelog.org -Extra-doc-files: docs/Data/PlaneGraph/small.png - -- docs/**/*.png - -cabal-version: 2.0 +Extra-doc-files: docs/**/*.png + docs/**/*.jpg source-repository head type: git location: https://github.com/noinia/hgeometry @@ -56,26 +34,32 @@ ghc-options: -O2 -Wall -fno-warn-unticked-promoted-constructors -fno-warn-type-defaults exposed-modules: + -- * Primitives; Simulating General Position + Algorithms.Geometry.SoS + Algorithms.Geometry.SoS.Symbolic + -- * Generic Geometry Data.Geometry Data.Geometry.Properties Data.Geometry.Transformation Data.Geometry.Boundary Data.Geometry.Duality + Data.Geometry.Directions -- * Basic Geometry Types Data.Geometry.Vector Data.Geometry.Vector.VectorFixed Data.Geometry.Vector.VectorFamily - Data.Geometry.Vector.VectorFamilyPeano + Data.Geometry.Matrix + -- Data.Geometry.Vector.Vinyl Data.Geometry.Interval - Data.Geometry.Interval.Util Data.Geometry.Point + Data.Geometry.Line - Data.Geometry.Line.Internal Data.Geometry.LineSegment + Data.Geometry.LineSegment.Internal Data.Geometry.SubLine Data.Geometry.HalfLine Data.Geometry.PolyLine @@ -86,10 +70,20 @@ Data.Geometry.Slab Data.Geometry.Box Data.Geometry.Box.Internal + Data.Geometry.Box.Sides + Data.Geometry.Box.Corners + Data.Geometry.Ball + Data.Geometry.Ellipse + Data.Geometry.Polygon + Data.Geometry.Polygon.Bezier + Data.Geometry.Polygon.Inflate Data.Geometry.Polygon.Convex + Data.Geometry.Polygon.Monotone + Data.Geometry.BezierSpline + -- * Geometric Data Structures Data.Geometry.IntervalTree Data.Geometry.SegmentTree @@ -99,11 +93,10 @@ Data.Geometry.PlanarSubdivision Data.Geometry.PlanarSubdivision.Raw - Data.Geometry.PlanarSubdivision.Basic - Data.Geometry.PlanarSubdivision.Merge + Data.Geometry.PlanarSubdivision.Dynamic + Data.Geometry.PlanarSubdivision.TreeRep Data.Geometry.Arrangement - Data.Geometry.Arrangement.Internal Data.Geometry.RangeTree Data.Geometry.RangeTree.Measure @@ -111,17 +104,31 @@ Data.Geometry.PrioritySearchTree + Data.Geometry.QuadTree + Data.Geometry.QuadTree.Cell + Data.Geometry.QuadTree.Quadrants + 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 - -- Algorithms.Geometry.ConvexHull.JarvisMarch + Algorithms.Geometry.ConvexHull.JarvisMarch + Algorithms.Geometry.ConvexHull.Naive Algorithms.Geometry.LowerEnvelope.DualCH - Algorithms.Geometry.SmallestEnclosingBall.Types + Algorithms.Geometry.SmallestEnclosingBall Algorithms.Geometry.SmallestEnclosingBall.RIC Algorithms.Geometry.SmallestEnclosingBall.Naive @@ -129,29 +136,36 @@ Algorithms.Geometry.DelaunayTriangulation.DivideAndConquer Algorithms.Geometry.DelaunayTriangulation.Naive + Algorithms.Geometry.PolyLineSimplification.ImaiIri 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 - + Algorithms.Geometry.PolygonTriangulation Algorithms.Geometry.PolygonTriangulation.Types 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 @@ -162,10 +176,14 @@ Algorithms.Geometry.FrechetDistance.Discrete + Algorithms.Geometry.VisibilityPolygon.Lee + Algorithms.Geometry.SSSP + Algorithms.Geometry.SSSP.Naive + Algorithms.Geometry.RayShooting.Naive + -- * Embedded Planar Graphs Data.PlaneGraph - Data.PlaneGraph.Core Data.PlaneGraph.AdjRep Data.PlaneGraph.IO @@ -174,18 +192,55 @@ Graphics.Render other-modules: + Data.Geometry.Matrix.Internal + Data.Geometry.Transformation.Internal + -- * 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.Vector.VectorFamilyPeano + + Data.Geometry.Point.Internal + Data.Geometry.Point.Orientation + Data.Geometry.Point.Quadrants + Data.Geometry.Point.Orientation.Degenerate + Data.Geometry.Point.Class + + Data.Geometry.Line.Internal + + + Data.Geometry.Interval.Util + + Algorithms.Geometry.SoS.Expr + Algorithms.Geometry.SoS.AsPoint + Algorithms.Geometry.SoS.Internal + Algorithms.Geometry.SoS.Orientation + Algorithms.Geometry.SoS.Determinant + Algorithms.Geometry.SoS.Sign + + Data.PlaneGraph.Core + + Data.Geometry.Arrangement.Internal + + Data.Geometry.PlanarSubdivision.Basic + Data.Geometry.PlanarSubdivision.Merge + -- other-extensions: build-depends: base >= 4.11 && < 5 - , hgeometry-combinatorial >= 0.10.0.0 + , hgeometry-combinatorial >= 0.13 , bifunctors >= 4.1 , bytestring >= 0.10 , containers >= 0.5.9 + -- , multi-containers >= 0.2 , dlist >= 0.7 , lens >= 4.2 , semigroupoids >= 5 @@ -198,10 +253,13 @@ , deepseq >= 1.1 , fingertree >= 0.1 , MonadRandom >= 0.5 + , random >= 1.1 , QuickCheck >= 2.5 , quickcheck-instances >= 0.3 , reflection >= 2.1 , primitive >= 0.6.3.0 + , hashable >= 1.2 + -- , singleton-typelits >= 0.1.0.0 -- , ghc-typelits-natnormalise >= 0.6 @@ -209,7 +267,11 @@ , vector >= 0.11 , data-clist >= 0.1.2.3 + , vector-circular >= 0.1.4 + , nonempty-vector >= 0.2.0.0 , text >= 1.1.1.0 + , vector-algorithms + , witherable >= 0.4 , aeson >= 1.0 , yaml >= 0.8 @@ -220,7 +282,7 @@ , hspec, QuickCheck, quickcheck-instances - hs-source-dirs: src test + hs-source-dirs: src default-language: Haskell2010 @@ -246,6 +308,8 @@ , DeriveFoldable , DeriveTraversable , DeriveGeneric + , DerivingStrategies + , DerivingVia , FlexibleInstances @@ -260,5 +324,94 @@ , 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.LineSegmentIntersection.BentleyOttmannNoExt + Algorithms.Geometry.LineSegmentIntersection.TypesNoExt + + 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 + , DerivingStrategies + , DeriveGeneric 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 @@ -16,7 +16,6 @@ import Algorithms.DivideAndConquer import Control.Arrow ((&&&)) -import Control.Lens ((^.), to) import Data.Ext import Data.Geometry.Point import Data.Geometry.Polygon @@ -29,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 @@ -73,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,6 +1,15 @@ +-------------------------------------------------------------------------------- +-- | +-- Module : Algorithms.Geometry.ConvexHull.GrahamScan +-- Copyright : (C) Frank Staals +-- License : see the LICENSE file +-- Maintainer : Frank Staals +-------------------------------------------------------------------------------- module Algorithms.Geometry.ConvexHull.GrahamScan( convexHull - , upperHull - , lowerHull + , upperHull, upperHull' + , lowerHull, lowerHull' + + , upperHullFromSorted, upperHullFromSorted' ) where import Control.Lens ((^.)) @@ -16,20 +25,61 @@ -- 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. +-- +-- Specifically. A pair of points defines an edge of the upper hull +-- iff all other points are strictly to the right of its supporting +-- line. +-- +-- Note that this definition implies that the segment may be +-- vertical. Use 'upperHull'' if such an edge should not be reported. +-- +-- running time: \(O(n\log n)\) upperHull :: (Ord r, Num r) => NonEmpty (Point 2 r :+ p) -> NonEmpty (Point 2 r :+ p) upperHull = NonEmpty.reverse . hull id --- | Computes the upper hull. The upper hull is given from left to right +-- | Computes the upper hull, making sure that there are no vertical segments. +-- +-- The upper hull is given from left to right +-- +upperHull' :: (Ord r, Num r) => NonEmpty (Point 2 r :+ p) -> NonEmpty (Point 2 r :+ p) +upperHull' = NonEmpty.reverse . dropVertical . hull id + +-- | Helper function to remove vertical segments from the hull. +-- +-- Tests if the first two points are on a vertical line, if so removes +-- the first point. +dropVertical :: Eq r => NonEmpty (Point 2 r :+ p) -> NonEmpty (Point 2 r :+ p) +dropVertical = \case + h@(_ :| []) -> h + h@(p :| (q : rest)) | p^.core.xCoord == q^.core.xCoord -> q :| rest + | otherwise -> h + + +-- | Computes the upper hull. The upper hull is given from left to right. +-- +-- Specifically. A pair of points defines an edge of the lower hull +-- iff all other points are strictly to the left of its supporting +-- line. +-- +-- Note that this definition implies that the segment may be +-- vertical. Use 'lowerHull'' if such an edge should not be reported. +-- +-- running time: \(O(n\log n)\) lowerHull :: (Ord r, Num r) => NonEmpty (Point 2 r :+ p) -> NonEmpty (Point 2 r :+ p) lowerHull = hull reverse +-- | Computes the lower hull, making sure there are no vertical +-- segments. (Note that the only such segment could be the first +-- segment). +lowerHull' :: (Ord r, Num r) => NonEmpty (Point 2 r :+ p) -> NonEmpty (Point 2 r :+ p) +lowerHull' = dropVertical . hull reverse -- | Helper function so that that can compute both the upper or the lower hull, depending -- on the function f @@ -40,11 +90,37 @@ 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 +-- | Given a sequence of points that is sorted on increasing +-- x-coordinate and decreasing y-coordinate, computes the upper +-- hull, in *right to left order*. +-- +-- Specifically. A pair of points defines an edge of the upper hull +-- iff all other points are strictly to the right of its supporting +-- line. +-- +-- +-- Note that In constrast to the 'upperHull' function, the result is +-- returned *from right to left* !!! +-- +-- running time: \(O(n)\). +upperHullFromSorted :: (Ord r, Num r) => NonEmpty (Point 2 r :+ p) -> NonEmpty (Point 2 r :+ p) +upperHullFromSorted = \case + h@(_ :| []) -> h + pts -> hull' $ NonEmpty.toList pts + +-- | Computes the upper hull from a sorted input. Removes the last vertical segment. +-- +-- +-- running time: \(O(n)\). +upperHullFromSorted' :: (Ord r, Num r) => NonEmpty (Point 2 r :+ p) -> NonEmpty (Point 2 r :+ p) +upperHullFromSorted' = dropVertical . upperHullFromSorted + + -- | Precondition: The list of input points is sorted hull' :: (Ord r, Num r) => [Point 2 r :+ p] -> NonEmpty (Point 2 r :+ p) hull' (a:b:ps) = NonEmpty.fromList $ hull'' [b,a] ps @@ -57,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 new file mode 100644 --- /dev/null +++ b/src/Algorithms/Geometry/ConvexHull/JarvisMarch.hs @@ -0,0 +1,151 @@ +-------------------------------------------------------------------------------- +-- | +-- Module : Algorithms.Geometry.ConvexHull.JarvisMarch +-- Copyright : (C) Frank Staals +-- License : see the LICENSE file +-- Maintainer : Frank Staals +-------------------------------------------------------------------------------- +module Algorithms.Geometry.ConvexHull.JarvisMarch( + convexHull + + , upperHull, upperHull' + , lowerHull, lowerHull' + , steepestCcwFrom, steepestCwFrom + ) where + +import Control.Lens ((^.)) +import Data.Bifunctor +import Data.Ext +import Data.Foldable +import Data.Geometry.Point +import Data.Geometry.Polygon +import Data.Geometry.Polygon.Convex (ConvexPolygon(..)) +import Data.Geometry.Vector +import qualified Data.List as List +import Data.List.NonEmpty (NonEmpty(..), (<|)) +import qualified Data.List.NonEmpty as NonEmpty +import Data.Ord (comparing, Down(..)) +import Data.Semigroup.Foldable + +-------------------------------------------------------------------------------- + +-- | Compute the convexhull using JarvisMarch. The resulting polygon +-- is given in clockwise order. +-- +-- running time: \(O(nh)\), where \(n\) is the number of input points +-- and \(h\) is the complexity of the hull. +convexHull :: (Ord r, Num r) + => NonEmpty (Point 2 r :+ p) -> ConvexPolygon p r +convexHull (p :| []) = ConvexPolygon . unsafeFromPoints $ [p] +convexHull pts = ConvexPolygon . unsafeFromPoints $ uh <> reverse lh + where + lh = case NonEmpty.nonEmpty (NonEmpty.init $ lowerHull pts) of + Nothing -> [] + Just (_:|lh') -> lh' + uh = toList $ upperHull pts + + -- note that fromList is afe since ps contains at least two elements + -- where + -- SP p@(c :+ _) pts = minViewBy incXdecY ps + -- takeWhile' pf (x :| xs) = x : takeWhile pf xs + +upperHull :: (Num r, Ord r) => NonEmpty (Point 2 r :+ p) -> NonEmpty (Point 2 r :+ p) +upperHull pts = repeatedly cmp steepestCwFrom s rest + where + (s:_ :+ rest) = extractMinimaBy cmp (NonEmpty.toList pts) + cmp = comparing (\(Point2 x y :+ _) -> (x, Down y)) + -- start from the topmost point that has minimum x-coord + -- also use cmp as the comparator, so that we also select the last + -- vertical segment. + +-- | Upepr hull from left to right, without any vertical segments. +upperHull' :: (Num r, Ord r) => NonEmpty (Point 2 r :+ p) -> NonEmpty (Point 2 r :+ p) +upperHull' pts = pruneVertical $ repeatedly cmp steepestCwFrom s rest + where + (s:_ :+ rest) = extractMinimaBy cmp0 (NonEmpty.toList pts) + cmp0 = comparing (\(Point2 x y :+ _) -> (x, Down y)) + -- start from the topmost point that has minimum x-coord + cmp = comparing (^.core) + -- for the rest select them in normal + -- lexicographic order, this causes the last + -- vertical segment to be ignored. + +-- | Computes the lower hull, from left to right. Includes vertical +-- segments at the start. +-- +-- running time: \(O(nh)\), where \(h\) is the complexity of the hull. +lowerHull :: (Num r, Ord r) => NonEmpty (Point 2 r :+ p) -> NonEmpty (Point 2 r :+ p) +lowerHull pts = pruneVertical $ repeatedly cmp steepestCcwFrom s rest + where + (s:_ :+ rest) = extractMinimaBy cmp0 (NonEmpty.toList pts) + cmp0 = comparing (\(Point2 x y :+ _) -> (x, Down y)) + -- start from the topmost point that has minimum x-coord + cmp = comparing (^.core) + -- for the rest of the comparions use the normal + -- lexicographic comparing order. + +-- | Jarvis March to compute the lower hull, without any vertical segments. +-- +-- +-- running time: \(O(nh)\), where \(h\) is the complexity of the hull. +lowerHull' :: (Num r, Ord r) => NonEmpty (Point 2 r :+ p) -> NonEmpty (Point 2 r :+ p) +lowerHull' pts = pruneVertical $ repeatedly cmp steepestCcwFrom s rest + where + (s:_ :+ rest) = extractMinimaBy cmp (NonEmpty.toList pts) + cmp = comparing (^.core) + + +-- | Find the next point in counter clockwise order, i.e. the point +-- 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) + +-- | 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) + +repeatedly :: (a -> a -> Ordering) -> (a -> NonEmpty a -> a) -> a -> [a] -> NonEmpty a +repeatedly cmp f = go + where + go m xs' = case NonEmpty.nonEmpty xs' of + Nothing -> m :| [] + Just xs -> let p = f m xs + in m <| go p (NonEmpty.filter (\x -> p `cmp` x == LT) xs) + + +-- | Removes the topmost vertical points, if they exist +pruneVertical :: Eq r => NonEmpty (Point 2 r :+ p) -> NonEmpty (Point 2 r :+ p) +pruneVertical = either id id . foldr1With f (\q -> Left $ q:|[]) + where + f p = \case + Left (q:|qs) | p^.core.xCoord == q^.core.xCoord -> Left (p :| qs) + | otherwise -> Right (p :| q:qs) + Right pts -> Right (p <| pts) + +-- | Foldr, but start by applying some function on the rightmost +-- element to get the starting value. +foldr1With :: Foldable1 f => (a -> b -> b) -> (a -> b) -> f a -> b +foldr1With f b = go . toNonEmpty + where + go (x :| xs) = case NonEmpty.nonEmpty xs of + Nothing -> b x + 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 +-- in the order in which they occur in the input. +-- +-- >>> extractMinimaBy compare [1,2,3,0,1,2,3,0,1,2,0,2] +-- [0,0,0] :+ [2,3,1,2,3,1,2,1,2] +extractMinimaBy :: (a -> a -> Ordering) -> [a] -> [a] :+ [a] +extractMinimaBy cmp = \case + [] -> [] :+ [] + (x:xs) -> first NonEmpty.toList $ foldr (\y (mins@(m:|_) :+ rest) -> + case m `cmp` y of + LT -> mins :+ y:rest + EQ -> (y NonEmpty.<| mins) :+ rest + GT -> (y:|[]) :+ NonEmpty.toList mins <> rest + ) ((x:|[]) :+ []) xs diff --git a/src/Algorithms/Geometry/ConvexHull/Naive.hs b/src/Algorithms/Geometry/ConvexHull/Naive.hs new file mode 100644 --- /dev/null +++ b/src/Algorithms/Geometry/ConvexHull/Naive.hs @@ -0,0 +1,98 @@ +-------------------------------------------------------------------------------- +-- | +-- 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 + + , isValidTriangle, upperHalfSpaceOf + ) where + +import Control.Lens +import Data.Ext +import Data.Foldable (toList) +import Data.Geometry.HalfSpace +import Data.Geometry.HyperPlane +import Data.Geometry.Line +import Data.Geometry.Point +import Data.Geometry.Triangle +import Data.Geometry.Vector +import Data.Intersection(intersects) +import Data.List.NonEmpty (NonEmpty(..)) +import Data.List (find) +import Data.Maybe (isNothing) +import Data.Util +-------------------------------------------------------------------------------- + +type ConvexHull d p r = [Triangle 3 p r] + +-- | Computes the lower hull without its vertical triangles. +-- +-- pre: The points are in general position. In particular, no four +-- points should be coplanar. +-- +-- running time: \(O(n^4)\) +lowerHull' :: forall r p. (Ord r, Fractional r, Show r) + => NonEmpty (Point 3 r :+ p) -> ConvexHull 3 p r +lowerHull' = filter (not . isVertical) . lowerHullAll + where + isVertical (Triangle p q r) = + ccw' (p&core %~ projectPoint) (q&core %~ projectPoint) (r&core %~ projectPoint) == CoLinear + +-- | Generates a set of triangles to be used to construct a complete +-- convex hull. In particular, it may contain vertical triangles. +-- +-- pre: The points are in general position. In particular, no four +-- points should be coplanar. +-- +-- running time: \(O(n^4)\) +lowerHullAll :: forall r p. (Ord r, Fractional r, Show r) + => NonEmpty (Point 3 r :+ p) -> ConvexHull 3 p r +lowerHullAll (toList -> pts) = let mkT (Three p q r) = Triangle p q r in + [ t | t <- mkT <$> uniqueTriplets pts, isNothing (isValidTriangle t pts) ] + + + +_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 + +overlaps :: (Fractional r, Ord r) => Triangle 3 p1 r -> Triangle 3 p2 r -> Bool +t1 `overlaps` t2 = upperHalfSpaceOf t1 == upperHalfSpaceOf t2 && False + + + +-- | Tests if this is a valid triangle for the lower envelope. That +-- is, if all point lie above the plane through these points. Returns +-- a Maybe; if the result is a Nothing the triangle is valid, if not +-- it returns a counter example. +-- +-- >>> let t = (Triangle (ext origin) (ext $ Point3 1 0 0) (ext $ Point3 0 1 0)) +-- >>> isValidTriangle t [ext $ Point3 5 5 0] +-- 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) :+ ()) +isValidTriangle :: (Num r, Ord r) + => Triangle 3 p r -> [Point 3 r :+ q] -> Maybe (Point 3 r :+ q) +isValidTriangle t = find (\a -> not $ (a^.core) `intersects` h) + where + h = upperHalfSpaceOf t + + +-- | 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}} +upperHalfSpaceOf :: (Ord r, Num r) => Triangle 3 p r -> HalfSpace 3 r +upperHalfSpaceOf (Triangle p q r) = HalfSpace h + where + h' = from3Points (p^.core) (q^.core) (r^.core) + c = p&core.zCoord -~ 1 + h = if (c^.core) `liesBelow` h' then h' else h'&normalVec %~ ((-1) *^) + a `liesBelow` plane = (a `onSideUpDown` plane) == Below 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,29 +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.CircularSeq as CS -import qualified Data.CircularList.Util as CU +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 qualified Data.Geometry.Polygon.Convex as Convex -import Data.Geometry.Polygon.Convex (ConvexPolygon(..), simplePolygon) -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.Vector as V +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.Circular.Util as CV ------------------------------------------------------------------------------- -- * Divide & Conqueror Delaunay Triangulation @@ -41,7 +52,6 @@ -- -- Rotating Right <-> rotate clockwise - -- | Computes the delaunay triangulation of a set of points. -- -- Running time: \(O(n \log n)\) @@ -72,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 @@ -98,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 @@ -137,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 @@ -151,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 @@ -198,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) @@ -232,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 @@ -246,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 @@ -254,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 @@ -270,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 @@ -283,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 @@ -295,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 +-- | 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) + +-- | 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 +-- showDT :: (Show p, Show r) => Triangulation p r -> IO () +-- showDT = mapM_ print . edgesAsPoints -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 - +-- | 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 (bimap (pts V.!) (pts V.!)) . edgesAsVertices $ t -tEdges :: Triangulation p r -> [(VertexID,VertexID)] -tEdges = concatMap (\(i,ns) -> map (i,) . filter (> i) . C.toList $ ns) +-- | 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,23 +109,22 @@ -- 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 -- -- running time: \(O(n)\). -toPlanarSubdivision :: (Ord r, Fractional r) - => proxy s -> Triangulation p r -> PlanarSubdivision s p () () r -toPlanarSubdivision px = fromPlaneGraph . toPlaneGraph px +toPlanarSubdivision :: forall s p r. (Ord r, Fractional r) + => Triangulation p r -> PlanarSubdivision s p () () r +toPlanarSubdivision = fromPlaneGraph . toPlaneGraph -- | convert the triangulation into a plane graph -- -- running time: \(O(n)\). -toPlaneGraph :: forall proxy s p r. - proxy s -> Triangulation p r -> PG.PlaneGraph s p () () r -toPlaneGraph _ tr = PG.PlaneGraph $ g&PPG.vertexData .~ vtxData +toPlaneGraph :: forall s p r. Triangulation p r -> PG.PlaneGraph s p () () r +toPlaneGraph tr = PG.PlaneGraph $ g&PPG.vertexData .~ vtxData where g = PPG.fromAdjacencyLists . V.toList . V.imap f $ tr^.neighbours - f i adj = (VertexId i, VertexId <$> adj) + f i adj = (VertexId i, C.leftElements $ VertexId <$> adj) -- report in CCW order vtxData = (\(loc :+ p) -> VertexData loc p) <$> tr^.positions 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,46 @@ +-------------------------------------------------------------------------------- +-- | +-- 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.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 @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,16 +1,35 @@ -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 + ( BooleanSweep.hasIntersections + , BO.intersections + , BO.interiorIntersections + , Intersections + , Associated(..) + , IntersectionPoint(..), mkIntersectionPoint + -- , isInteriorIntersection + , hasSelfIntersections + ) where import qualified Algorithms.Geometry.LineSegmentIntersection.BentleyOttmann as BO +import qualified Algorithms.Geometry.LineSegmentIntersection.BooleanSweep as BooleanSweep +import Algorithms.Geometry.LineSegmentIntersection.Types +import Data.Ext (ext) import Data.Geometry.LineSegment import Data.Geometry.Polygon --- Tests if there are any interior intersections. --- --- | \(O(n \log n)\) -hasInteriorIntersections :: (Ord r, Fractional r) - => [LineSegment 2 p r] -> Bool -hasInteriorIntersections = not . null . BO.interiorIntersections +import qualified Data.Map as Map --- | \(O(n \log n)\) +-- | Test if the polygon has self intersections. +-- +-- \(O(n \log n)\) hasSelfIntersections :: (Ord r, Fractional r) => Polygon t p r -> Bool -hasSelfIntersections = hasInteriorIntersections . listEdges +hasSelfIntersections = not . Map.null . BO.interiorIntersections . map ext . listEdges +-- hasSelfIntersections :: (Ord r, Num r) => Polygon t p r -> Bool +-- hasSelfIntersections = BooleanSweep.hasIntersections . listEdges +-- FIXME: fix the open/closed bug, then switch to a boolean sweep based version 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,12 +10,17 @@ -- and Ottmann. -- -------------------------------------------------------------------------------- -module Algorithms.Geometry.LineSegmentIntersection.BentleyOttmann where +module Algorithms.Geometry.LineSegmentIntersection.BentleyOttmann + ( intersections + , interiorIntersections + ) where import Algorithms.Geometry.LineSegmentIntersection.Types import Control.Lens hiding (contains) +import Data.Coerce import Data.Ext import qualified Data.Foldable as F +import Data.Function (on) import Data.Geometry.Interval import Data.Geometry.LineSegment import Data.Geometry.Point @@ -26,50 +31,105 @@ import qualified Data.Map as M import Data.Maybe import Data.Ord (Down(..), comparing) -import Data.OrdSeq (Compare) +import qualified Data.Set as EQ -- event queue import qualified Data.Set as SS -- status struct +import qualified Data.Set as Set import qualified Data.Set.Util 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 SS.empty +intersections :: forall p r e. (Ord r, Fractional r) + => [LineSegment 2 p r :+ e] -> Intersections p r e +intersections ss = fmap unflipSegs . merge $ sweep pts SS.empty where - pts = EQ.fromAscList . groupStarts . L.sort . concatMap asEventPts $ ss + pts = EQ.fromAscList . groupStarts . L.sort . concatMap (asEventPts . tagFlipped) $ 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 + => [LineSegment 2 p r :+ e] -> Intersections p r e +interiorIntersections = M.filter isInteriorIntersection . intersections +-------------------------------------------------------------------------------- +-- * Flipping and unflipping + +data Flipped = NotFlipped | Flipped deriving (Show,Eq) + +-- | Make sure the 'start' endpoint occurs before the end-endpoints in +-- terms of the sweep order. +tagFlipped :: Ord r => LineSegment 2 p r :+ e -> LineSegment 2 p r :+ (e :+ Flipped) +tagFlipped s = case (s^.core.start.core) `ordPoints` (s^.core.end.core) of + GT -> s&core %~ flipSeg + &extra %~ (:+ Flipped) + _ -> s&extra %~ (:+ NotFlipped) + +-- | Flips the segment +flipSeg :: LineSegment d p r -> LineSegment d p r +flipSeg seg = seg&start .~ (seg^.end) + &end .~ (seg^.start) + +-- | Unflips the segments in an associated. +unflipSegs :: (Fractional r, Ord r) + => Associated p r (e :+ Flipped) -> Associated p r e +unflipSegs (Associated ss es is) = + Associated (dropFlipped ss1 <> unflipSegs' es') + (dropFlipped es1 <> unflipSegs' ss') + (dropFlipped is1 <> unflipSegs' is') + where + (ss',ss1) = Set.partition (\(AroundEnd s) -> isFlipped s) ss + (es',es1) = Set.partition (\(AroundStart s) -> isFlipped s) es + (is',is1) = Set.partition (\(AroundIntersection s) -> isFlipped s) is + + isFlipped s = Flipped == s^.extra.extra + + -- | For segments that are not acutally flipped, we can just drop the flipped bit + dropFlipped :: Functor f + => Set.Set (f (LineSegment 2 p r :+ (e :+ Flipped))) + -> Set.Set (f (LineSegment 2 p r :+ e)) + dropFlipped = Set.mapMonotonic (fmap dropFlip) + + -- For flipped segs we unflip them (and appropriately coerce the + -- so that they remain in the same order. I.e. if they were sorted + -- around the start point they are now sorted around the endpoint. + unflipSegs' :: ( Functor f + , Coercible (f (LineSegment 2 p r :+ e)) (g (LineSegment 2 p r :+ e)) + ) + => Set.Set (f (LineSegment 2 p r :+ (e :+ Flipped))) + -> Set.Set (g (LineSegment 2 p r :+ e)) + unflipSegs' = Set.mapMonotonic (coerce . fmap unflip) + + unflip (s :+ (e :+ _)) = flipSeg s :+ e + dropFlip (s :+ (e :+ _)) = s :+ e + +-------------------------------------------------------------------------------- + -- | 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)] +asEventPts :: LineSegment 2 p r :+ e -> [Event p r e] +asEventPts s = [ Event (s^.core.start.core) (Start $ s :| []) + , Event (s^.core.end.core) (End s) + ] -- | Group the segments with the intersection points -merge :: Ord r => [IntersectionPoint p r] -> Intersections p r +merge :: (Ord r, Fractional r) => [IntersectionPoint p r e] -> Intersections p r e 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 :: Eq r => [Event p r e] -> [Event p r e] 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') + -- FIXME: this seems to keep the segments on decreasing y, increasing x. shouldn't we + -- sort them cyclically around p instead? + ss = let (x:|xs) = s + in x :| (xs ++ concatMap startSegs ss') sameStart (Event q (Start _)) = p == q sameStart _ = False @@ -94,84 +154,68 @@ (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) +data Event p r e = Event { eventPoint :: !(Point 2 r) + , eventType :: !(EventType (LineSegment 2 p r :+ e)) + } deriving (Show,Eq) -instance Ord r => Ord (Event p r) where +instance Ord r => Ord (Event p r e) 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 :: Event p r e -> [LineSegment 2 p r :+ e] 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.Set (LineSegment 2 p r) +type EventQueue p r e = EQ.Set (Event p r e) +type StatusStructure p r e = SS.Set (LineSegment 2 p r :+ e) -- | Run the sweep handling all events sweep :: (Ord r, Fractional r) - => EventQueue p r -> StatusStructure p r -> [IntersectionPoint p r] + => EventQueue p r e -> StatusStructure p r e -> [IntersectionPoint p r e] 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 :: forall r p e. (Ord r, Fractional r) + => Event p r e -> EventQueue p r e -> StatusStructure p r e + -> [IntersectionPoint p r e] 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] + -- starts' = filter (isClosedStart p) starts + starts' = shouldReport p $ SS.toAscList newSegs + + -- If we just inserted open-ended segments that start here, then + -- don't consider them to be "contained" segments. + pureContains = filter (\(LineSegment s _ :+ _) -> + not $ isOpen s && p == s^.unEndPoint.core) contains + + -- any (closed) ending segments at this event point. + closedEnds = filter (\(LineSegment _ e' :+ _) -> isClosed e') ends + + toReport = case starts' <> closedEnds <> pureContains of + (_:_:_) -> [mkIntersectionPoint p (starts' <> closedEnds) pureContains] _ -> [] -- new status structure ss' = before `SS.join` newSegs `SS.join` after newSegs = toStatusStruct p $ starts ++ contains + -- the new eeventqueue eq' = foldr EQ.insert eq es -- the new events: @@ -186,54 +230,145 @@ app f x y = do { x' <- x ; y' <- y ; f x' y'} +-- | given the starting point p, and the segments that either start in +-- p, or continue in p, in left to right order along a line just +-- epsilon below p, figure out which segments we should report as +-- intersecting at p. +-- +-- in partcular; those that: +-- - have a closed endpoint at p +-- - those that have an open endpoint at p and have an intersection +-- with a segment eps below p. Those segments thus overlap wtih +-- their predecessor or successor in the cyclic order. +shouldReport :: (Ord r, Num r) + => Point 2 r -> [LineSegment 2 p r :+ e] -> [LineSegment 2 p r :+ e] +shouldReport _ = overlapsOr (\(LineSegment s _ :+ _) -> isClosed s) + (\(s :+ _) (s2 :+ _) -> s `intersects` s2) + -- | 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) + => Point 2 r -> StatusStructure p r e + -> (StatusStructure p r e, [LineSegment 2 p r :+ e], StatusStructure p r e) extractContains p ss = (before, F.toList mid1 <> F.toList mid2, after) where - (before, mid1, after') = SS.splitOn (xCoordAt $ p^.yCoord) (p^.xCoord) ss + (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 . view core) after' + xCoordAt' y sa = xCoordAt y (sa^.core) -- | 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 + => Point 2 r -> [LineSegment 2 p r :+ e] -> StatusStructure p r e toStatusStruct p xs = ss `SS.join` hors -- ss { SS.nav = ordAtNav $ p^.yCoord } `SS.join` hors where (hors',rest) = L.partition isHorizontal xs - ss = SS.fromListBy (ordAt $ maxY xs) rest + ss = SS.fromListBy (ordAtY' $ maxY xs) rest hors = SS.fromListBy (comparing rightEndpoint) hors' - isHorizontal s = s^.start.core.yCoord == s^.end.core.yCoord + isHorizontal s = s^.core.start.core.yCoord == s^.core.end.core.yCoord + ordAtY' q sa sb = ordAtY q (sa^.core) (sb^.core) + -- 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]) + . concatMap (\s -> [s^.core.start.core.yCoord,s^.core.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) +rightEndpoint :: Ord r => LineSegment 2 p r :+ e -> r +rightEndpoint s = (s^.core.start.core.xCoord) `max` (s^.core.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] +endsAt :: Eq r => Point 2 r -> LineSegment 2 p r :+ e -> Bool +endsAt p (LineSegment' _ (b :+ _) :+ _) = p == 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 + => Point 2 r -> LineSegment 2 p r :+ e -> LineSegment 2 p r :+ e + -> Maybe (Event p r e) +findNewEvent p l r = match ((l^.core) `intersect` (r^.core)) $ + 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 + + + +type R = Rational + +seg1, seg2 :: LineSegment 2 () R +seg1 = ClosedLineSegment (ext $ Point2 0 0) (ext $ Point2 0 10) +seg2 = ClosedLineSegment (ext $ Point2 0 1) (ext $ Point2 0 5) + + + +-------------------------------------------------------------------------------- +-- * + +-- | Given a predicate p on elements, and a predicate q on +-- (neighbouring) pairs of elements, filter the elements that satisfy +-- p, or together with one of their neighbours satisfy q. +overlapsOr :: (a -> Bool) + -> (a -> a -> Bool) + -> [a] + -> [a] +overlapsOr p q = map fst . filter snd . map (\((a,b),b') -> (a, b || b')) + . overlapsWithNeighbour (q `on` fst) + . map (\x -> (x, p x)) + +-- | Given a predicate, test and a list, annotate each element whether +-- it, together with one of its neighbors satisifies the predicate. +overlapsWithNeighbour :: (a -> a -> Bool) -> [a] -> [(a,Bool)] +overlapsWithNeighbour p = go0 + where + go0 = \case + [] -> [] + (x:xs) -> go x False xs + + go x b = \case + [] -> [] + (y:ys) -> let b' = p x y + in (x,b || b') : go y b' ys + +-- annotateReport :: (a -> Bool) -> [a] -> [(a,Bool)] +-- annotateReport p = map (\x -> (x, p x)) + +overlapsWithNext' :: (a -> a -> Bool) -> [a] -> [(a,Bool)] +overlapsWithNext' p = go + where + go = \case + [] -> [] + [x] -> [(x,False)] + (x:xs@(y:_)) -> (x,p x y) : go xs + +overlapsWithPrev' :: (a -> a -> Bool) -> [a] -> [(a,Bool)] +overlapsWithPrev' p = go0 + where + go0 = \case + [] -> [] + (x:xs) -> (x,False) : go x xs + + go x = \case + [] -> [] + (y:ys) -> (y,p x y) : go y ys + + +overlapsWithNeighbour2 p = map (\((a,b),b') -> (a, b || b')) + . overlapsWithNext' (p `on` fst) + . overlapsWithPrev' p + +shouldBe :: Eq a => a -> a -> Bool +shouldBe = (==) + +propSameAsSeparate p xs = overlapsWithNeighbour p xs `shouldBe` overlapsWithNeighbour2 p xs + +test' = overlapsWithNeighbour (==) testOverlapNext +testOverlapNext = [1,2,3,3,3,5,6,6,8,10,11,34,2,2,3] 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,190 @@ +{-# 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 sets of line segments intersect. +-- +-- Shamos and Hoey. +-- +-------------------------------------------------------------------------------- +module Algorithms.Geometry.LineSegmentIntersection.BooleanSweep + ( hasIntersections + ) where + +import Control.Lens hiding (contains) +import Data.Ext +import Data.Geometry.Interval +import Data.Geometry.LineSegment +import Data.Geometry.Point + +import Data.Intersection +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 +import Data.Geometry.Polygon + +-------------------------------------------------------------------------------- + +-- | Tests if there are any intersections. +-- +-- \(O(n\log n)\) +hasIntersections :: (Ord r, Num r) + => [LineSegment 2 p r :+ e] -> 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 :+ e -> [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) + deriving (Show) + +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 (intersects <$> 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 + + -- Check whether the endpoint is contained in one of the existing + -- segments. The only segments that could qualify are the ones in + -- 'contains'. Hence check only those. Note that it is not + -- sufficient just to check whether 'contains' is empty or not, + -- since there may be segments whose endpoint is open and coincides with p. + endOverlap = isClosed startPoint && any (p `intersects`) contains + + overlaps = + or [ fromMaybe False (intersects l <$> sl) + , fromMaybe False (intersects 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 + +-- -- | Given two segments test if they intersect. Why don't we simply use 'intersect' +-- 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) `intersects` b) || +-- (isClosed aEnd && (aEnd^.unEndPoint.core) `intersects` 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) + + +bug' = hasIntersections $ map ext $ listEdges bug + +bug :: SimplePolygon () Int +bug = fromPoints . map ext $ [ + Point2 144 592 + , Point2 336 624 + , Point2 320 544 + , Point2 240 624 + ] + +s1, s2 :: LineSegment 2 () Int +s1 = read "LineSegment (Closed (Point2 240 620 :+ ())) (Open (Point2 320 544 :+ ()))" +s2 = read "LineSegment (Closed (Point2 144 592 :+ ())) (Open (Point2 336 624 :+ ()))" + +tr s x = traceShow (s <> " : ", x) x + +edges' :: [LineSegment 2 () Int] +edges' = [ LineSegment (Closed (Point2 240 624 :+ ())) (Open (Point2 320 544 :+ ())) +-- , LineSegment (Closed (Point2 320 544 :+ ())) (Open (Point2 336 624 :+ ())) + , LineSegment (Closed (Point2 336 624 :+ ())) (Open (Point2 144 592 :+ ())) + , LineSegment (Closed (Point2 144 592 :+ ())) (Open (Point2 240 624 :+ ())) + ] + +-- ah, I guess it selects the wrong predecessor/successor seg, since they overlap at the endpoint. 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,52 +1,58 @@ {-# 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 +import Control.Lens((^.)) import Data.Ext -import Data.Geometry.Interval +-- import Data.Geometry.Interval import Data.Geometry.LineSegment import Data.Geometry.Point import Data.Geometry.Properties import qualified Data.Map as M +import Data.Util import Data.Vinyl import Data.Vinyl.CoRec +import qualified Data.List as List +-------------------------------------------------------------------------------- -- | Compute all intersections (naively) -- -- \(O(n^2)\) -intersections :: forall r p. (Ord r, Fractional r) - => [LineSegment 2 p r] -> Intersections p r -intersections = foldr collect mempty . pairs +intersections :: forall r p e. (Ord r, Fractional r) + => [LineSegment 2 p r :+ e] -> Intersections p r e +intersections = foldr collect mempty . uniquePairs -- | Test if the two segments intersect, and if so add the segment to the map -collect :: (Ord r, Fractional r) - => (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]) +collect :: (Ord r, Fractional r) + => Two (LineSegment 2 p r :+ e) + -> Intersections p r e -> Intersections p r e +collect (Two s s') m = match ((s^.core) `intersect` (s'^.core)) $ + H (\NoIntersection -> m) + :& H (\p -> handlePoint s s' p m) + :& H (\s'' -> handlePoint s s' (topEndPoint s'') m) :& RNil --- | Add s and s' to the map with key p -handlePoint :: Ord r - => LineSegment 2 p r -> LineSegment 2 p r -> Point 2 r - -> Intersections p r -> Intersections p r -handlePoint s s' p = addTo p s . addTo p s' --- | figure out which map to add the point to -addTo :: Ord r => Point 2 r -> LineSegment 2 p r - -> Intersections p r -> Intersections p r -addTo p s - | p `isEndPointOf` s = M.insertWith (<>) p (associated [s] []) - | otherwise = M.insertWith (<>) p (associated [] [s]) +topEndPoint :: Ord r => LineSegment 2 p r -> Point 2 r +topEndPoint (LineSegment' (a :+ _) (b :+ _)) = List.minimumBy ordPoints [a,b] -isEndPointOf :: Eq r => Point 2 r -> LineSegment 2 p r -> Bool -p `isEndPointOf` s = p == s^.start.core || p == s^.end.core +-- | Add s and s' to the map with key p +handlePoint :: (Ord r, Fractional r) + => LineSegment 2 p r :+ e + -> LineSegment 2 p r :+ e + -> Point 2 r + -> Intersections p r e -> Intersections p r e +handlePoint s s' p = M.insertWith (<>) p (mkAssociated p s <> mkAssociated p s') -pairs :: [a] -> [(a, a)] -pairs [] = [] -pairs (x:xs) = map (x,) xs ++ pairs xs + +type R = Rational + +seg1, seg2 :: LineSegment 2 () R +seg1 = ClosedLineSegment (ext $ Point2 0 0) (ext $ Point2 0 10) +seg2 = ClosedLineSegment (ext $ Point2 0 1) (ext $ Point2 0 5) 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,85 +1,210 @@ +{-# LANGUAGE UndecidableInstances #-} {-# 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 Algorithms.DivideAndConquer import Control.DeepSeq import Control.Lens import Data.Ext +import Data.Bifunctor 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 Map +import qualified Data.Set as Set +import Data.Ord (comparing, Down(..)) import GHC.Generics +import Data.Vinyl.CoRec +import Data.Vinyl +import Data.Intersection --------------------------------------------------------------------------------- --- get the endpoints of a line segment -endPoints' :: (HasEnd s, HasStart s) => s -> (StartCore s, EndCore s) -endPoints' s = (s^.start.core,s^.end.core) +---------------------------------------------------------------------------------- -type Set' l = - Map.Map (Point (Dimension l) (NumType l), Point (Dimension l) (NumType l)) (NonEmpty l) +-- FIXME: What do we do when one segmnet lies *on* the other one. For +-- the short segment it should be an "around start", but then the +-- startpoints do not match. +-- +-- for the long one it's an "on" segment, but they do not intersect -data Associated p r = Associated { _endPointOf :: Set' (LineSegment 2 p r) - , _interiorTo :: Set' (LineSegment 2 p r) - } deriving (Show, Generic) +-- | Assumes that two segments have the same start point +newtype AroundStart a = AroundStart a deriving (Show,Read,NFData,Functor) -instance (Eq p, Eq r) => Eq (Associated p r) where - (Associated es is) == (Associated es' is') = f es es' && f is is' +instance Eq r => Eq (AroundStart (LineSegment 2 p r :+ e)) where + -- | equality on endpoint + (AroundStart s) == (AroundStart s') = s^.core.end.core == s'^.core.end.core + +instance (Ord r, Num r) => Ord (AroundStart (LineSegment 2 p r :+ e)) where + -- | ccw ordered around their suposed common startpoint + (AroundStart s) `compare` (AroundStart s') = + ccwCmpAround (s^.core.start.core) (s^.core.end.core) (s'^.core.end.core) + +---------------------------------------- + +-- | Assumes that two segments have the same end point +newtype AroundEnd a = AroundEnd a deriving (Show,Read,NFData,Functor) + +instance Eq r => Eq (AroundEnd (LineSegment 2 p r :+ e)) where + -- | equality on endpoint + (AroundEnd s) == (AroundEnd s') = s^.core.start.core == s'^.core.start.core + +instance (Ord r, Num r) => Ord (AroundEnd (LineSegment 2 p r :+ e)) where + -- | ccw ordered around their suposed common end point + (AroundEnd s) `compare` (AroundEnd s') = + ccwCmpAround (s^.core.end.core) (s^.core.start.core) (s'^.core.start.core) + +-------------------------------------------------------------------------------- + +-- | Assumes that two segments intersect in a single point. +newtype AroundIntersection a = AroundIntersection a deriving (Show,Read,NFData,Functor) + +instance Eq r => Eq (AroundIntersection (LineSegment 2 p r :+ e)) where + -- | equality ignores the p and the e types + (AroundIntersection (s :+ _)) == (AroundIntersection (s' :+ _)) + = first (const ()) s == first (const ()) s' + +instance (Ord r, Fractional r) => Ord (AroundIntersection (LineSegment 2 p r :+ e)) where + -- | ccw ordered around their common intersection point. + (AroundIntersection (s :+ _)) `compare` (AroundIntersection (s' :+ _)) = + match (s `intersect` s') $ + H (\NoIntersection -> error "AroundIntersection: segments do not intersect!") + :& H (\p -> cmpAroundP p s s') + :& H (\_ -> (squaredLength s) `compare` (squaredLength s')) + -- if s and s' just happen to be the same length but + -- intersect in different behaviour from using (==). + -- but that situation doese not satisfy the precondition + -- of aroundIntersection anyway. + :& RNil where - f xs ys = and $ zipWith (\(p,pa) (q,qa) -> p == q && pa `sameElements` qa) - (Map.toAscList xs) (Map.toAscList ys) + squaredLength (LineSegment' a b) = squaredEuclideanDist (a^.core) (b^.core) - g = L.nub . NonEmpty.toList - sameElements (g -> xs) (g -> ys) = L.null $ (xs L.\\ ys) ++ (ys L.\\ xs) +-- | compare around p +cmpAroundP :: (Ord r, Num r) => Point 2 r -> LineSegment 2 p r -> LineSegment 2 p r -> Ordering +cmpAroundP p s s' = ccwCmpAround p (s^.start.core) (s'^.start.core) -instance (NFData p, NFData r) => NFData (Associated p r) +-- seg1 = ClosedLineSegment (ext $ Point2 0 0) (ext $ Point2 0 10) +-- seg2 = ClosedLineSegment (ext $ Point2 0 0) (ext $ Point2 0 10) +-------------------------------------------------------------------------------- -associated :: Ord r - => [LineSegment 2 p r] -> [LineSegment 2 p r] -> Associated p r -associated es is = Associated (f es) (f is) - where - f = foldr (\s -> Map.insertWith (<>) (endPoints' s) (s :| [])) mempty +-- | The line segments that contain a given point p may either have p +-- as the endpoint or have p in their interior. +-- +-- if somehow the segment is degenerate, and p is both the start and +-- end it is reported only as the start point. +data Associated p r e = + Associated { _startPointOf :: Set.Set (AroundEnd (LineSegment 2 p r :+ e)) + -- ^ segments for which the intersection point is the + -- start point (i.e. s^.start.core == p) + , _endPointOf :: Set.Set (AroundStart (LineSegment 2 p r :+ e)) + -- ^ segments for which the intersection point is the end + -- point (i.e. s^.end.core == p) + , _interiorTo :: Set.Set (AroundIntersection (LineSegment 2 p r :+ e)) + } deriving stock (Show, Read, Generic, Eq) -endPointOf :: Associated p r -> [LineSegment 2 p r] -endPointOf = concatMap NonEmpty.toList . Map.elems . _endPointOf +makeLenses ''Associated -interiorTo :: Associated p r -> [LineSegment 2 p r] -interiorTo = concatMap NonEmpty.toList . Map.elems . _interiorTo +instance Functor (Associated p r) where + fmap f (Associated ss es is) = Associated (Set.mapMonotonic (g f) ss) + (Set.mapMonotonic (g f) es) + (Set.mapMonotonic (g f) is) + where + g :: forall f c e b. Functor f => (e -> b) -> f (c :+ e) -> f (c :+ b) + g f' = fmap (&extra %~ f') -instance Ord r => Semigroup (Associated p r) where - (Associated es is) <> (Associated es' is') = Associated (es <> es') (is <> is') +-- | Reports whether this associated has any interior intersections +-- +-- \(O(1)\) +isInteriorIntersection :: Associated p r e -> Bool +isInteriorIntersection = not . null . _interiorTo -instance Ord r => Monoid (Associated p r) where - mempty = Associated mempty mempty - mappend = (<>) -type Intersections p r = Map.Map (Point 2 r) (Associated p r) +-- | test if the given segment has p as its endpoint, an construct the +-- appropriate associated representing that. +-- +-- pre: p intersects the segment +mkAssociated :: (Ord r, Fractional r) + => Point 2 r -> LineSegment 2 p r :+ e-> Associated p r e +mkAssociated p s@(LineSegment a b :+ _) + | p == a^.unEndPoint.core = mempty&startPointOf .~ Set.singleton (AroundEnd s) + | p == b^.unEndPoint.core = mempty&endPointOf .~ Set.singleton (AroundStart s) + | otherwise = mempty&interiorTo .~ Set.singleton (AroundIntersection s) -data IntersectionPoint p r = + +-- | test if the given segment has p as its endpoint, an construct the +-- appropriate associated representing that. +-- +-- If p is not one of the endpoints we concstruct an empty Associated! +-- +mkAssociated' :: (Ord r, Fractional r) + => Point 2 r -> LineSegment 2 p r :+ e -> Associated p r e +mkAssociated' p s = (mkAssociated p s)&interiorTo .~ mempty + +instance (Ord r, Fractional r) => Semigroup (Associated p r e) where + (Associated ss es is) <> (Associated ss' es' is') = + Associated (ss <> ss') (es <> es') (is <> is') + +instance (Ord r, Fractional r) => Monoid (Associated p r e) where + mempty = Associated mempty mempty mempty + +instance (NFData p, NFData r, NFData e) => NFData (Associated p r e) + +-- | For each intersection point the segments intersecting there. +type Intersections p r e = Map.Map (Point 2 r) (Associated p r e) + +-- | An intersection point together with all segments intersecting at +-- this point. +data IntersectionPoint p r e = IntersectionPoint { _intersectionPoint :: !(Point 2 r) - , _associatedSegs :: !(Associated p r) - } deriving (Show,Eq) + , _associatedSegs :: !(Associated p r e) + } deriving (Show,Read,Eq,Generic,Functor) makeLenses ''IntersectionPoint +instance (NFData p, NFData r, NFData e) => NFData (IntersectionPoint p r e) --- | reports true if there is at least one segment for which this intersection --- point is interior. --- --- \(O(1)\) -isEndPointIntersection :: Associated p r -> Bool -isEndPointIntersection = Map.null . _interiorTo +-- sameOrder :: (Ord r, Num r, Eq p) => Point 2 r +-- -> [LineSegment 2 p r] -> [LineSegment 2 p r] -> Bool +-- sameOrder c ss ss' = f ss == f ss' +-- where +-- f = map (^.extra) . sortAround' (ext c) . map (\s -> s^.end.core :+ s) --- newtype E a b = E (a -> b) + + + +-- | Given a point p, and a bunch of segments that suposedly intersect +-- at p, correctly categorize them. +mkIntersectionPoint :: (Ord r, Fractional r) + => Point 2 r + -> [LineSegment 2 p r :+ e] -- ^ uncategorized + -> [LineSegment 2 p r :+ e] -- ^ segments we know contain p, + -> IntersectionPoint p r e +mkIntersectionPoint p as cs = IntersectionPoint p $ foldMap (mkAssociated p) $ as <> cs + + -- IntersectionPoint p + -- $ Associated mempty mempty (Set.fromAscList cs') + -- <> foldMap (mkAssociated p) as + -- where + -- cs' = map AroundIntersection . List.sortBy (cmpAroundP p) $ cs + -- -- TODO: In the bentley ottman algo we already know the sorted order of the segments + -- -- so we can likely save the additional sort + + + +-- | 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 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 @@ -86,8 +87,8 @@ , _current :: !(Point d r) } -deriving instance (Arity d, Show r) => Show (LPState d r) -deriving instance (Arity d, Eq r) => Eq (LPState d r) +deriving instance (Arity d, Show r) => Show (LPState d r) +deriving instance (Arity d, Eq r, Fractional r) => Eq (LPState d r) obj :: Lens' (LPState d r) (Vector d r) obj = lens _obj (\(LPState _ s p) o -> LPState o s p) @@ -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/LinearProgramming/Types.hs b/src/Algorithms/Geometry/LinearProgramming/Types.hs --- a/src/Algorithms/Geometry/LinearProgramming/Types.hs +++ b/src/Algorithms/Geometry/LinearProgramming/Types.hs @@ -26,14 +26,14 @@ | UnBounded (HalfLine d r) makePrisms ''LPSolution -deriving instance (Arity d, Show r) => Show (LPSolution d r) -deriving instance (Arity d, Eq r) => Eq (LPSolution d r) +deriving instance (Arity d, Show r) => Show (LPSolution d r) +deriving instance (Arity d, Eq r, Fractional r) => Eq (LPSolution d r) data LinearProgram d r = LinearProgram { _objective :: !(Vector d r) , _constraints :: [HalfSpace d r] } makeLenses ''LinearProgram -deriving instance Arity d => Functor (LinearProgram d) -deriving instance (Arity d, Show r) => Show (LinearProgram d r) -deriving instance (Arity d, Eq r) => Eq (LinearProgram d r) +deriving instance Arity d => Functor (LinearProgram d) +deriving instance (Arity d, Show r) => Show (LinearProgram d r) +deriving instance (Arity d, Fractional r, Eq r) => Eq (LinearProgram d r) 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) @@ -29,7 +36,7 @@ -- the upper convex hull. It uses the given algorithm to do so -- -- running time: O(time required by the given upper hull algorithm) -lowerEnvelopeWith :: (Fractional r, Eq r) +lowerEnvelopeWith :: (Fractional r, Ord r) => UpperHullAlgorithm (Line 2 r :+ a) r -> NonEmpty (Line 2 r :+ a) -> Envelope a r lowerEnvelopeWith chAlgo = fromPts . chAlgo . toPts 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) @@ -14,23 +21,23 @@ -------------------------------------------------------------------------------- -- | Line simplification with the well-known Douglas Peucker alogrithm. Given a distance --- value eps adn a polyline pl, constructs a simplification of pl (i.e. with +-- value eps and a polyline pl, constructs a simplification of pl (i.e. with -- 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) \) on average. douglasPeucker :: (Ord r, Fractional r, Arity d) => r -> PolyLine d p r -> PolyLine d p r douglasPeucker eps pl - | dst <= (eps*eps) = fromPoints [a,b] + | dst <= (eps*eps) = fromPointsUnsafe [a,b] -- at least two points, so we are fine. | otherwise = douglasPeucker eps pref `merge` douglasPeucker eps subf where - pts = pl^.points - a = LSeq.head pts - b = LSeq.last pts - (i,dst) = maxDist pts (ClosedLineSegment a b) + pts = pl^.points + a = LSeq.head pts + b = LSeq.last pts + (i,dst) = maxDist pts (ClosedLineSegment a b) - (pref,subf) = split i pl + (pref,subf) = split i pl -------------------------------------------------------------------------------- -- * Internal functions diff --git a/src/Algorithms/Geometry/PolyLineSimplification/ImaiIri.hs b/src/Algorithms/Geometry/PolyLineSimplification/ImaiIri.hs new file mode 100644 --- /dev/null +++ b/src/Algorithms/Geometry/PolyLineSimplification/ImaiIri.hs @@ -0,0 +1,138 @@ +-- | +-- Module : Algorithms.Geometry.PolyLineSimplification.ImaiIri +-- Copyright : (C) Frank Staals +-- License : see the LICENSE file +-- Maintainer : Frank Staals +-------------------------------------------------------------------------------- +module Algorithms.Geometry.PolyLineSimplification.ImaiIri + ( simplify + , simplifyWith + ) where + +import Algorithms.Graph.BFS (bfs') +import Control.Lens +import Data.Ext +import qualified Data.Foldable as F +import Data.Geometry.LineSegment +import Data.Geometry.Point +import Data.Geometry.PolyLine +import Data.Geometry.Vector +import qualified Data.LSeq as LSeq +import Data.List.NonEmpty (NonEmpty(..)) +import qualified Data.List.NonEmpty as NonEmpty +import qualified Data.Sequence as Seq +import Data.Tree +import qualified Data.Vector as V +import Witherable + +-- import Data.RealNumber.Rational +-- type R = RealNumber 5 + +-------------------------------------------------------------------------------- + +-- | Line simplification with the Imai-Iri alogrithm. Given a distance +-- value eps and a polyline pl, constructs a simplification of pl +-- (i.e. with vertices from pl) s.t. all other vertices are within +-- dist eps to the original polyline. +-- +-- Running time: \( O(n^2) \) time. +simplify :: (Ord r, Fractional r, Arity d) + => r -> PolyLine d p r -> PolyLine d p r +simplify eps = simplifyWith $ \shortcut subPoly -> all (closeTo shortcut) (subPoly^.points) + where + closeTo seg (p :+ _) = sqDistanceToSeg p seg <= epsSq + epsSq = eps*eps + +-- | Given a function that tests if the shortcut is valid, compute a +-- simplification using the Imai-Iri algorithm. +-- +-- Running time: \( O(Tn^2 \) time, where \(T\) is the time to +-- evaluate the predicate. +simplifyWith :: (LineSegment d p r -> PolyLine d p r -> Bool) + -> PolyLine d p r -> PolyLine d p r +simplifyWith isValid pl = pl&points %~ (LSeq.promise @2 . extract path) + where + g = mkGraph isValid pl + spt = bfs' 0 g + path = case pathsTo (pl^.points.to F.length - 1) spt of + [] -> error "no path found?" + (pth:_) -> pth + +---------------------------------------- + +type Graph = V.Vector [Int] + +-- | Constructs the shortcut graph +mkGraph :: (LineSegment d p r -> PolyLine d p r -> Bool) -> PolyLine d p r -> Graph +mkGraph isValid = flip V.snoc [] . V.imap f . V.fromList . F.toList . allPrefixes + where + f i subPl = catMaybes + $ zipWith isValid' [i+1..] . F.toList . allSuffixes $ subPl + + isValid' j subPoly = let shortcut = ClosedLineSegment (subPoly^.start) (subPoly^.end) + in if isValid shortcut subPoly then Just j else Nothing + +-- | Generates all prefixes of the polyline; i.e. all contiguous +-- polylines all starting at the original starting point. +allPrefixes :: PolyLine d p r -> Seq.Seq (PolyLine d p r) +allPrefixes pl = mapMaybe mkPolyLine . Seq.tails . LSeq.toSeq $ pl^.points + +mkPolyLine :: Seq.Seq (Point d r :+ p) -> Maybe (PolyLine d p r) +mkPolyLine = fmap PolyLine . LSeq.eval @2 . LSeq.fromSeq + +-- | Generates all suffixes of the polyline. +allSuffixes :: PolyLine d p r -> Seq.Seq (PolyLine d p r) +allSuffixes pl = mapMaybe mkPolyLine . Seq.drop 2 . Seq.inits . LSeq.toSeq $ pl^.points + + + + + + +-- | Get all paths to the particular element in the tree. +pathsTo :: Eq a => a -> Tree a -> [NonEmpty a] +pathsTo x = findPaths (== x) + +-- | All paths to the nodes satisfying the predicate. +findPaths :: (a -> Bool) -> Tree a -> [NonEmpty a] +findPaths p = go + where + go (Node x chs) = case foldMap go chs of + [] | p x -> [x:|[]] + | otherwise -> [] + paths | p x -> (x:|[]) : map (x NonEmpty.<|) paths + | otherwise -> map (x NonEmpty.<|) paths + + + + +-- | Given a non-empty list of indices, and some LSeq, extract the elemnets +-- on those indices. +-- +-- running time: \(O(n)\) +extract :: NonEmpty Int -> LSeq.LSeq n a -> LSeq.LSeq 0 a +extract is = LSeq.fromList . extract' (F.toList is) 0 . F.toList + +extract' :: [Int] -> Int -> [a] -> [a] +extract' [] _ _ = [] +extract' (_:_) _ [] = [] +extract' is'@(i:is) j (x:xs) | i == j = x : extract' is (j+1) xs + | otherwise = extract' is' (j+1) xs + +-------------------------------------------------------------------------------- + + +-- tr :: Tree Int +-- tr = Node 0 [Node 1 [], Node 2 [Node 3 [], Node 2 [], Node 4 [Node 5 []]]] + +-- poly :: PolyLine 2 Int R +-- poly = case fromPoints [origin :+ 0, Point2 1 1 :+ 1, Point2 2 2 :+ 2, Point2 3 3 :+ 3] of +-- Just p -> p + +-- test = Seq.fromList [0..5] + +-- myTree :: Tree Int +-- myTree = Node {rootLabel = 0, subForest = [Node {rootLabel = 1, subForest = []} +-- ,Node {rootLabel = 2, subForest = []} +-- ,Node {rootLabel = 3, subForest = []}] +-- } diff --git a/src/Algorithms/Geometry/PolygonTriangulation.hs b/src/Algorithms/Geometry/PolygonTriangulation.hs new file mode 100644 --- /dev/null +++ b/src/Algorithms/Geometry/PolygonTriangulation.hs @@ -0,0 +1,14 @@ +-------------------------------------------------------------------------------- +-- | +-- Module : Algorithms.Geometry.PolygonTriangulation +-- Copyright : (C) Frank Staals +-- License : see the LICENSE file +-- Maintainer : Frank Staals +-------------------------------------------------------------------------------- +module Algorithms.Geometry.PolygonTriangulation + ( triangulate + , triangulate' + , computeDiagonals + ) where + +import Algorithms.Geometry.PolygonTriangulation.Triangulate 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) \) time. +-- +-- 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,23 +1,27 @@ -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE ScopedTypeVariables #-} -module Algorithms.Geometry.PolygonTriangulation.MakeMonotone( makeMonotone - , computeDiagonals +{-# 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 - , VertexType(..) - , classifyVertices - ) where + , VertexType(..) + , classifyVertices + ) where -import Algorithms.Geometry.LineSegmentIntersection.BentleyOttmann ( xCoordAt - , ordAt) 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 Data.Ext import qualified Data.Foldable as F @@ -27,16 +31,16 @@ import Data.Geometry.Polygon import qualified Data.IntMap as IntMap import qualified Data.List.NonEmpty as NonEmpty -import Data.Ord (comparing, Down(..)) +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.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 +53,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 +74,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 +103,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 +114,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. -- @@ -155,11 +161,11 @@ -- pre: the polygon boundary is given in counterClockwise order. -- -- 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) +makeMonotone :: forall s t p r. (Fractional r, Ord r) + => Polygon t p r + -> PlanarSubdivision s p PolygonEdgeType PolygonFaceData r +makeMonotone pg = let (e:es) = listEdges pg + in constructSubdivision e es (computeDiagonals pg) type Sweep p r = WriterT (DList.DList (LineSegment 2 Int r)) (StateT (StatusStruct r) @@ -192,11 +198,11 @@ insertAt :: (Ord r, Fractional r) => Point 2 r -> LineSegment 2 q r -> SS.Set (LineSegment 2 q r) -> SS.Set (LineSegment 2 q r) -insertAt v = SS.insertBy (ordAt $ v^.yCoord) +insertAt v = SS.insertBy (ordAtY $ v^.yCoord) deleteAt :: (Fractional r, Ord r) => Point 2 r -> LineSegment 2 p r -> SS.Set (LineSegment 2 p r) -> SS.Set (LineSegment 2 p r) -deleteAt v = SS.deleteAllBy (ordAt $ v^.yCoord) +deleteAt v = SS.deleteAllBy (ordAtY $ v^.yCoord) handleStart :: (Fractional r, Ord r) 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,17 +18,15 @@ import Data.Geometry.LineSegment import Data.Geometry.PlanarSubdivision.Basic import Data.Geometry.Polygon -import Data.PlaneGraph (PlaneGraph) -------------------------------------------------------------------------------- -- | Triangulates a polygon of \(n\) vertices -- -- running time: \(O(n \log n)\) -triangulate :: (Ord r, Fractional r) - => proxy s -> Polygon t p r - -> PlanarSubdivision s p PolygonEdgeType PolygonFaceData r -triangulate px pg' = constructSubdivision px e es diags +triangulate :: forall s t p r. (Ord r, Fractional r) + => Polygon t p r -> PlanarSubdivision s p PolygonEdgeType PolygonFaceData r +triangulate pg' = constructSubdivision e es diags where (pg, diags) = computeDiagonals' pg' (e:es) = listEdges pg @@ -30,10 +35,9 @@ -- | Triangulates a polygon of \(n\) vertices -- -- running time: \(O(n \log n)\) -triangulate' :: (Ord r, Fractional r) - => proxy s -> Polygon t p r - -> PlaneGraph s p PolygonEdgeType PolygonFaceData r -triangulate' px pg' = constructGraph px e es diags +triangulate' :: forall s t p r. (Ord r, Fractional r) + => Polygon t p r -> PlaneGraph s p PolygonEdgeType PolygonFaceData r +triangulate' pg' = constructGraph e es diags where (pg, diags) = computeDiagonals' pg' (e:es) = listEdges pg @@ -56,7 +60,7 @@ computeDiagonals' pg' = (pg, monotoneDiags <> extraDiags) where pg = toCounterClockWiseOrder pg' - monotoneP = MM.makeMonotone (Identity pg) pg -- use some arbitrary proxy type + monotoneP = MM.makeMonotone @() pg -- use some arbitrary proxy type -- outerFaceId' = outerFaceId monotoneP monotoneDiags = map (^._2.core) . filter (\e' -> e'^._2.extra == Diagonal) @@ -65,8 +69,6 @@ . lefts . map (^._2.core) . filter (\mp -> mp^._2.extra == Inside) -- triangulate only the insides -- . filter (\f -> f^._1 /= outerFaceId') - . F.toList . rawFacePolygons $ monotoneP - - -- -- we alredy know we get the polgyons in *clockwise* order, so skip the - -- -- check if it is counter clockwise - -- toCounterClockWiseOrder'' = reverseOuterBoundary + . F.toList . internalFacePolygons $ monotoneP + -- FIXME: we should already get all polygons in CCW order, so no + -- need for the toClockwiseOrder' call 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) @@ -25,10 +47,9 @@ -- | Triangulates a polygon of \(n\) vertices -- -- running time: \(O(n \log n)\) -triangulate :: (Ord r, Fractional r) - => proxy s -> MonotonePolygon p r - -> PlanarSubdivision s p PolygonEdgeType PolygonFaceData r -triangulate px pg' = constructSubdivision px e es (computeDiagonals pg) +triangulate :: forall s p r. (Ord r, Fractional r) + => MonotonePolygon p r -> PlanarSubdivision s p PolygonEdgeType PolygonFaceData r +triangulate pg' = constructSubdivision e es (computeDiagonals pg) where pg = toCounterClockWiseOrder pg' (e:es) = listEdges pg @@ -37,10 +58,9 @@ -- | Triangulates a polygon of \(n\) vertices -- -- running time: \(O(n \log n)\) -triangulate' :: (Ord r, Fractional r) - => proxy s -> MonotonePolygon p r - -> PlaneGraph s p PolygonEdgeType PolygonFaceData r -triangulate' px pg' = constructGraph px e es (computeDiagonals pg) +triangulate' :: forall s p r. (Ord r, Fractional r) + => MonotonePolygon p r-> PlaneGraph s p PolygonEdgeType PolygonFaceData r +triangulate' pg' = constructGraph e es (computeDiagonals pg) where pg = toCounterClockWiseOrder pg' (e:es) = listEdges pg @@ -126,19 +146,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 +175,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) @@ -23,16 +31,15 @@ -- -- -- running time: \(O(n\log n)\) -constructSubdivision :: forall proxy r s p. (Fractional r, Ord r) - => proxy s - -> LineSegment 2 p r -- ^ A counter-clockwise - -- edge along the outer - -- boundary - -> [LineSegment 2 p r] -- ^ remaining original edges - -> [LineSegment 2 p r] -- ^ diagonals - -> PlanarSubdivision s - p PolygonEdgeType PolygonFaceData r -constructSubdivision px e origs diags = fromPlaneGraph $ constructGraph px e origs diags +constructSubdivision :: forall s r p. (Fractional r, Ord r) + => LineSegment 2 p r -- ^ A counter-clockwise + -- edge along the outer + -- boundary + -> [LineSegment 2 p r] -- ^ remaining original edges + -> [LineSegment 2 p r] -- ^ diagonals + -> PlanarSubdivision s + p PolygonEdgeType PolygonFaceData r +constructSubdivision e origs diags = fromPlaneGraph $ constructGraph e origs diags -- constructSubdivision px e origs diags = -- subdiv & rawVertexData.traverse.dataVal %~ NonEmpty.head @@ -72,22 +79,21 @@ -- -- -- running time: \(O(n\log n)\) -constructGraph :: forall proxy r s p. (Fractional r, Ord r) - => proxy s - -> LineSegment 2 p r -- ^ A counter-clockwise +constructGraph :: forall s r p. (Fractional r, Ord r) + => LineSegment 2 p r -- ^ A counter-clockwise -- edge along the outer -- boundary -> [LineSegment 2 p r] -- ^ remaining original edges -> [LineSegment 2 p r] -- ^ diagonals -> PG.PlaneGraph s p PolygonEdgeType PolygonFaceData r -constructGraph px e origs diags = +constructGraph e origs diags = subdiv & PG.vertexData.traverse %~ NonEmpty.head & PG.faceData .~ faceData' & PG.rawDartData.traverse %~ snd where subdiv :: PG.PlaneGraph s (NonEmpty p) (Bool,PolygonEdgeType) () r - subdiv = PG.fromConnectedSegments px $ e' : origs' <> diags' + subdiv = PG.fromConnectedSegments $ e' : origs' <> diags' diags' = (:+ (True, Diagonal)) <$> diags origs' = (:+ (False,Original)) <$> origs diff --git a/src/Algorithms/Geometry/RayShooting/Naive.hs b/src/Algorithms/Geometry/RayShooting/Naive.hs new file mode 100644 --- /dev/null +++ b/src/Algorithms/Geometry/RayShooting/Naive.hs @@ -0,0 +1,88 @@ +module Algorithms.Geometry.RayShooting.Naive + ( firstHit + , firstHit' + + + , firstHitSegments + , intersectionDistance + , labelWithDistances + ) where + +import Control.Lens +import Data.Bifunctor +import Data.Ext +import Data.Geometry.HalfLine +import Data.Geometry.LineSegment +import Data.Geometry.Point +import Data.Geometry.Polygon +import Data.Intersection +import qualified Data.List as List +import Data.Maybe +import Data.Ord (comparing) +import Data.Vinyl.CoRec +import Data.Vinyl + +-------------------------------------------------------------------------------- + +-- | +-- +-- pre: halfline should start in the interior +firstHit :: (Fractional r, Ord r) + => HalfLine 2 r + -> Polygon t p r + -> LineSegment 2 p r +firstHit ray = fromMaybe err . firstHit' ray + where + err = error "Algorithms.Geometry.RayShooting.Naive: no intersections; ray must have started outside the polygon" + +-- | Compute the first edge hit by the ray, if it exists +firstHit' :: (Fractional r, Ord r) + => HalfLine 2 r + -> Polygon t p r + -> Maybe (LineSegment 2 p r) +firstHit' ray pg = fmap (^.core) . firstHitSegments ray . map ext $ listEdges pg + + +-- | Compute the first segment hit by the ray, if it exists +firstHitSegments :: (Ord r, Fractional r) + => HalfLine 2 r + -> [LineSegment 2 p r :+ e] + -> Maybe (LineSegment 2 p r :+ e) +firstHitSegments ray = fmap (^.extra) . minimumOn (^.core) + . mapMaybe (\(s :+ (md, e)) -> (:+ (s :+ e)) <$> md) + . labelWithDistances (ray^.startPoint) ray + +minimumOn :: Ord b => (a -> b) -> [a] -> Maybe a +minimumOn f = \case + [] -> Nothing + xs -> Just . List.minimumBy (comparing f) $ xs + + +-- | Given q, a 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. +intersectionDistance :: forall r p. (Ord r, Fractional r) + => Point 2 r -> HalfLine 2 r -> LineSegment 2 p r + -> Maybe r +intersectionDistance q ray s = match (seg `intersect` ray) $ + H (\NoIntersection -> Nothing) + :& H (\p -> Just $ d p) + :& H (\(LineSegment' (a :+ _) (b :+ _)) -> Just $ d a `min` d b) + :& RNil + -- TODO: there is some slight subtility if the segment is open. + where + d = squaredEuclideanDist q + 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 :+ (intersectionDistance q ray s, e)) + + + +-------------------------------------------------------------------------------- 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.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 :: forall s p r. (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' @s 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 @@ -22,11 +23,11 @@ import Data.List (minimumBy) import Data.Function (on) import Data.Maybe (fromMaybe) -import Data.Util(STR(..),SP(..), uniquePairs, uniqueTriplets) - +import Data.Util(uniquePairs, uniqueTriplets) +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) @@ -38,12 +39,13 @@ pairs :: Fractional r => [Point 2 r :+ p] -> [DiskResult p r] pairs pts = [ DiskResult (fromDiameter (a^.core) (b^.core)) (Two a b) - | SP a b <- uniquePairs pts] + | Util.Two a b <- uniquePairs pts] triplets :: (Ord r, Fractional r) => [Point 2 r :+ p] -> [DiskResult p r] triplets pts = [DiskResult (disk' a b c) (Three a b c) - | STR a b c <- uniqueTriplets pts] + | 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,7 +29,8 @@ import Data.Ord (comparing) import System.Random.Shuffle (shuffle) -import Debug.Trace +-- import Data.RealNumber.Rational +-- import Debug.Trace -------------------------------------------------------------------------------- @@ -47,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. @@ -149,16 +148,32 @@ -------------------------------------------------------------------------------- -test :: Maybe (DiskResult () Rational) -test = smallestEnclosingDiskWithPoints p q myPts - where - p = ext $ Point2 0 (-6) - q = ext $ Point2 0 6 +-- test :: Maybe (DiskResult () Rational) +-- test = smallestEnclosingDiskWithPoints p q myPts +-- where +-- p = ext $ Point2 0 (-6) +-- q = ext $ Point2 0 6 -myPts = map ext [Point2 5 1, Point2 3 3, Point2 (-2) 2, Point2 (-4) 5] +-- myPts = map ext [Point2 5 1, Point2 3 3, Point2 (-2) 2, Point2 (-4) 5] -disk'' r = (r:+) <$> disk (p^.core) (q^.core) (r^.core) - where - p = ext $ Point2 0 (-6) - q = ext $ Point2 0 6 +-- disk'' r = (r:+) <$> disk (p^.core) (q^.core) (r^.core) +-- where +-- p = ext $ Point2 0 (-6) +-- q = ext $ Point2 0 6 + + +-- maartenBug :: DiskResult () Double +-- maartenBug = let (p:q:rest) = maartenBug' +-- in smallestEnclosingDisk' p q rest + +-- maartenBug' :: [Point 2 Double :+ ()] +-- maartenBug' = [ Point2 (7.2784424e-3) (249.23) :+ () +-- , Point2 (-5.188493 ) (249.23) :+ () +-- , Point2 (-10.382694 ) (249.23) :+ () +-- , Point2 (-15.575621 ) (249.23) :+ () +-- , Point2 (0.0 ) (249.23) :+ () +-- , Point2 (0.0 ) (239.9031) :+ () +-- , Point2 (0.0 ) (230.37791) :+ () +-- , Point2 (0.0 ) (220.67882) :+ () +-- ] 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 new file mode 100644 --- /dev/null +++ b/src/Algorithms/Geometry/SoS.hs @@ -0,0 +1,235 @@ +-------------------------------------------------------------------------------- +-- | +-- Module : Algorithms.Geometry.SoS +-- Copyright : (C) Frank Staals +-- License : see the LICENSE file +-- Maintainer : Frank Staals +-- +-- Implementation of +-- Simulation of Simplicity: A Technique to Cope with Degenerate Cases in Geometric Algorithms +-- +-- By +-- Herbert Edelsbrunner and Ernst Peter Mucke +-- +-------------------------------------------------------------------------------- +module Algorithms.Geometry.SoS + ( module Algorithms.Geometry.SoS.Sign + , module Algorithms.Geometry.SoS.Orientation + , module Algorithms.Geometry.SoS.Determinant + ) where + +-- import Algorithms.Geometry.SoS.Internal +import Algorithms.Geometry.SoS.Orientation +import Algorithms.Geometry.SoS.Determinant +import Algorithms.Geometry.SoS.Sign + +-------------------------------------------------------------------------------- + +-------------------------------------------------------------------------------- + + + +-- sideTest' :: ( SoS p, Dimension p ~ 2, r ~ NumType p +-- , Eq r, Num r +-- ) => [p] -> Sign +-- sideTest' (q:p1:p2:_) = sideTest q (Vector2 p1 p2) + + + + + + +-------------------------------------------------------------------------------- + + +---------------------------------------- +-------------------------------------------------------------------------------- + +-------------------------------------------------------------------------------- + + + + + +-- instance (i `CanAquire` Point d r, Arity d) => P i d r `CanAquire` Point d (R i) where +-- aquire (P i) = Point $ pure () + + + + +-------------------------------------------------------------------------------- + + + +-------------------------------------------------------------------------------- + + +-------------------------------------------------------------------------------- + + +-- -- TODO: Remove this one +-- instance HasIndex (Point d r :+ Int) where +-- indexOf = view extra + + +-- test1 :: Sign +-- test1 = sideTest (Point1 1 :+ 0 :: Point 1 Int :+ Int) (Vector1 $ Point1 5 :+ 1) + +-- test2 :: Sign +-- test2 = sideTest (Point1 5 :+ 0 :: Point 1 Int :+ Int) (Vector1 $ Point1 5 :+ 1) + + +-- test3 :: Sign +-- test3 = sideTest (Point2 (-1) 5 :+ 0 :: Point 2 Int :+ Int) (Vector2 (Point2 0 0 :+ 1) +-- (Point2 0 10 :+ 2) +-- ) + + +-- pattern Point1 x = Point (Vector1 x) + + +-- testV :: Sign +-- testV = simulateSimplicity sideTest' [ Point2 (-1) 5 +-- , Point2 0 0 +-- , Point2 0 10 +-- ] + + + + + +-------------------------------------------------------------------------------- + + + + + + + + +-- cmpSignificance :: Ord k => Bag k -> Bag k -> Ordering +-- cmpSignificance (Bag e1) (Bag e2) = e1e2 `compare` e2e1 +-- where +-- e1e2 = fmap fst . Map.lookupMax $ e1 `Map.difference` e2 +-- e2e1 = fmap fst . Map.lookupMax $ e2 `Map.difference` e1 + + + +-- -- | Represents a Sum of terms, i.e. a value that has the form: +-- -- +-- -- \[ +-- -- \sum c \Pi_{(i,j)} \varepsilon(i,j) +-- -- \] +-- newtype Symbolic i j r = Symbolic [Term i j r] deriving (Show,Eq,Functor) + +-- instance (Ord i, Ord j, Num r) => Num (Symbolic i j r) where +-- (Symbolic ts) + (Symbolic ts') = Symbolic (ts `addTerms` ts') +-- negate = fmap negate +-- (Symbolic ts) * (Symbolic ts') = Symbolic $ multiplyTerms ts ts' +-- fromInteger x = constant (fromInteger x) +-- -- abs x | signum x == -1 = (-1)*x +-- -- | oterwise = x + +-- -- signum = undefined + + + + + + + + + + +-- -- | Adds two lists of terms +-- addTerms :: forall i j r. (Ord i, Ord j, Num r) +-- => [Term i j r] -> [Term i j r] -> [Term i j r] +-- addTerms ts ts' = (\(eps,c) -> Term c eps) <$> Map.toList m +-- where +-- m :: Map.Map (EpsFold i j) r +-- m = Map.fromListWith (+) [ (eps,c) | (Term c eps) <- ts <> ts' ] + +-- multiplyTerms :: forall i j r. (Ord i, Ord j, Num r) +-- => [Term i j r] -> [Term i j r] -> [Term i j r] +-- multiplyTerms ts ts' = (\(eps,c) -> Term c eps) <$> Map.toList m +-- where +-- m :: Map.Map (EpsFold i j) r +-- m = Map.fromListWith (+) [ (es <> es',c*d) | (Term c es) <- ts, (Term d es') <- ts' ] + + + + +-- orderedTerms :: (Ord i, Ord j) => Symbolic i j r -> [Term i j r] +-- orderedTerms (Symbolic ts) = List.sortBy (\(Term _ e1) (Term _ e2) -> cmpSignificance e1 e2) ts + + + + + + + + + + + + + + + + + + -- zipWith (\j x -> Term x $ singleton (i,j)) [0..] . toList + + + + + + +-- orderTerms :: (Ord i, Ord j) => Symbolic i j r -> Symbolic i j r +-- orderTerms (Symbolic ts) = Symbolic $ List.sortBy cmpSignificance ts + + + +-- fromPoint' :: Foldable f => i -> f r -> Symbolic i Int r +-- fromPoint' i = Symbolic . zipWith (\j x -> Term x [(i,j)]) [0..] . toList + + + +-- testZ :: Symbolic Int Int Int +-- testZ = (5 + 6) * + + + + + + -- case sign i of + -- (-1) -> Negative $ fromInteger i + -- 0 -> Zero + -- _ -> Positive $ fromInteger i + -- negate = \case + -- Negative c -> Positive c + -- Positive c -> Negative c + + +-- newtype N = N String deriving (Show,Eq) + + +-- instance Num N where +-- (N x) + (N y) = N $ x <> "+" <> y +-- (N x) * (N y) = N $ x <> y +-- negate (N x) = N ("negate(" <> x <> ")") +-- fromInteger = N . show + + +-- n :: (Ord i, Ord j) => String -> i -> j -> Symbolic i j N +-- n x i j = Symbolic [Term (N x) mempty, Term 1 (singleton (i,j))] + + + + + +-- testM3 = det33 $ V3 (fromPoint' [N "px", N "py"] <> 1) +-- (fromPoint' [N "px", N "py"] <> 1) +-- (fromPoint' [N "px", N "py"] <> 1) +-- -- (V3 (N "qx") (N "qy") 1) +-- -- (V3 (N "rx") (N "ry") 1) diff --git a/src/Algorithms/Geometry/SoS/AsPoint.hs b/src/Algorithms/Geometry/SoS/AsPoint.hs new file mode 100644 --- /dev/null +++ b/src/Algorithms/Geometry/SoS/AsPoint.hs @@ -0,0 +1,27 @@ +module Algorithms.Geometry.SoS.AsPoint where + +import Control.CanAquire +import Data.Ext +import Data.Geometry.Point.Internal +import Data.Geometry.Properties +import Data.Geometry.Vector + +-------------------------------------------------------------------------------- +-- | a P is a 'read only' point in d dimensions +newtype P i d r = P i deriving (Eq, Show) + +-- | Indxec type that can disambiguate points +newtype SoSIndex i = SoSIndex i deriving (Show,Eq,Ord) + +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 + aquire (P i) = aquire i + +type instance NumType (P i d r) = r +type instance Dimension (P i d r) = d + +asPointWithIndex :: (Arity d, i `CanAquire` Point d r) + => P i d r -> Point d r :+ SoSIndex i +asPointWithIndex (P i) = aquire i :+ SoSIndex i diff --git a/src/Algorithms/Geometry/SoS/Determinant.hs b/src/Algorithms/Geometry/SoS/Determinant.hs new file mode 100644 --- /dev/null +++ b/src/Algorithms/Geometry/SoS/Determinant.hs @@ -0,0 +1,13 @@ +module Algorithms.Geometry.SoS.Determinant where + +import Algorithms.Geometry.SoS.Sign +import Algorithms.Geometry.SoS.Symbolic +import Data.Geometry.Matrix + + +-- | pre: computes the sign of the determinant +signDet :: (HasDeterminant d, Ord i, Num r, Ord r) => Matrix d d (Symbolic i r) -> Sign +signDet m = case det m `compare` 0 of + LT -> Negative + GT -> Positive + EQ -> error "signDet: determinant is zero! this should not happen!" diff --git a/src/Algorithms/Geometry/SoS/Expr.hs b/src/Algorithms/Geometry/SoS/Expr.hs new file mode 100644 --- /dev/null +++ b/src/Algorithms/Geometry/SoS/Expr.hs @@ -0,0 +1,78 @@ +{-# LANGUAGE TemplateHaskell #-} +module Algorithms.Geometry.SoS.Expr where + +import Control.Lens +import qualified Data.List as List + +-------------------------------------------------------------------------------- + +data Expr v r = Constant r + | Negate (Expr v r) + | Sum [Expr v r] + | Prod [Expr v r] + | Var v + deriving (Show,Eq) +makePrisms ''Expr + + +foldExpr :: (r -> b) -> (b -> b) -> ([b] -> b) -> ([b] -> b) -> (v -> b) -> Expr v r -> b +foldExpr con' neg' sum' prod' var' = go + where + go = \case + Constant c -> con' c + Negate e -> neg' $ go e + Sum es -> sum' $ map go es + Prod es -> prod' $ map go es + Var v -> var' v + +-- | Test if the expression has any variables. +hasVariables :: Expr v r -> Bool +hasVariables = foldExpr (const False) + id + or + or + (const True) + +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 + + (Sum es) + (Sum es') = Sum $ es <> es' + (Sum es) + e = Sum (e:es) + e + (Sum es) = Sum (e:es) + e + e' = Sum [e,e'] + + (Prod es) * (Prod es') = Prod $ es <> es' + (Prod es) * e = Prod (e:es) + e * (Prod es) = Prod (e:es) + e * e' = Prod [e,e'] + + +simplify :: (Num r, Eq r) => Expr v r -> Expr v r +simplify = \case + Prod es -> case filter (isn't $ _Constant.only 1) es of + [] -> Constant 1 + es' -> Prod $ map simplify es' + Sum es -> case filter (isn't $ _Constant.only 0) es of + [] -> Constant 0 + es' -> Sum $ map simplify es' + Negate e -> Negate $ simplify e + e -> e + +prettyP :: (Show r, Show v) => Expr v r -> String +prettyP = \case + Constant c -> show c + Negate e -> "(-1)*(" <> prettyP e <> ")" + Prod es -> mconcat [ "(" + , List.intercalate ")*(" (prettyP <$> es) + , ")" + ] + Sum es -> mconcat [ "(" + , List.intercalate ") + (" (prettyP <$> es) + , ")" + ] + Var v -> show v diff --git a/src/Algorithms/Geometry/SoS/Internal.hs b/src/Algorithms/Geometry/SoS/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Algorithms/Geometry/SoS/Internal.hs @@ -0,0 +1,28 @@ +module Algorithms.Geometry.SoS.Internal where + +import Algorithms.Geometry.SoS.AsPoint +import Algorithms.Geometry.SoS.Orientation +import Control.CanAquire +import Data.Geometry.Point.Internal + +-------------------------------------------------------------------------------- + +-- simulateSimplicity :: forall t d r b. (Traversable t, SoSD d) +-- => (forall p. ( AsPoint p, HasIndex p +-- , d ~ Dimension p, r ~ NumType p +-- ) => t p -> b) +-- -> t (Point d r) -> b +-- simulateSimplicity = simulateSimplicity' + + +-- | The actual implementation of SoS +simulateSimplicity' :: forall t d r b. (Traversable t, SoS d) + => (forall i. ( CanAquire i (Point d r) + , SoS d + ) => t (P i d r) -> b) + -> t (Point d r) -> b +simulateSimplicity' alg = runAcquire alg' + where + alg' :: forall i. CanAquire i (Point d r) => t i -> b + alg' = alg . fmap (P @i @d @r) + -- ideally the fmap would just be a coerce, but GHC does not want to do that. diff --git a/src/Algorithms/Geometry/SoS/Orientation.hs b/src/Algorithms/Geometry/SoS/Orientation.hs new file mode 100644 --- /dev/null +++ b/src/Algorithms/Geometry/SoS/Orientation.hs @@ -0,0 +1,83 @@ +module Algorithms.Geometry.SoS.Orientation( SoS + + , sideTest + , sideTest' + + , toSymbolic + ) where + +import Algorithms.Geometry.SoS.Determinant +import Algorithms.Geometry.SoS.Sign +import Algorithms.Geometry.SoS.Symbolic +import Control.Lens hiding (snoc,cons) +import Data.Ext +import Data.Geometry.Matrix +import Data.Geometry.Point +import Data.Geometry.Vector +import GHC.TypeNats + +-------------------------------------------------------------------------------- + + + +-- | A dimension d has support for SoS when we can: compute a +-- dterminant of a d+1 by d+1 dimensional matrix. +type SoS d = (Arity d, HasDeterminant (d+1)) + +-- | Given a query point q, and a vector of d points defining a +-- hyperplane test if q lies above or below the hyperplane. Each point +-- is assumed to have an unique index of type i that can be used to +-- disambiguate it in case of degeneracies. +-- +-- some 1D examples: +-- +-- >>> sideTest (Point1 0 :+ 0) (Vector1 $ Point1 2 :+ 1) +-- Negative +-- >>> sideTest (Point1 10 :+ 0) (Vector1 $ Point1 2 :+ 1) +-- Positive +-- >>> sideTest (Point1 2 :+ 0) (Vector1 $ Point1 2 :+ 1) +-- Positive +-- >>> sideTest (Point1 2 :+ 3) (Vector1 $ Point1 2 :+ 1) +-- Negative +-- +-- some 2D examples: +-- +-- >>> sideTest (Point2 1 2 :+ 0) $ Vector2 (Point2 0 0 :+ 1) (Point2 2 2 :+ 3) +-- Positive +-- >>> sideTest (Point2 1 (-2) :+ 0) $ Vector2 (Point2 0 0 :+ 1) (Point2 2 2 :+ 3) +-- Negative +-- >>> sideTest (Point2 1 1 :+ 0) $ Vector2 (Point2 0 0 :+ 1) (Point2 2 2 :+ 3) +-- Positive +-- >>> sideTest (Point2 1 1 :+ 10) $ Vector2 (Point2 0 0 :+ 1) (Point2 2 2 :+ 3) +-- Negative +-- >>> sideTest (Point2 1 1 :+ 10) $ Vector2 (Point2 0 0 :+ 3) (Point2 2 2 :+ 1) +-- Negative +sideTest :: (SoS d, Num r, Ord r, Ord i) + => Point d r :+ i -> Vector d (Point d r :+ i) -> Sign +sideTest q ps = sideTest'' . fmap toSymbolic $ cons q ps + +-- | 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)) + +-- | Given a point q and a vector of d points defining a hyperplane, +-- test on which side of the hyperplane q lies. +-- +-- TODO: Specify what the sign means +sideTest' :: (Num r, Ord r, Ord i, HasDeterminant (d+1), Arity d, Arity (d+1)) + => Point d (Symbolic i r) -> Vector d (Point d (Symbolic i r)) -> Sign +sideTest' q ps = sideTest'' $ cons q ps + +-- | Given a vector of points, tests if the point encoded in the first +-- row is above/below the hyperplane defined by the remaining points +-- (rows). +sideTest'' :: (Num r, Ord r, Ord i, HasDeterminant (d+1), Arity d, Arity (d+1)) + => Vector (d+1) (Point d (Symbolic i r)) -> Sign +sideTest'' = signDet . Matrix . fmap mkLambdaRow + +-- | Given a point produces the vector/row corresponding to this point +-- 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 diff --git a/src/Algorithms/Geometry/SoS/Sign.hs b/src/Algorithms/Geometry/SoS/Sign.hs new file mode 100644 --- /dev/null +++ b/src/Algorithms/Geometry/SoS/Sign.hs @@ -0,0 +1,31 @@ +module Algorithms.Geometry.SoS.Sign where + +import qualified Data.List as List +import Data.Maybe + +-------------------------------------------------------------------------------- + +-- | 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 + Positive -> Negative + +-------------------------------------------------------------------------------- + +-- | Given the terms, in decreasing order of significance, computes the sign +-- +-- i.e. expects a list of terms, we base the sign on the sign of the first non-zero term. +-- +-- pre: the list contains at least one such a term. +signFromTerms :: (Num r, Eq r) => [r] -> Sign +signFromTerms = List.head . mapMaybe signum' + where + signum' x = case signum x of + -1 -> Just Negative + 0 -> Nothing + 1 -> Just Positive + _ -> error "signum': absurd" diff --git a/src/Algorithms/Geometry/SoS/Symbolic.hs b/src/Algorithms/Geometry/SoS/Symbolic.hs new file mode 100644 --- /dev/null +++ b/src/Algorithms/Geometry/SoS/Symbolic.hs @@ -0,0 +1,359 @@ +-------------------------------------------------------------------------------- +-- | +-- 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 + , hasNoPertubation + , factors + , suitableBase + + , Term(..), term, constantFactor + + , Symbolic + , constant, symbolic, perturb + + , toTerms + , signOf + ) where + +import Algorithms.Geometry.SoS.Sign (Sign(..)) +import Control.Lens +import Data.Foldable (toList) +import qualified Data.List as List +import qualified Data.Map as Map +import qualified Data.Map.Merge.Strict as Map +import Data.Maybe (isNothing) +import Test.QuickCheck (Arbitrary(..), listOf) +import Test.QuickCheck.Instances () + +-------------------------------------------------------------------------------- +-- * EpsFolds + +{- +Let \(\mathcal{I}\) be a bag with indices, let \(c\) be an upper +bound on the number of times a single item may occur in +\(\mathcal{I}\), and let \(\varepsilon\) be a function mapping indices +to real numbers that satisfies: + +1. \(0 < \varepsilon(j) < 1\), for all \(1 \leq j\), +2. \(\prod_{0 \leq i \leq j} \varepsilon(i)^c > \varepsilon(k)\), for all \(1 \leq j < k\) + +Note that such a function exists: + +\begin{lemma} + \label{lem:condition_2} + Let \(\delta \in (0,1)\) and \(d \geq c+1\). The function + \(\varepsilon(i) = \delta^{d^i}\) satisfies condition 2. +\end{lemma} + +\begin{proof} + By transitivity it suffices to argue this for \(k=j+1\): + + \begin{align*} + &\qquad \prod_{0 \leq i \leq j} \varepsilon(i)^c > \varepsilon(j+1) \\ + \equiv &\qquad \prod_{0 \leq i \leq j} (\delta^{d^i})^c > \delta^{d^{j+1}}\\ + \equiv &\qquad \prod_{0 \leq i \leq j} \delta^{cd^i} > \delta^{d^{j+1}} \\ + \equiv &\qquad \delta^{\sum_{0 \leq i \leq j} cd^i} > \delta^{d^{j+1}} & + \text{using + } + \delta \in (0,1)\\ + \equiv &\qquad \sum_{0 \leq i \leq j} cd^i < d^{j+1} \\ + \equiv &\qquad c\sum_{0 \leq i \leq j} d^i < d^{j+1} \\ + \end{align*} + + We prove this by induction. + + For the base case \(j=0\): we have \(0 < 1\), which is trivially true. + + For the step case we have the induction hypothesis + \(c\sum_{0 \leq i \leq j} d^i < d^{j+1}\), and we have to prove that + \(c\sum_{0 \leq i \leq j+1} d^i < d^{j+2}\): + + \begin{align*} + c\sum_{0 \leq i \leq j+1} d^i + &= cd^{j+1} + c\sum_{0 \leq i \leq j} d^i \\ + &< cd^{j+1} + d^{j+1} & \text{using IH} \\ + &= (c+1)d^{j+1} & \text{using that } c+1 \leq d \\ + &\leq dd^{j+1} \\ + &=d^{j+2} + \end{align*} + This completes the proof. +\end{proof} + + + + + + +An EpsFold now represents the term + +\[ \prod_{i \in \mathcal{I}} \varepsilon(i) \] + +for some bag \(\mathcal{I}\). + + +Let \(\mathcal{J}\) be some sub-bag of \(\mathcal{I}\). Note that +condition 2 implies that: + +\(\prod_{i \in \mathcal{J}} \varepsilon(i) > \varepsilon(k)\), for all \(1 \leq j < k\) + +This means that when comparing two EpsFolds, say \(e_1\) and \(e_2\), +representing bags \(\mathcal{I}_1\) and \(\mathcal{I}_2\), +respectively. It suffices to compare the largest index +\(j \in \mathcal{I}_1\setminus\mathcal{I}_2\) with the largest index +\(k \in \mathcal{I}_2\setminus\mathcal{I}_1\). We have that + +\(e_1 > e_2\) if and only if \(j < k\). +-} +newtype EpsFold i = Pi (Bag i) deriving (Semigroup,Monoid) + +-- | Gets the factors +factors :: EpsFold i -> Bag i +factors (Pi is) = is + +-- | Creates the term \(\varepsilon(i)\) +eps :: i -> EpsFold i +eps = Pi . singleton + +mkEpsFold :: Ord i => [i] -> EpsFold i +mkEpsFold = Pi . foldMap singleton + + + +-- | computes a base 'd' that can be used as: +-- +-- \( \varepsilon(i) = \varepsilon^{d^i} \) +suitableBase :: EpsFold i -> Int +suitableBase = max 2 . (1+) . maxMultiplicity . factors + +instance Show i => Show (EpsFold i) where + showsPrec d (Pi b) = showParen (d > app_prec) $ + showString "Pi " . showsPrec d (toList b) + where + app_prec = 10 + + +instance Ord i => Eq (EpsFold i) where + e1 == e2 = (e1 `compare` e2) == EQ + +instance Ord i => Ord (EpsFold i) where + (Pi e1) `compare` (Pi e2) = k `compare` j -- note that k and j are flipped here + where + j = maximum' $ e1 `difference` e2 + k = maximum' $ e2 `difference` e1 + -- note: If the terms are all the same, the difference of the bags is empty + -- and thus both e1e2 and e2e1 are Nothing and thus equal. + + -- otherwise, let j be the largest term that is in e1 but not in e2. + -- If e2 does not have any terms at all (Nothing) it will be bigger than e1 + -- + -- if e2 does have a term, let k be the largest one, then the + -- 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 + + +-- | Test if the epsfold has no pertubation at all (i.e. if it is \(\Pi_{\emptyset}\) +hasNoPertubation :: EpsFold i -> Bool +hasNoPertubation (Pi b) = null b + + +-------------------------------------------------------------------------------- +-- * Terms + +-- | A term 'Term c es' represents a term: +-- +-- \[ c \Pi_{i \in es} \varepsilon(i) +-- \] +-- +-- for a constant c and an arbitrarily small value \(\varepsilon\), +-- parameterized by i. +data Term i r = Term r (EpsFold i) deriving (Eq,Functor) + +-- | Lens to access the constant 'c' in the term. +constantFactor :: Lens' (Term i r) r +constantFactor = lens (\(Term c _) -> c) (\(Term _ es) c -> Term c es) + + +instance (Show i, Show r) => Show (Term i r) where + showsPrec d (Term c es) = showParen (d > up_prec) $ + showsPrec (up_prec + 1) c + . showString " * " + . showsPrec (up_prec + 1) es + where + up_prec = 5 + + +-- | Creates a singleton term +term :: r -> i -> Term i r +term r i = Term r $ eps i + +instance (Ord i, Ord r, Num r) => Ord (Term i r) where + (Term c e1) `compare` (Term d e2) = case (hasNoPertubation e1, hasNoPertubation e2) of + (True,True) -> c `compare` d + _ -> case (signum c, signum d) of + (-1,-1) -> e2 `compare` e1 + (0,0) -> e1 `compare` e2 + (1,1) -> e1 `compare` e2 + (-1,_) -> LT + (_,-1) -> GT + _ -> error "SoS: Term.ord absurd" + -- If both the eps folds are zero, and thus we just have constants + -- then we should compare the individual terms. + + -- if *one* of the two has an eps term, then we can choose eps to be + -- arbitrarily small, i.e. small enough so that that terms is + -- actually smaller than the other term. this is reflected since + -- findMax will then return a Noting, which is smaller than anything + -- else + + -- if both terms have epsilon terms, we first look at the sign. If + -- they have non-negative signs we compare the eps-folds as in the + -- paper. (Lemma 3.3). If both are negative, that reverses the + -- ordering. If the signs are different then we can base the + -- ordering on that. + +instance (Arbitrary r, Arbitrary (EpsFold i), Ord i) => Arbitrary (Term i r) where + arbitrary = Term <$> arbitrary <*> arbitrary + +-------------------------------------------------------------------------------- +-- * Symbolic + +-- | Represents a Sum of terms, i.e. a value that has the form: +-- +-- \[ +-- \sum c \Pi_i \varepsilon(i) +-- \] +-- +-- The terms are represented in order of decreasing significance. +-- +-- The main idea in this type is that, if symbolic values contains +-- \(\varepsilon(i)\) terms we can always order them. That is, two +-- Symbolic terms will be equal only if: +-- +-- - they contain *only* a constant term (that is equal) +-- - they contain the exact same \(\varepsilon\)-fold. +-- +newtype Symbolic i r = Sum (Map.Map (EpsFold i) r) deriving (Functor) + +-- | Produces a list of terms, in decreasing order of significance +toTerms :: Symbolic i r -> [Term i r] +toTerms (Sum m) = map (\(i,c) -> Term c i) . Map.toDescList $ m + +-- | Computing the Sign of an expression. (Nothing represents zero) +signOf :: (Num r, Eq r) => Symbolic i r -> Maybe Sign +signOf e = case List.dropWhile (== 0) . map (\(Term c _) -> signum c) $ toTerms e of + [] -> Nothing + (-1:_) -> Just Negative + _ -> Just Positive + +instance (Ord i, Eq r, Num r) => Eq (Symbolic i r) where + e1 == e2 = isNothing $ signOf (e1 - e2) + +instance (Ord i, Ord r, Num r) => Ord (Symbolic i r) where + e1 `compare` e2 = case signOf (e1 - e2) of + Nothing -> EQ + Just Negative -> LT + Just Positive -> GT + +instance (Ord i, Num r, Eq r) => Num (Symbolic i r) where + (Sum e1) + (Sum e2) = Sum $ Map.merge Map.preserveMissing -- insert things only in e1 + Map.preserveMissing -- insert things only in e2 + combine + e1 e2 + where + -- if things are in both e1 and e2, we add the constant terms. If they are non-zero + -- we use this value in the map. Otherwise we drop it. + combine = Map.zipWithMaybeMatched + (\_ c d -> let x = c + d in if x /= 0 then Just x else Nothing) + -- Symbolic $ Map.unionWith (+) ts ts' + + negate = fmap negate + + (Sum ts) * (Sum ts') = Sum $ Map.fromListWith (+) [ (es <> es',c*d) + | (es, c) <- Map.toList ts + , (es',d) <- Map.toList ts' + , c*d /= 0 + ] + + fromInteger x = constant (fromInteger x) + + signum s = case signOf s of + Nothing -> 0 + Just Negative -> (-1) + Just Positive -> 1 + + abs x | signum x == -1 = (-1)*x + | otherwise = x + + +instance (Show i, Show r) => Show (Symbolic i r) where + showsPrec d s = showParen (d > app_prec) $ + showString "Sum " . showsPrec d (toTerms s) + where + app_prec = 10 + +instance (Arbitrary r, Ord i, Arbitrary (EpsFold i)) => Arbitrary (Symbolic i r) where + arbitrary = Sum <$> arbitrary + +---------------------------------------- + +-- | Creates a constant symbolic value +constant :: Ord i => r -> Symbolic i r +constant c = Sum $ Map.singleton mempty c + +-- | Creates a symbolic vlaue with a single indexed term. If you just need a constant (i.e. non-indexed), use 'constant' +symbolic :: Ord i => r -> i -> Symbolic i r +symbolic r i = Sum $ Map.singleton (eps i) r + +-- | given the value c and the index i, creates the perturbed value +-- \(c + \varepsilon(i)\) +perturb :: (Num r, Ord i) => r -> i -> Symbolic i r +perturb c i = Sum $ Map.fromAscList [ (mempty,c) , (eps i,1) ] + + +-------------------------------------------------------------------------------- + +-- | The word specifiies how many *duplicates* there are. I.e. If the +-- Bag maps k to i, then k has multiplicity i+1. +newtype Bag a = Bag (Map.Map a Int) deriving (Show,Eq,Ord,Arbitrary) + +singleton :: k -> Bag k +singleton x = Bag $ Map.singleton x 0 + + +instance Foldable Bag where + -- ^ Takes multiplicity into account. + foldMap f (Bag m) = + Map.foldMapWithKey (\k d -> foldMap f (List.replicate (fromIntegral d+1) k)) m + null (Bag m) = Map.null m + +instance Ord k => Semigroup (Bag k) where + (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 + +-- | Computes the difference of the two maps +difference :: Ord a => Bag a -> Bag a -> Bag a +difference (Bag m1) (Bag m2) = Bag $ Map.differenceWith updateCount m1 m2 + where + updateCount i j = let d = i - j -- note that we should actually compare (i+1) and (j+1) + in if d <= 0 then Nothing -- we have no copies left + else Just $ d - 1 + + +maximum' :: Bag b -> Maybe b +maximum' (Bag m) = fmap fst . Map.lookupMax $ m + + +-- | maximum multiplicity of an element in the bag +maxMultiplicity :: Bag a -> Int +maxMultiplicity (Bag m) = maximum . (0:) . map (1+) . Map.elems $ m 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,531 @@ +{-# 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 Algorithms.Geometry.RayShooting.Naive +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 Data.List.NonEmpty (NonEmpty(..)) +import qualified Data.List.NonEmpty as NonEmpty +import qualified Data.List.Util as List +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 + +-------------------------------------------------------------------------------- +-- * 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 @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 @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 @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 @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,74 +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 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' = GV.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 = GV.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/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 @@ -11,10 +11,12 @@ -------------------------------------------------------------------------------- module Data.Geometry.Arrangement.Internal where +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 @@ -22,11 +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 Data.Sequence.Util -import qualified Data.Vector as V +import Data.Ord (Down (..)) +import qualified Data.Vector as V import Data.Vinyl.CoRec -------------------------------------------------------------------------------- @@ -52,39 +53,36 @@ -- | Builds an arrangement of \(n\) lines -- -- running time: \(O(n^2\log n\) -constructArrangement :: (Ord r, Fractional r) - => proxy s - -> [Line 2 r :+ l] - -> Arrangement s l () (Maybe l) () r -constructArrangement px ls = let b = makeBoundingBox ls - in constructArrangementInBox' px b ls +constructArrangement :: forall s l r. (Ord r, Fractional r) + => [Line 2 r :+ l] + -> Arrangement s l () (Maybe l) () r +constructArrangement ls = let b = makeBoundingBox ls + in constructArrangementInBox' b ls -- | Constructs the arrangemnet inside the box. note that the resulting box -- may be larger than the given box to make sure that all vertices of the -- arrangement actually fit. -- -- running time: \(O(n^2\log n\) -constructArrangementInBox :: (Ord r, Fractional r) - => proxy s - -> Rectangle () r - -> [Line 2 r :+ l] - -> Arrangement s l () (Maybe l) () r -constructArrangementInBox px rect ls = let b = makeBoundingBox ls - in constructArrangementInBox' px (b <> rect) ls +constructArrangementInBox :: forall s l r. (Ord r, Fractional r) + => Rectangle () r + -> [Line 2 r :+ l] + -> Arrangement s l () (Maybe l) () r +constructArrangementInBox rect ls = let b = makeBoundingBox ls + in constructArrangementInBox' (b <> rect) ls -- | Constructs the arrangemnet inside the box. (for parts to be useful, it is -- assumed this boxfits at least the boundingbox of the intersections in the -- Arrangement) -constructArrangementInBox' :: (Ord r, Fractional r) - => proxy s - -> Rectangle () r - -> [Line 2 r :+ l] - -> Arrangement s l () (Maybe l) () r -constructArrangementInBox' px rect ls = +constructArrangementInBox' :: forall s l r. (Ord r, Fractional r) + => Rectangle () r + -> [Line 2 r :+ l] + -> Arrangement s l () (Maybe l) () r +constructArrangementInBox' rect ls = Arrangement (V.fromList ls) subdiv rect (link parts' subdiv) where - subdiv = fromConnectedSegments px segs + subdiv = fromConnectedSegments segs & rawVertexData.traverse.dataVal .~ () (segs,parts') = computeSegsAndParts rect ls @@ -97,7 +95,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 +110,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 +119,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 +179,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,13 +190,10 @@ unBoundedParts rect ls = [tl] <> t <> [tr] <> reverse r <> [br] <> reverse b <> [bl] <> l where sideIntersections' = over (traverse._2) Just . sideIntersections ls - (t,r,b,l) = map4 sideIntersections' $ sides rect - (tl,tr,br,bl) = map4 ((,Nothing) . (^.core)) $ corners rect + Sides t r b l = sideIntersections' <$> sides rect + Corners tl tr br bl = (,Nothing) . (^.core) <$> corners rect -map4 :: (a -> b) -> (a,a,a,a) -> (b,b,b,b) -map4 f (a,b',c,d) = (f a, f b', f c, f d) - -- | Links the vertices of the outer boundary with those in the subdivision link :: Eq r => [(Point 2 r, a)] -> PlanarSubdivision s v (Maybe e) f r -> V.Vector (Point 2 r, VertexId' s, a) @@ -215,10 +210,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 @@ -247,7 +242,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 @@ -267,13 +262,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 - (t,r,b,l) = sides'' $ arr^.boundedArea - sides'' = map4 (\(ClosedLineSegment a c) -> LineSegment (Closed a) (Open c)) . sides + 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 @@ -31,6 +31,7 @@ import Linear.Matrix import Linear.V3 (V3(..)) + -------------------------------------------------------------------------------- -- * A d-dimensional ball @@ -75,6 +76,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 @@ -123,36 +125,43 @@ pattern Sphere c r = Boundary (Ball c r) {-# COMPLETE Sphere #-} - - +-- | +_BallSphere :: Iso (Disk p r) (Disk p s) (Circle p r) (Circle p s) +_BallSphere = _Boundary -------------------------------------------------------------------------------- -- * Disks and Circles, aka 2-dimensional Balls and Spheres type Disk p r = Ball 2 p r +-- | Given the center and the squared radius, constructs a disk pattern Disk :: Point 2 r :+ p -> r -> Disk p r pattern Disk c r = Ball c r {-# COMPLETE Disk #-} - type Circle p r = Sphere 2 p r +-- | Iso for converting between Disks and Circles, i.e. forgetting the boundary +_DiskCircle :: Iso (Disk p r) (Disk p s) (Circle p r) (Circle p s) +_DiskCircle = _BallSphere + +-- | Given the center and the squared radius, constructs a circle pattern Circle :: Point 2 r :+ p -> r -> Circle p r 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}) -disk :: (Eq r, Fractional r) +-- Just (Ball {_center = Point2 0.0 0.0 :+ (), _squaredRadius = 100.0}) +disk :: (Ord 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. @@ -184,16 +193,36 @@ newtype Touching p = Touching p deriving (Show,Eq,Ord,Functor,F.Foldable,T.Traversable) -- | No intersection, one touching point, or two points -type instance IntersectionOf (Line 2 r) (Circle p r) = [ NoIntersection - , Touching (Point 2 r) - , (Point 2 r, Point 2 r) - ] +type instance IntersectionOf (Line d r) (Sphere d p r) = [ NoIntersection + , Touching (Point d r) + , (Point d r, Point d r) + ] +instance {-# OVERLAPPABLE #-} (Ord r, Fractional r, Arity d) + => Line d r `HasIntersectionWith` Sphere d q r where + l `intersects` (Sphere (c :+ _) r) = let closest = pointClosestTo c l + in squaredEuclideanDist c closest <= r -instance (Ord r, Floating r) => (Line 2 r) `IsIntersectableWith` (Circle p r) where +instance {-# OVERLAPPING #-} (Ord r, Num r) => Line 2 r `HasIntersectionWith` Circle p r where + (Line p' v) `intersects` (Circle (c :+ _) r) = discr >= 0 + where + (Vector2 vx vy) = v + -- (px, py) is the vector/point after translating the circle s.t. it is centered at the + -- origin + (Vector2 px py) = p' .-. c - nonEmptyIntersection = defaultNonEmptyIntersection + -- let q lambda be the intersection point. We solve the following equation + -- solving the equation (q_x)^2 + (q_y)^2 = r^2 then yields the equation + -- L^2(vx^2 + vy^2) + L2(px*vx + py*vy) + px^2 + py^2 = 0 + -- where L = \lambda + aa = vx^2 + vy^2 + bb = 2 * (px * vx + py * vy) + cc = px^2 + py^2 - r^2 + discr = bb^2 - 4*aa*cc +instance (Ord r, Floating r) => Line 2 r `IsIntersectableWith` Circle p r where + + nonEmptyIntersection = defaultNonEmptyIntersection (Line p' v) `intersect` (Circle (c :+ _) r) = case discr `compare` 0 of LT -> coRec NoIntersection EQ -> coRec . Touching $ q' (lambda (+)) @@ -225,23 +254,30 @@ -- | A line segment may not intersect a circle, touch it, or intersect it -- properly in one or two points. -type instance IntersectionOf (LineSegment 2 p r) (Circle q r) = [ NoIntersection - , Touching (Point 2 r) - , Point 2 r - , (Point 2 r, Point 2 r) - ] +type instance IntersectionOf (LineSegment d p r) (Sphere d q r) = [ NoIntersection + , Touching (Point d r) + , Point d r + , (Point d r, Point d r) + ] +instance (Ord r, Fractional r, Arity d) + => LineSegment d p r `HasIntersectionWith` Sphere d q r where + seg `intersects` (Sphere (c :+ _) r) = let closest = pointClosestTo c (supportingLine seg) + in case squaredEuclideanDist c closest `compare` r of + LT -> True + EQ -> closest `intersects` seg + GT -> False -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 new file mode 100644 --- /dev/null +++ b/src/Data/Geometry/BezierSpline.hs @@ -0,0 +1,641 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE UndecidableInstances #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Data.Geometry.BezierSpline +-- Copyright : (C) Frank Staals +-- License : see the LICENSE file +-- Maintainer : Frank Staals +-------------------------------------------------------------------------------- +module Data.Geometry.BezierSpline( + BezierSpline (BezierSpline, Bezier2, Bezier3) + , controlPoints + , fromPointSeq + , endPoints + , Data.Geometry.BezierSpline.reverse + + , evaluate + , split + , splitMany + , splitMonotone + , splitByPoints + , extension + , extend + , growTo + , merge + , subBezier + , tangent + , approximate + , parameterOf + , snap + , intersectB + , colinear + , quadToCubic + ) where + +import Algorithms.Geometry.ConvexHull.GrahamScan +import Algorithms.Geometry.SmallestEnclosingBall.RIC +import Algorithms.Geometry.SmallestEnclosingBall.Types +import Control.Lens hiding (Empty) +import Data.Ext +import qualified Data.Foldable as F +import Data.Geometry.Ball +import Data.Geometry.Box.Internal +import Data.Geometry.Line +import Data.Geometry.LineSegment hiding (endPoints) +import Data.Geometry.Point +import Data.Geometry.PolyLine (PolyLine(..)) +import Data.Geometry.Polygon +import Data.Geometry.Polygon.Convex hiding (merge) +import Data.Geometry.Properties +import Data.Geometry.Transformation +import Data.Geometry.Vector hiding (init) +import Data.LSeq (LSeq) +import qualified Data.LSeq as LSeq +import Data.List (sort) +import qualified Data.List.NonEmpty as NonEmpty +import Data.Sequence (Seq(..)) +import qualified Data.Sequence as Seq +import Data.Traversable (fmapDefault,foldMapDefault) +import GHC.TypeNats +import qualified Test.QuickCheck as QC + +-- import Debug.Trace + +-------------------------------------------------------------------------------- + +-- | 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 + +-- | 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]) + 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]) + where + Bezier3 p q r s = fromPointSeq . Seq.fromList $ [p,q,r,s] +{-# COMPLETE Bezier3 #-} + +-- | Constructs the Bezier Spline from a given sequence of points. +fromPointSeq :: Seq (Point d r) -> BezierSpline n d r +fromPointSeq = BezierSpline . LSeq.promise . LSeq.fromSeq + + +deriving instance (Arity d, Eq r) => Eq (BezierSpline n d r) + +type instance Dimension (BezierSpline n d r) = d +type instance NumType (BezierSpline n d r) = r + +instance (Arity n, Arity d, QC.Arbitrary r) => QC.Arbitrary (BezierSpline n d r) where + arbitrary = fromPointSeq . Seq.fromList <$> QC.vector (fromIntegral . (1+) . natVal $ C @n) + +{- +instance (Arity n, Arity d, QC.Arbitrary r, Ord r) => QC.Arbitrary (BezierSpline n d r) where + arbitrary = fromPointSeq . Seq.fromList <$> allDifferent (fromIntegral . (1+) . natVal $ C @n) + +-- | Generates a set of unique items. +allDifferent :: (Ord a, QC.Arbitrary a) => Int -> QC.Gen [a] +allDifferent n = take n . Set.toList . go maxattempts mempty <$> QC.infiniteList + where + maxattempts = 100 + go 0 s _ = s -- too many attempts + go t s (x:xs) | Set.size s == n = s + | otherwise = go (t-1) (Set.insert x s) xs +-} + +instance (Arity d, Show r) => Show (BezierSpline n d r) where + show (BezierSpline ps) = + mconcat [ "BezierSpline", show $ length ps - 1, " ", show (F.toList ps) ] + +instance Arity d => Functor (BezierSpline n d) where + fmap = fmapDefault + +instance Arity d => Foldable (BezierSpline n d) where + foldMap = foldMapDefault + +instance Arity d => Traversable (BezierSpline n d) where + traverse f (BezierSpline ps) = BezierSpline <$> traverse (traverse f) ps + +instance (Fractional r, Arity d, Arity (d + 1), Arity n) + => IsTransformable (BezierSpline n d r) where + transformBy = transformPointFunctor + +instance PointFunctor (BezierSpline n d) where + pmap f = over controlPoints (fmap f) + +-------------------------------------------------------------------------------- + +-- | Convert a quadratic bezier to a cubic bezier. +quadToCubic :: Fractional r => BezierSpline 2 2 r -> BezierSpline 3 2 r +quadToCubic (Bezier2 a (Point b) c) = + Bezier3 a (Point $ (1/3)*^ (toVec a ^+^ 2*^b)) (Point $ (1/3)*^ (2*^ b ^+^ toVec c)) c + +-------------------------------------------------------------------------------- + +-- | Reverse a BezierSpline +reverse :: (Arity d, Ord r, Num r) => BezierSpline n d r -> BezierSpline n d r +reverse = controlPoints %~ LSeq.reverse + + +-- | Evaluate a BezierSpline curve at time t in [0, 1] +-- +-- pre: \(t \in [0,1]\) +evaluate :: (Arity d, Eq r, Num r) => BezierSpline n d r -> r -> Point d r +evaluate b 0 = fst $ endPoints b +evaluate b 1 = snd $ endPoints b +evaluate b t = evaluate' (b^.controlPoints.to LSeq.toSeq) + where + evaluate' = \case + (p :<| Empty) -> p + pts@(_ :<| tl) -> let (ini :|> _) = pts in evaluate' $ Seq.zipWith blend ini tl + _ -> error "evaluate: absurd" + blend p q = p .+^ t *^ (q .-. p) + +-- | Extract a tangent vector from the first to the second control 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 + +-- | Return the endpoints of the Bezier spline. +endPoints :: BezierSpline n d r -> (Point d r, Point d r) +endPoints b = let (p LSeq.:<| _) = b^.controlPoints + (_ LSeq.:|> q) = b^.controlPoints + in (p,q) + + + + +-- | Restrict a Bezier curve to the piece between parameters t < u in [0, 1]. +subBezier :: (KnownNat n, Arity d, Ord r, Num r) + => r -> r -> BezierSpline n d r -> BezierSpline n d r +subBezier t u = fst . split u . snd . split t + + +-- | Compute the convex hull of the control polygon of a 2-dimensional Bezier curve. +-- Should also work in any dimension, but convex hull is not yet implemented. +convexHullB :: (Ord r, Fractional r) => BezierSpline n 2 r -> ConvexPolygon () r +convexHullB = convexHull . NonEmpty.fromList . fmap ext . F.toList . _controlPoints + +-------------------------------------------------------------------------------- + +-- | Split a Bezier curve at time t in [0, 1] into two pieces. +split :: forall n d r. (KnownNat n, Arity d, Ord r, Num r) + => r -> BezierSpline n d r -> (BezierSpline n d r, BezierSpline n d r) +split t b | t < 0 = error "split: t < 0" -- ++ show t ++ " < 0" + | t > 1 = error "split: t > 1" -- ++ show t ++ " > 1" + | otherwise = splitRaw t b + + +-- | Split without parameter check. If t outside [0,1], will actually extend the curve +-- rather than split it. +splitRaw :: forall n d r. (KnownNat n, Arity d, Ord r, Num r) + => r -> BezierSpline n d r -> (BezierSpline n d r, BezierSpline n d r) +splitRaw t b = let n = fromIntegral $ natVal (C @n) + ps = collect t $ b^.controlPoints + in ( fromPointSeq . Seq.take (n + 1) $ ps + , fromPointSeq . Seq.drop (n + 0) $ ps + ) + +-- | implementation of splitRaw +collect :: (Arity d, Ord r, Num r) => r -> LSeq n (Point d r) -> Seq (Point d r) +collect t = go . LSeq.toSeq + where + go = \case + ps@(_ :<| Empty) -> ps + ps@(p :<| tl) -> let (ini :|> q) = ps in (p :<| go (Seq.zipWith blend ini tl)) :|> q + _ -> error "collect: absurd" + + blend p q = p .+^ t *^ (q .-. p) + +-- | Split a Bezier curve into many pieces. +-- Todo: filter out duplicate parameter values! +splitMany :: forall n d r. (KnownNat n, Arity d, Ord r, Fractional r) + => [r] -> BezierSpline n d r -> [BezierSpline n d r] +splitMany = splitManySorted . sort . map (restrict "splitMany" 0 1) + + where splitManySorted [] b' = [b'] + splitManySorted (t : ts) b' = let (a,c) = split t b' + in a : splitManySorted (map (rescale t) ts) c + rescale :: r -> r -> r + rescale 1 _ = 1 + rescale t u = (u - t) / (1 - t) + + +-- | Cut a Bezier curve into $x_i$-monotone pieces. +-- Can only be solved exactly for degree 4 or smaller. +-- Only gives rational result for degree 2 or smaller. +-- Currentlly implemented for degree 3. +splitMonotone :: (Arity d, Ord r, Enum r, Floating r) => Int -> BezierSpline 3 d r -> [BezierSpline 3 d r] +splitMonotone i b = splitMany (locallyExtremalParameters i b) b + +{- +type family RealTypeConstraint (n :: Nat) (r :: *) :: Constraint where + RealTypeConstraint 1 r = (Fractional r) + RealTypeConstraint 2 r = (Fractional r) + RealTypeConstraint 3 r = (Floating r) + RealTypeConstraint 4 r = (Floating r) + RealTypeConstraint 5 r = (Floating r) + RealTypeConstraint n r = TypeError "" +-} + +-- | Report all parameter values at which the derivative of the $i$th coordinate is 0. +locallyExtremalParameters :: (Arity d, Ord r, Enum r, Floating r) + => Int -> BezierSpline 3 d r -> [r] +locallyExtremalParameters i curve = + let [x1, x2, x3, x4] = map (view $ unsafeCoord i) $ F.toList $ _controlPoints curve + a = 3 * x4 - 9 * x3 + 9 * x2 - 3 * x1 + b = 6 * x1 - 12 * x2 + 6 * x3 + c = 3 * x2 - 3 * x1 + in filter (\j -> 0 <= j && j <= 1) $ solveQuadraticEquation a b c + + +-- | Subdivide a curve based on a sequence of points. +-- Assumes these points are all supposed to lie on the curve, and +-- snaps endpoints of pieces to these points. +-- (higher dimensions would work, but depends on convex hull) +splitByPoints :: (KnownNat n, Ord r, RealFrac r) + => r -> [Point 2 r] -> BezierSpline n 2 r -> [BezierSpline n 2 r] +splitByPoints treshold points curve = + let a = fst $ endPoints curve + b = snd $ endPoints curve + intern = filter (\p -> p /= a && p /= b) points + times = map (parameterOf treshold curve) intern + tipos = sort $ zip times intern + pieces = splitMany (map fst tipos) curve + stapts = a : map snd tipos + endpts = map snd tipos ++ [b] + in zipWith3 snapEndpoints stapts endpts pieces + +-------------------------------------------------------------------------------- + +-- | Extend a Bezier curve to a parameter value t outside the interval [0,1]. +-- For t < 0, returns a Bezier representation of the section of the underlying curve +-- from parameter value t until paramater value 0. For t > 1, the same from 1 to t. +-- +-- pre: t outside [0,1] +extension :: forall n d r. (KnownNat n, Arity d, Ord r, Num r) + => r -> BezierSpline n d r -> BezierSpline n d r +extension t b | t > 0 && t < 1 = error "extension: 0 < t < 1" -- ++ show t ++ " < 1" + | t <= 0 = fst $ splitRaw t b + | otherwise {- t >= 1-} = snd $ splitRaw t b + +-- | Extend a Bezier curve to a parameter value t outside the interval [0,1]. +-- For t < 0, returns a Bezier representation of the section of the underlying curve +-- from parameter value t until paramater value 1. For t > 1, the same from 0 to t. +-- +-- pre: t outside [0,1] +extend :: forall n d r. (KnownNat n, Arity d, Ord r, Num r) + => r -> BezierSpline n d r -> BezierSpline n d r +extend t b | t > 0 && t < 1 = error "extend: 0 < t < 1" -- ++ show t ++ " < 1" + | t <= 0 = snd $ splitRaw t b + | otherwise {- t >= 1 -} = fst $ splitRaw t b + + +-- | Extend a Bezier curve to a point not on the curve, but on / close +-- to the extended underlying curve. +growTo :: (KnownNat n, Arity d, Ord r, Fractional r) + => r -> Point d r -> BezierSpline n d r -> BezierSpline n d r +growTo treshold p b = + let t = extendedParameterOf treshold b p + r | t < 0 = extend t b + | t > 1 = extend t b + | otherwise = b + in r + +{- + +-- | Tries to fit a degree n Bezier curve through a list of points, with error parameter eps. +-- Either returns an appropriate curve, or fails. +fit :: r -> [Point 2 r] -> Maybe (Bezier n d r) +fit eps pts + +-} + + +-------------------------------------------------------------------------------- + +-- | Merge two Bezier pieces. Assumes they can be merged into a single piece of the same degree +-- (as would e.g. be the case for the result of a 'split' operation). +-- Does not test whether this is the case! +merge :: (KnownNat n, Arity d, Ord r, Fractional r) + => r -> BezierSpline n d r -> BezierSpline n d r -> BezierSpline n d r +merge treshold b1 b2 = let (p1, q1) = endPoints b1 + (p2, q2) = endPoints b2 + result | q1 /= p2 = error "merge: something is wrong, maybe need to flip one of the curves?" + | otherwise = snapEndpoints p1 q2 $ growTo treshold p1 b2 + in result + +-- need distance function between polyBeziers... + + +-------------------------------------------------------------------------------- + + +-- | Approximate Bezier curve by Polyline with given resolution. That +-- is, every point on the approximation will have distance at most res +-- to the Bezier curve. +approximate :: (KnownNat n, Arity d, Ord r, Fractional r) + => r -> BezierSpline n d r -> PolyLine d () r +approximate res = PolyLine . fmap ext . approximate' res + +-- | implementation of approximate; returns the polyline as an LSeq +approximate' :: (KnownNat n, Arity d, Ord r, Fractional r) + => r -> BezierSpline n d r -> LSeq 2 (Point d r) +approximate' res = LSeq.promise . LSeq.fromSeq . go + where + go b | flat res b = let (p,q) = endPoints b in Seq.fromList [p,q] + | otherwise = let (b1, b2) = split 0.5 b in go b1 <> Seq.drop 1 (go b2) + +-- | Test whether a Bezier curve can be approximated by a single line segment, +-- given the resolution parameter. +flat :: (KnownNat n, Arity d, Ord r, Fractional r) => r -> BezierSpline n d r -> Bool +flat r b = let p = fst $ endPoints b + q = snd $ endPoints b + s = ClosedLineSegment (p :+ ()) (q :+ ()) + e t = squaredEuclideanDistTo (evaluate b t) s < r ^ 2 + in qdA p q < r ^ 2 || all e [0.1, 0.2, 0.3, 0.4, 0.5, 0.6, 0.7, 0.8, 0.9] + +-- seems this is now covered by approximate +-- +-- +-- -- | Approximate curve as line segments where no point on the curve is further away +-- -- from the nearest line segment than the given tolerance. +-- lineApproximate :: (Ord r, Fractional r) => r -> BezierSpline 3 2 r -> [Point 2 r] +-- lineApproximate eps bezier +-- | colinear eps bezier = +-- [ bezier^.controlPoints.to LSeq.head +-- , bezier^.controlPoints.to LSeq.last ] +-- | otherwise = +-- let (b1, b2) = split 0.5 bezier +-- in lineApproximate eps b1 ++ tail (lineApproximate eps b2) + +-- If both control points are on the same side of the straight line from the start and end +-- points then the curve is guaranteed to be within 3/4 of the distance from the straight line +-- to the furthest control point. +-- Otherwise, if the control points are on either side of the straight line, the curve is +-- guaranteed to be within 4/9 of the maximum distance from the straight line to a control +-- point. +-- Also: 3/4 * sqrt(v) = sqrt (9/16 * v) +-- 4/9 * sqrt(v) = sqrt (16/81 * v) +-- So: 3/4 * sqrt(v) < eps => +-- sqrt(9/16 * v) < eps => +-- 9/16*v < eps*eps +-- | Return True if the curve is definitely completely covered by a line of thickness +-- twice the given tolerance. May return false negatives but not false positives. +colinear :: (Ord r, Fractional r) => r -> BezierSpline 3 2 r -> Bool +colinear eps (Bezier3 !a !b !c !d) = sqBound < eps*eps + where ld = flip squaredEuclideanDistTo (lineThrough a d) + sameSide = ccw a d b == ccw a d c + maxDist = max (ld b) (ld c) + sqBound + | sameSide = 9/16 * maxDist + | otherwise = 16/81 * maxDist + +-------------------------------------------------------------------------------- + +-- general d depends on convex hull +-- parameterOf :: (Arity d, Ord r, Fractional r) => BezierSpline n d r -> Point d r -> r +-- +-- | Given a point on (or within distance treshold to) a Bezier curve, return the parameter value +-- of some point on the curve within distance treshold from p. +-- For points farther than treshold from the curve, the function will attempt to return the +-- parameter value of an approximate locally closest point to the input point, but no guarantees. +parameterOf :: (KnownNat n, Ord r, RealFrac r) => r -> BezierSpline n 2 r -> Point 2 r -> r +parameterOf treshold b p | closeEnough treshold p $ fst $ endPoints b = 0 + | closeEnough treshold p $ snd $ endPoints b = 1 + | otherwise = parameterInterior treshold b p + +-- parameterInterior is slow, look into algebraic solution? + +-- general d depends on convex hull +parameterInterior :: (KnownNat n, Ord r, RealFrac r) => r -> BezierSpline n 2 r -> Point 2 r -> r +parameterInterior treshold b p | sqrad (F.toList $ view controlPoints b) < (0.5 * treshold)^2 = 0.5 + | otherwise = + let (b1, b2) = split 0.5 b + recurse1 = 0.5 * parameterInterior treshold b1 p + recurse2 = 0.5 + 0.5 * parameterInterior treshold b2 p + chb1 = _simplePolygon $ convexHullB b1 + chb2 = _simplePolygon $ convexHullB b2 + in1 = squaredEuclideanDistTo p chb1 < treshold^2 + in2 = squaredEuclideanDistTo p chb2 < treshold^2 + result | in1 && in2 = betterFit b p recurse1 recurse2 + | in2 && not in2 = recurse1 + | not in2 && in2 = recurse2 + | squaredEuclideanDistTo p chb1 < squaredEuclideanDistTo p chb2 = recurse1 + | otherwise = recurse2 + in result + +-- | Given a point on (or close to) the extension of a Bezier curve, return the corresponding +-- parameter value, which might also be smaller than 0 or larger than 1. +-- (For points far away from the curve, the function will return the parameter value of +-- an approximate locally closest point to the input point.) +-- +-- This implementation is not robust: might return a locally closest point on the curve +-- even though the point lies on another part of the curve. For points on the actual +-- curve, use parameterOf instead. +extendedParameterOf :: (Arity d, KnownNat n, Ord r, Fractional r) + => r -> BezierSpline n d r -> Point d r -> r +extendedParameterOf treshold b p | p == fst (endPoints b) = 0 + | p == snd (endPoints b) = 1 + | otherwise = binarySearch treshold (qdA p . evaluate b) (-100) 100 + +---------------------------------------- +-- * Stuff to implement parameterOf and extendedParameterOf + +betterFit :: (KnownNat n, Arity d, Ord r, Fractional r) + => BezierSpline n d r -> Point d r -> r -> r -> r +betterFit b p t u = + let q = evaluate b t + r = evaluate b u + in if qdA q p < qdA r p then t else u + +-------------------------------------------------------------------------------- + +-- | Given two Bezier curves, list all intersection points. +-- Not exact, since for degree >= 3 there is no closed form. +-- (In principle, this algorithm works in any dimension +-- but this requires convexHull, area/volume, and intersect.) +intersectB :: (KnownNat n, Ord r, RealFrac r) => r -> BezierSpline n 2 r -> BezierSpline n 2 r -> [Point 2 r] +intersectB treshold a b + | a == b = [fst $ endPoints b, snd $ endPoints b] -- should really return the whole curve + | otherwise = let [a1, _a2, _a3, a4] = F.toList $ _controlPoints a + [b1, _b2, _b3, b4] = F.toList $ _controlPoints b + in intersectPointsPoints treshold [a1, a4] [b1, b4] + ++ intersectPointsInterior treshold [a1, a4] b + ++ intersectPointsInterior treshold [b1, b4] a + ++ intersectInteriorInterior treshold [a1, a4, b1, b4] a b + + +closeEnough :: (Arity d, Ord r, Fractional r) => r -> Point d r -> Point d r -> Bool +closeEnough treshold p q = qdA p q < treshold ^ 2 + +intersectPointsPoints :: (Ord r, Fractional r) => r -> [Point 2 r] -> [Point 2 r] -> [Point 2 r] +intersectPointsPoints treshold ps = filter (\q -> any (closeEnough treshold q) ps) + +intersectPointsInterior :: (KnownNat n, Ord r, RealFrac r) => r -> [Point 2 r] -> BezierSpline n 2 r -> [Point 2 r] +intersectPointsInterior treshold ps b = + let [b1, _b2, _b3, b4] = F.toList $ _controlPoints b + nearc p = closeEnough treshold (snap treshold b p) p + near1 = closeEnough treshold b1 + near4 = closeEnough treshold b4 + in filter (\p -> nearc p && not (near1 p) && not (near4 p)) ps + + +intersectInteriorInterior :: (KnownNat n, Ord r, RealFrac r) => r -> [Point 2 r] -> BezierSpline n 2 r -> BezierSpline n 2 r -> [Point 2 r] +intersectInteriorInterior treshold forbidden a b = + let cha = _simplePolygon $ convexHullB a + chb = _simplePolygon $ convexHullB b + (a1, a2) = split 0.5 a + (b1, b2) = split 0.5 b + points = F.toList (view controlPoints a) + ++ F.toList (view controlPoints b) + approx = average points + done | not (cha `intersectsP` chb) = True + | sqrad points < treshold^2 = True + | otherwise = False + result | not (cha `intersectsP` chb) = [] + | any (closeEnough treshold approx) forbidden = [] + | otherwise = [approx] + recurse = intersectInteriorInterior treshold forbidden a1 b1 + ++ intersectInteriorInterior treshold forbidden a1 b2 + ++ intersectInteriorInterior treshold forbidden a2 b1 + ++ intersectInteriorInterior treshold forbidden a2 b2 + in if done then result else recurse + +sqrad :: (Ord r, RealFrac r) => [Point 2 r] -> r +sqrad points | length points < 2 = error "sqrad: not enough points" +sqrad points | otherwise = + let rationalPoints :: [Point 2 Rational] -- smallestEnclosingDisk fails on Floats + rationalPoints = map (traverse %~ realToFrac) points + (a : b : cs) = map (:+ ()) rationalPoints + diskResult = smallestEnclosingDisk' a b cs + in realToFrac $ view squaredRadius $ view enclosingDisk $ diskResult + +average :: (Functor t, Foldable t, Arity d, Fractional r) => t (Point d r) -> Point d r +average ps = origin .+^ foldr1 (^+^) (fmap toVec ps) ^/ realToFrac (length ps) + +{- +type instance IntersectionOf (BezierSpline n 2 r) (BezierSpline n 2 r) = [ NoIntersection + , [Point 2 r] + , BezierSpline n 2 r + ] + + +instance (KnownNat n, Ord r, Fractional r) => (BezierSpline n 2 r) `IsIntersectableWith` (BezierSpline n 2 r) where + nonEmptyIntersection = defaultNonEmptyIntersection + a `intersect` b = a `intersectB` b +-} + + +-- function to test whether two convex polygons intersect +-- for speed, first test bounding boxes +-- maybe would be faster to directly compare bounding boxes of points, rather than +-- call convex hull first? +intersectsP :: (Ord r, Fractional r) => SimplePolygon p r -> SimplePolygon p r -> Bool +intersectsP p q | not $ boundingBox p `intersects` boundingBox q = False + | otherwise = or [a `intersects` b | a <- p & listEdges, b <- q & listEdges] + || (any (flip insidePolygon p) $ map _core $ F.toList $ polygonVertices q) + || (any (flip insidePolygon q) $ map _core $ F.toList $ polygonVertices p) + -- first test bounding box? + + +{- + +instance (Arity d, Floating r) => IsBoxable (BezierSpline 3 d r) where + boundingBox b = foldr1 (<>) $ map (\i -> boundingBox (extremal True i b) <> boundingBox (extremal False i b)) [1 .. d] + +-- | Find extremal points on curve in the $i$th dimension. +extremal :: Floating r => Bool -> Int -> BezierSpline 3 d r -> Point d r +extremal pos i b = + let [p1, _, _, p4] = F.toList $ view controlPoints b + ps = map evaluate $ locallyExtremalParameters i b + candidates = [p1, p4] ++ ps + result | pos = maximumBy (unsafeCoord i . snd) candidates + | not pos = minimumBy (unsafeCoord i . snd) candidates + in result + +-} + + +-------------------------------------------------------------------------------- + +snapEndpoints :: (KnownNat n, Arity d, Ord r, Fractional r) + => Point d r -> Point d r -> BezierSpline n d r -> BezierSpline n d r +snapEndpoints p q curve = + let points = F.toList $ _controlPoints curve + middle = tail . init $ points + new = [p] ++ middle ++ [q] + in fromPointSeq $ Seq.fromList new + + +-- | Snap a point close to a Bezier curve to the curve. +snap :: (KnownNat n, Ord r, RealFrac r) => r -> BezierSpline n 2 r -> Point 2 r -> Point 2 r +snap treshold b = evaluate b . parameterOf treshold b + +-------------------------------------------------------------------------------- +-- * Helper functions + +-- | Solve equation of the form ax^2 + bx + c = 0. +-- If there are multiple solutions, report in ascending order. +-- Attempt at a somewhat robust implementation. +solveQuadraticEquation :: (Ord r, Enum r, Floating r) => r -> r -> r -> [r] +solveQuadraticEquation 0 0 0 = [0..] -- error "infinite solutions" +solveQuadraticEquation _ 0 0 = [0] +solveQuadraticEquation 0 _ 0 = [0] +solveQuadraticEquation 0 0 _ = [] +solveQuadraticEquation a b 0 = sort [0, -b / a] +solveQuadraticEquation a 0 c | (-c / a) < 0 = [] + | (-c / a) == 0 = [0] + | (-c / a) > 0 = [sqrt (-c / a)] +solveQuadraticEquation 0 b c = [-c / b] +solveQuadraticEquation a b c | almostzero a || almostzero (a / b) || almostzero (a / c) = solveQuadraticEquation 0 b c +solveQuadraticEquation a b c = + let d = b^2 - 4 * a * c + result | d == 0 = [-b / (2 * a)] + | d > 0 = [(-b - sqrt d) / (2 * a), (-b + sqrt d) / (2 * a)] + | otherwise = [] + in result + -- trace ("soving equation " ++ show a ++ "x^2 + " ++ show b ++ "x + " ++ show c ++ " = 0") $ result + +-- | Test whether a floating point number is close enough to zero, taking rounding errors into account. +almostzero :: (Floating r, Ord r) => r -> Bool +almostzero x = abs x < epsilon + +-- | Treshold for rounding errors in almostzero test. +-- TODO: Should be different depending on the type. +epsilon :: Floating r => r +epsilon = 0.0001 + + + +-- | This function tests whether a value lies within bounds of a given interval. +-- If not, graciously continues with value snapped to interval. +-- This should never happen, but apparently it sometimes does? +restrict :: (Ord r) => String -> r -> r -> r -> r +restrict f l r x | l > r = error $ f <> ": restrict [l,r] is not an interval" --error $ f ++ ": restrict: [" ++ show l ++ ", " ++ show r ++ "] is not an interval" + -- | x < l = trace (f ++ ": restricting " ++ show x ++ " to [" ++ show l ++ ", " ++ show r ++ "]") l + -- | x > r = trace (f ++ ": restricting " ++ show x ++ " to [" ++ show l ++ ", " ++ show r ++ "]") r + | otherwise = x + + +binarySearch :: (Ord r, Fractional r) + => r -> (r -> r) -> r -> r -> r +binarySearch treshold f l r + | abs (f l - f r) < treshold = restrict "binarySearch" l r m + | derivative f m > 0 = restrict "binarySearch" l r $ binarySearch treshold f l m + | otherwise = restrict "binarySearch" l r $ binarySearch treshold f m r + where m = (l + r) / 2 + +derivative :: Fractional r => (r -> r) -> r -> r +derivative f x = (f (x + delta) - f x) / delta + where delta = 0.0000001 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,7 +1,15 @@ +-------------------------------------------------------------------------------- +-- | +-- Module : Data.Geometry.Boundary +-- Copyright : (C) Frank Staals +-- License : see the LICENSE file +-- Maintainer : Frank Staals +-------------------------------------------------------------------------------- module Data.Geometry.Boundary where -import Data.Geometry.Properties -import Data.Geometry.Transformation +import Control.Lens (iso,Iso) +import Data.Geometry.Properties +import Data.Geometry.Transformation -------------------------------------------------------------------------------- @@ -12,6 +20,10 @@ type instance NumType (Boundary g) = NumType g type instance Dimension (Boundary g) = Dimension g + +-- | Iso for converting between things with a boundary and without its boundary +_Boundary :: Iso g h (Boundary g) (Boundary h) +_Boundary = iso Boundary (\(Boundary b) -> b) -- | Result of a query that asks if something is Inside a g, *on* the boundary diff --git a/src/Data/Geometry/Box.hs b/src/Data/Geometry/Box.hs --- a/src/Data/Geometry/Box.hs +++ b/src/Data/Geometry/Box.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE DeriveAnyClass #-} {-# OPTIONS_GHC -fno-warn-orphans #-} @@ -13,57 +11,29 @@ -- Orthogonal \(d\)-dimensiontal boxes (e.g. rectangles) -- -------------------------------------------------------------------------------- -module Data.Geometry.Box( module Data.Geometry.Box.Internal - , topSide, leftSide, bottomSide, rightSide - , sides, sides' - ) where +module Data.Geometry.Box + ( module Data.Geometry.Box.Internal + , module Data.Geometry.Box.Corners + , module Data.Geometry.Box.Sides + , inBox' + ) where import Control.DeepSeq +import Data.Geometry.Box.Corners import Data.Geometry.Box.Internal -import Data.Geometry.LineSegment +import Data.Geometry.Box.Sides import Data.Geometry.Vector +import Data.Geometry.Point +import Data.Geometry.Boundary -------------------------------------------------------------------------------- deriving instance (NFData p, NFData r, Arity d) => NFData (Box d p r) -topSide :: Num r => Rectangle p r -> LineSegment 2 p r -topSide = (\(l,r,_,_) -> ClosedLineSegment l r) . corners - --- | Oriented from *left to right* -bottomSide :: Num r => Rectangle p r -> LineSegment 2 p r -bottomSide = (\(_,_,r,l) -> ClosedLineSegment l r) . corners - --- -leftSide :: Num r => Rectangle p r -> LineSegment 2 p r -leftSide = (\(t,_,_,b) -> ClosedLineSegment b t) . corners - --- | The right side, oriented from *bottom* to top -rightSide :: Num r => Rectangle p r -> LineSegment 2 p r -rightSide = (\(_,t,b,_) -> ClosedLineSegment b t) . corners - - --- | The sides of the rectangle, in order (Top, Right, Bottom, Left). The sides --- themselves are also oriented in clockwise order. If, you want them in the --- same order as the functions `topSide`, `bottomSide`, `leftSide`, and --- `rightSide`, use `sides'` instead. -sides :: Num r => Rectangle p r -> ( LineSegment 2 p r - , LineSegment 2 p r - , LineSegment 2 p r - , LineSegment 2 p r - ) -sides = (\(t,r,b,l) -> (t,flipSegment r,flipSegment b,l)) . sides' - - --- | The sides of the rectangle. The order of the segments is (Top, Right, --- Bottom, Left). Note that the segments themselves, are oriented as described --- by the functions topSide, bottomSide, leftSide, rightSide (basically: from --- left to right, and from bottom to top). If you want the segments oriented --- along the boundary of the rectangle, use the `sides` function instead. -sides' :: Num r => Rectangle p r -> ( LineSegment 2 p r - , LineSegment 2 p r - , LineSegment 2 p r - , LineSegment 2 p r - ) -sides' r = (topSide r, rightSide r, bottomSide r, leftSide r) +-- | Compute whether the point lies inside, on the boundary of, or +-- outside the box. +inBox' :: (Arity d, Ord r) => Point d r -> Box d p r -> PointLocationResult +q `inBox'` b | q `insideBox` b = Inside + | q `inBox` b = OnBoundary + | otherwise = Outside diff --git a/src/Data/Geometry/Box/Corners.hs b/src/Data/Geometry/Box/Corners.hs new file mode 100644 --- /dev/null +++ b/src/Data/Geometry/Box/Corners.hs @@ -0,0 +1,80 @@ +{-# 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 + +import Control.Lens (makeLenses,Ixed(..),Index, IxValue,(%~),(&),(^?!)) +import Data.Ext +import Data.Functor.Apply +import Data.Geometry.Box.Internal +import Data.Geometry.Directions +import Data.Geometry.Point +import Data.Semigroup.Foldable.Class +import Data.Semigroup.Traversable.Class +import Data.Util +import GHC.Generics (Generic) + +-------------------------------------------------------------------------------- + +-- | A data type rperesenting the corners of a box. the order of the +-- Corners is 'northWest, northEast, southEast, southWest', i.e. in +-- clockwise order starting from the topleft. +data Corners a = Corners { _northWest :: !a + , _northEast :: !a + , _southEast :: !a + , _southWest :: !a + } deriving (Show,Eq,Ord,Generic,Functor,Foldable,Traversable) +makeLenses ''Corners + + +type instance Index (Corners a) = InterCardinalDirection +type instance IxValue (Corners a) = a + +instance Ixed (Corners a) where + ix = \case + NorthWest -> northWest + NorthEast -> northEast + SouthEast -> southEast + SouthWest -> southWest + +instance Foldable1 Corners +instance Traversable1 Corners where + traverse1 f (Corners a b c d) = Corners <$> f a <.> f b <.> f c <.> f d + +instance Applicative Corners where + pure x = Corners x x x x + (Corners f g h i) <*> (Corners a b c d) = Corners (f a) (g b) (h c) (i d) + +instance Semigroup a => Semigroup (Corners a) where + s <> s' = (<>) <$> s <*> s' +instance Monoid a => Monoid (Corners a) where + mempty = pure mempty + + +-------------------------------------------------------------------------------- + +{- 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, +-- the extra values in the Bottom points are taken from the Bottom point +corners :: Num r => Rectangle p r -> Corners (Point 2 r :+ p) +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 + + +-------------------------------------------------------------------------------- + +-- | Gets the corners in a particular direction +cornersInDirection :: CardinalDirection -> Corners p -> Two p +cornersInDirection d c = (\icd -> c^?!ix icd) <$> interCardinalsOf d 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 @@ -1,6 +1,7 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE AllowAmbiguousTypes #-} -------------------------------------------------------------------------------- -- | -- Module : Data.Geometry.Box.Internal @@ -15,22 +16,24 @@ import Control.DeepSeq import Control.Lens +import Data.Bifoldable import Data.Bifunctor +import Data.Bitraversable import Data.Ext +import qualified Data.Foldable as F import Data.Geometry.Point import Data.Geometry.Properties -import Data.Geometry.Transformation +import Data.Geometry.Transformation.Internal import Data.Geometry.Vector import qualified Data.Geometry.Vector as V import qualified Data.List.NonEmpty as NE import qualified Data.Range as R import qualified Data.Semigroup.Foldable as F -import qualified Data.Foldable as F import qualified Data.Vector.Fixed as FV import Data.Vinyl.CoRec (asA) import GHC.Generics (Generic) import GHC.TypeLits -import Test.QuickCheck(Arbitrary(..)) +import Test.QuickCheck (Arbitrary(..)) -------------------------------------------------------------------------------- @@ -60,6 +63,10 @@ } deriving Generic makeLenses ''Box + + + + -- | Given the point with the lowest coordinates and the point with highest -- coordinates, create a box. box :: Point d r :+ p -> Point d r :+ p -> Box d p r @@ -83,6 +90,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 @@ -99,7 +107,9 @@ 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 `HasIntersectionWith` Box d q r + +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') @@ -108,12 +118,14 @@ r `intersect'` s = asA @(R.Range r) $ r `intersect` s instance Arity d => Bifunctor (Box d) where - bimap :: forall p q r s. (p -> q) -> (r -> s) -> Box d p r -> Box d q s - bimap f g (Box mi ma) = Box (bimap g' f mi) (bimap g' f ma) + bimap = bimapDefault +instance Arity d => Bifoldable (Box d) where + bifoldMap = bifoldMapDefault +instance Arity d => Bitraversable (Box d) where + bitraverse f g (Box mi ma) = Box <$> bitraverse (tr g) f mi <*> bitraverse (tr g) f ma where - g' :: Functor g => g (Point d r) -> g (Point d s) - g' = fmap (fmap g) - + tr :: (Traversable t, Applicative f) => (r -> f s) -> t (Point d r) -> f (t (Point d s)) + tr g' = traverse $ traverse g' -- -- In principle this should also just work for Boxes in higher dimensions. It is just -- -- that we need a better way to compute their corners @@ -136,7 +148,10 @@ 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 `HasIntersectionWith` Box d p r where + intersects = inBox + +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 @@ -179,12 +194,24 @@ 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) @@ -193,19 +220,19 @@ -- 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 -- | Given a dimension, get the width of the box in that dimension. Dimensions are 1 indexed. -- --- >>> widthIn (C :: C 1) (boundingBoxList' [origin, Point3 1 2 3] :: Box 3 () Int) +-- >>> widthIn @1 (boundingBoxList' [origin, Point3 1 2 3] :: Box 3 () Int) -- 1 --- >>> widthIn (C :: C 3) (boundingBoxList' [origin, Point3 1 2 3] :: Box 3 () Int) +-- >>> widthIn @3 (boundingBoxList' [origin, Point3 1 2 3] :: Box 3 () Int) -- 3 -widthIn :: forall proxy p i d r. (Arity d, Arity (i - 1), Num r, ((i-1)+1) <= d) - => proxy i -> Box d p r -> r -widthIn _ = view (V.element (C :: C (i - 1))) . size +widthIn :: forall i p d r. (Arity d, Arity (i - 1), Num r, ((i-1)+1) <= d) + => Box d p r -> r +widthIn = view (V.element @(i-1)) . size -- | Same as 'widthIn' but with a runtime int instead of a static dimension. @@ -225,38 +252,24 @@ type Rectangle = Box 2 +-- | -- >>> width (boundingBoxList' [origin, Point2 1 2] :: Rectangle () Int) -- 1 -- >>> width (boundingBoxList' [origin] :: Rectangle () Int) -- 0 width :: Num r => Rectangle p r -> r -width = widthIn (C :: C 1) +width = widthIn @1 +-- | -- >>> height (boundingBoxList' [origin, Point2 1 2] :: Rectangle () Int) -- 2 -- >>> height (boundingBoxList' [origin] :: Rectangle () Int) -- 0 height :: Num r => Rectangle p r -> r -height = widthIn (C :: C 2) +height = widthIn @2 --- | 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, --- the extra values in the Bottom points are taken from the Bottom point -corners :: Num r => Rectangle p r -> ( Point 2 r :+ p - , Point 2 r :+ p - , Point 2 r :+ p - , Point 2 r :+ p - ) -corners r = let w = width r - p = (_maxP r)&core %~ _cwMax - q = (_minP r)&core %~ _cwMin - in ( p&core.xCoord %~ (subtract w) - , p - , q&core.xCoord %~ (+ w) - , q - ) +-------------------------------------------------------------------------------- -------------------------------------------------------------------------------- -- * Constructing bounding boxes @@ -264,7 +277,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 @@ -282,3 +295,29 @@ instance IsBoxable (Box d p r) where boundingBox (Box m m') = Box (m&extra .~ ()) (m'&extra .~ ()) + +instance IsBoxable c => IsBoxable (c :+ e) where + boundingBox = boundingBox . view core + +-------------------------------------------------------------------------------- +-- * Distances + +instance (Num r, Ord r) => HasSquaredEuclideanDistance (Box 2 p r) where + pointClosestToWithDistance q bx = + case ((q^.xCoord) `R.inRange` hor, (q^.yCoord) `R.inRange` ver) of + (False,False) -> if q^.yCoord < b + then closest (Point2 l b) (Point2 r b) + else closest (Point2 l t) (Point2 r t) + (True, False) -> if q^.yCoord < b + then (q&yCoord .~ b, sq $ q^.yCoord - b) + else (q&yCoord .~ t, sq $ q^.yCoord - t) + (False, True) -> if q^.xCoord < l + then (q&yCoord .~ l, sq $ q^.xCoord - l) + else (q&yCoord .~ r, sq $ q^.xCoord - r) + (True, True) -> (q, 0) -- point lies inside the box + where + Vector2 hor@(R.Range' l r) ver@(R.Range' b t) = extent bx + sq x = x*x + closest p1 p2 = let d1 = squaredEuclideanDist q p1 + d2 = squaredEuclideanDist q p2 + in if d1 < d2 then (p1, d1) else (p2, d2) diff --git a/src/Data/Geometry/Box/Sides.hs b/src/Data/Geometry/Box/Sides.hs new file mode 100644 --- /dev/null +++ b/src/Data/Geometry/Box/Sides.hs @@ -0,0 +1,98 @@ +{-# 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' + + , sideDirections + ) where + +import Data.Geometry.Directions +import Data.Geometry.Box.Internal +import Data.Geometry.Box.Corners +import Data.Geometry.LineSegment.Internal +import Data.Functor.Apply +import Data.Semigroup.Foldable.Class +import Data.Semigroup.Traversable.Class +import GHC.Generics (Generic) +import Control.Lens(makeLenses, Ixed(..), Index, IxValue) + +-------------------------------------------------------------------------------- + +-- | The four sides of a rectangle +data Sides a = Sides { _north :: !a + , _east :: !a + , _south :: !a + , _west :: !a + } deriving (Show,Read,Eq,Generic,Ord,Foldable,Functor,Traversable) +makeLenses ''Sides + +instance Applicative Sides where + pure x = Sides x x x x + (Sides f g h i) <*> (Sides a b c d) = Sides (f a) (g b) (h c) (i d) + +instance Foldable1 Sides +instance Traversable1 Sides where + traverse1 f (Sides a b c d) = Sides <$> f a <.> f b <.> f c <.> f d + +instance Semigroup a => Semigroup (Sides a) where + s <> s' = (<>) <$> s <*> s' +instance Monoid a => Monoid (Sides a) where + mempty = pure mempty + + +type instance Index (Sides a) = CardinalDirection +type instance IxValue (Sides a) = a + +instance Ixed (Sides a) where + ix = \case + North -> north + East -> east + South -> south + West -> west + +-- | Constructs a Sides value that indicates the appropriate +-- direction. +sideDirections :: Sides CardinalDirection +sideDirections = Sides North East South West + +-------------------------------------------------------------------------------- + +topSide :: Num r => Rectangle p r -> LineSegment 2 p r +topSide = (\(Corners l r _ _) -> ClosedLineSegment l r) . corners + +-- | Oriented from *left to right* +bottomSide :: Num r => Rectangle p r -> LineSegment 2 p r +bottomSide = (\(Corners _ _ r l) -> ClosedLineSegment l r) . corners + +-- +leftSide :: Num r => Rectangle p r -> LineSegment 2 p r +leftSide = (\(Corners t _ _ b) -> ClosedLineSegment b t) . corners + +-- | The right side, oriented from *bottom* to top +rightSide :: Num r => Rectangle p r -> LineSegment 2 p r +rightSide = (\(Corners _ t b _) -> ClosedLineSegment b t) . corners + + +-- | The sides of the rectangle, in order (Top, Right, Bottom, Left). The sides +-- themselves are also oriented in clockwise order. If, you want them in the +-- same order as the functions `topSide`, `bottomSide`, `leftSide`, and +-- `rightSide`, use `sides'` instead. +sides :: Num r => Rectangle p r -> Sides (LineSegment 2 p r) +sides r = let Corners nw ne se sw = corners r + in Sides (ClosedLineSegment nw ne) (ClosedLineSegment ne se) + (ClosedLineSegment se sw) (ClosedLineSegment sw nw) + +-- | The sides of the rectangle. The order of the segments is (Top, Right, +-- Bottom, Left). Note that the segments themselves, are oriented as described +-- by the functions topSide, bottomSide, leftSide, rightSide (basically: from +-- left to right, and from bottom to top). If you want the segments oriented +-- along the boundary of the rectangle, use the `sides` function instead. +sides' :: Num r => Rectangle p r -> Sides (LineSegment 2 p r) +sides' r = Sides (topSide r) (rightSide r) (bottomSide r) (leftSide r) diff --git a/src/Data/Geometry/Directions.hs b/src/Data/Geometry/Directions.hs new file mode 100644 --- /dev/null +++ b/src/Data/Geometry/Directions.hs @@ -0,0 +1,56 @@ +-------------------------------------------------------------------------------- +-- | +-- 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 + , oppositeDirection + + , InterCardinalDirection(..) + -- , _NorthWest, _NorthEast, _SouthEast, _SouthWest + + , interCardinalsOf + ) where + +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 + +-------------------------------------------------------------------------------- +-- * Functions on Cardinal Directions + +-- | Computes the direction opposite to the given one. +oppositeDirection :: CardinalDirection -> CardinalDirection +oppositeDirection = \case + North -> South + East -> West + South -> North + West -> East + +-------------------------------------------------------------------------------- + +-- | Intercardinal directions +data InterCardinalDirection = NorthWest | NorthEast | SouthEast | SouthWest + deriving (Show,Read,Eq,Ord,Enum,Generic) +-- makePrisms ''InterCardinalDirection + +-------------------------------------------------------------------------------- +-- * Functions on InterCardinal Directions + +-- | Get the two intercardinal directions, in increasing order, +-- corresponding to the cardinal direction. +interCardinalsOf :: CardinalDirection -> Two InterCardinalDirection +interCardinalsOf = \case + North -> Two NorthWest NorthEast + East -> Two NorthEast SouthEast + South -> Two SouthEast SouthWest + West -> Two SouthWest NorthWest 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 @@ -12,9 +19,9 @@ -- | Returns Nothing if the input line is vertical -- Maps a line l: y = ax + b to a point (a,-b) -dualPoint :: (Fractional r, Eq r) => Line 2 r -> Maybe (Point 2 r) +dualPoint :: (Fractional r, Ord r) => Line 2 r -> Maybe (Point 2 r) dualPoint l = (\(a,b) -> Point2 a (-b)) <$> toLinearFunction l -- | Pre: the input line is not vertical -dualPoint' :: (Fractional r, Eq r) => Line 2 r -> Point 2 r +dualPoint' :: (Fractional r, Ord r) => Line 2 r -> Point 2 r dualPoint' = fromJust . dualPoint diff --git a/src/Data/Geometry/Ellipse.hs b/src/Data/Geometry/Ellipse.hs new file mode 100644 --- /dev/null +++ b/src/Data/Geometry/Ellipse.hs @@ -0,0 +1,63 @@ +{-# 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 + , ellipseMatrix + , unitEllipse + , circleToEllipse, ellipseToCircle, _EllipseCircle + ) where + +import Control.Lens +import Data.Ext +import Data.Geometry.Ball +import Data.Geometry.Matrix +import Data.Geometry.Transformation +import Data.Geometry.Point +import Data.Geometry.Properties +import Data.Geometry.Vector + +-------------------------------------------------------------------------------- + +-- | A type representing planar ellipses +newtype Ellipse r = Ellipse { _affineTransformation :: Transformation 2 r } + deriving (Show,Eq,Functor,Foldable,Traversable) +makeLenses ''Ellipse + +type instance Dimension (Ellipse r) = 2 +type instance NumType (Ellipse r) = r + +instance Num r => IsTransformable (Ellipse r) where + transformBy t (Ellipse t') = Ellipse $ t |.| t' + + +ellipseMatrix :: Iso (Ellipse r) (Ellipse s) (Matrix 3 3 r) (Matrix 3 3 s) +ellipseMatrix = affineTransformation.transformationMatrix + +-- | Ellipse representing the unit circle +unitEllipse :: Num r => Ellipse r +unitEllipse = Ellipse $ Transformation identityMatrix + +-------------------------------------------------------------------------------- +-- | Converting between ellipses and circles + +_EllipseCircle :: (Floating r, Eq r) => Prism' (Ellipse r) (Circle () r) +_EllipseCircle = prism' circleToEllipse ellipseToCircle + +ellipseToCircle :: (Num r, Eq r) => Ellipse r -> Maybe (Circle () r) +ellipseToCircle e = case e^.ellipseMatrix of + Matrix (Vector3 (Vector3 sx 0 x) + (Vector3 0 sy y) + (Vector3 0 0 1) + ) + | sx == sy -> Just $ Circle (ext $ Point2 x y) (sx*sx) + _ -> Nothing + +circleToEllipse :: Floating r => Circle p r -> Ellipse r +circleToEllipse (Circle (Point v :+ _) rr) = Ellipse $ translation v |.| uniformScaling (sqrt rr) 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 @@ -31,7 +46,6 @@ makeLenses ''HalfLine deriving instance (Show r, Arity d) => Show (HalfLine d r) -deriving instance (Eq r, Arity d) => Eq (HalfLine d r) deriving instance (NFData r, Arity d) => NFData (HalfLine d r) deriving instance Arity d => Functor (HalfLine d) @@ -41,6 +55,19 @@ type instance Dimension (HalfLine d r) = d 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 + instance HasStart (HalfLine d r) where type StartCore (HalfLine d r) = Point d r type StartExtra (HalfLine d r) = () @@ -73,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 @@ -84,88 +111,129 @@ , 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 `HasIntersectionWith` Line 2 r +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 +instance (Ord r, Fractional r) => HalfLine 2 r `HasIntersectionWith` HalfLine 2 r --- 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 `HasIntersectionWith` HalfLine 2 r --- nonEmptyIntersection NoHalfLineHalfLineIntersection = False --- nonEmptyIntersection _ = True +instance (Ord r, Fractional r) => LineSegment 2 () r `IsIntersectableWith` HalfLine 2 r where + nonEmptyIntersection = defaultNonEmptyIntersection --- 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 + 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 +instance (Ord r, Fractional r, Arity d) => Point d r `HasIntersectionWith` HalfLine d r where + intersects = onHalfLine --- 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) +instance (Ord r, Fractional r, Arity d) => Point d r `IsIntersectableWith` HalfLine d r where + nonEmptyIntersection = defaultNonEmptyIntersection + p `intersect` hl | p `intersects` hl = coRec p + | otherwise = coRec NoIntersection --- nonEmptyIntersection NoSegmentHalfLineIntersection = False --- nonEmptyIntersection _ = True --- 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) (Boundary (Rectangle p r)) = + [ NoIntersection, Point 2 r, (Point 2 r, Point 2 r) , LineSegment 2 () r] +type instance IntersectionOf (HalfLine 2 r) (Rectangle p r) = [ NoIntersection + , Point 2 r + , LineSegment 2 () r + ] +instance (Ord r, Fractional r) + => HalfLine 2 r `HasIntersectionWith` Boundary (Rectangle p 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 `HasIntersectionWith` Rectangle p r + +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 @@ -38,13 +38,14 @@ -------------------------------------------------------------------------------- --- | A Halfspace in \(d\) dimensions. +-- | A Halfspace in \(d\) dimensions. Note that the intended side of +-- the halfspace is already indicated by the normal vector of the +-- bounding plane. newtype HalfSpace d r = HalfSpace { _boundingPlane :: HyperPlane d r } deriving Generic makeLenses ''HalfSpace deriving instance (Arity d, Show r) => Show (HalfSpace d r) -deriving instance (Arity d, Eq r) => Eq (HalfSpace d r) -- deriving instance (NFData r, Arity d) => NFData (HalfSpace d r) deriving instance Arity d => Functor (HalfSpace d) deriving instance Arity d => Foldable (HalfSpace d) @@ -55,23 +56,29 @@ deriving instance (Arity d, Arity (d + 1), Fractional r) => IsTransformable (HalfSpace d r) +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 + in h == h' && signum d == 1 + -------------------------------------------------------------------------------- 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 @@ -91,31 +98,31 @@ type instance IntersectionOf (Point d r) (HalfSpace d r) = [NoIntersection, Point d r] -instance (Num r, Ord r, Arity d) => Point d r `IsIntersectableWith` HalfSpace d r where - nonEmptyIntersection = defaultNonEmptyIntersection - +instance (Num r, Ord r, Arity d) => Point d r `HasIntersectionWith` HalfSpace d r where q `intersects` h = q `inHalfSpace` h /= Outside +instance (Num r, Ord r, Arity d) => Point d r `IsIntersectableWith` HalfSpace d r where + nonEmptyIntersection = defaultNonEmptyIntersection q `intersect` h | q `intersects` h = coRec q | otherwise = coRec NoIntersection - type instance IntersectionOf (Line d r) (HalfSpace d r) = [NoIntersection, HalfLine d r, Line d r] +instance (Fractional r, Ord r) => Line 2 r `HasIntersectionWith` HalfSpace 2 r instance (Fractional r, Ord r) => Line 2 r `IsIntersectableWith` HalfSpace 2 r where 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 @@ -11,26 +18,31 @@ import Data.Geometry.Transformation import Data.Geometry.Vector import GHC.Generics (Generic) +import Data.Kind import GHC.TypeLits -------------------------------------------------------------------------------- -- | Hyperplanes embedded in a \(d\) dimensional space. -data HyperPlane (d :: Nat) (r :: *) = HyperPlane { _inPlane :: !(Point d r) - , _normalVec :: !(Vector d r) - } deriving Generic +data HyperPlane (d :: Nat) (r :: Type) = + HyperPlane { _inPlane :: !(Point d r) + , _normalVec :: !(Vector d r) + } deriving Generic makeLenses ''HyperPlane type instance Dimension (HyperPlane d r) = d type instance NumType (HyperPlane d r) = r deriving instance (Arity d, Show r) => Show (HyperPlane d r) -deriving instance (Arity d, Eq r) => Eq (HyperPlane d r) deriving instance (NFData r, Arity d) => NFData (HyperPlane d r) deriving instance Arity d => Functor (HyperPlane d) deriving instance Arity d => Foldable (HyperPlane d) deriving instance Arity d => Traversable (HyperPlane d) +instance (Arity d, Eq r, Fractional r) => Eq (HyperPlane d r) where + (HyperPlane p u) == h@(HyperPlane _ v) = p `intersects` h && u `isScalarMultipleOf` v + + instance (Arity d, Arity (d + 1), Fractional r) => IsTransformable (HyperPlane d r) where transformBy t (HyperPlane p v) = HyperPlane (transformBy t p) (transformBy t v) @@ -38,9 +50,11 @@ type instance IntersectionOf (Point d r) (HyperPlane d r) = [NoIntersection, Point d r] +instance (Num r, Eq r, Arity d) => Point d r `HasIntersectionWith` HyperPlane d r where + q `intersects` (HyperPlane p n) = n `dot` (q .-. p) == 0 + instance (Num r, Eq r, Arity d) => Point d r `IsIntersectableWith` HyperPlane d r where nonEmptyIntersection = defaultNonEmptyIntersection - q `intersects` (HyperPlane p n) = n `dot` (q .-. p) == 0 q `intersect` h | q `intersects` h = coRec q | otherwise = coRec NoIntersection @@ -68,16 +82,35 @@ pattern Plane :: Point 3 r -> Vector 3 r -> Plane r pattern Plane p n = HyperPlane p n +{-# COMPLETE Plane #-} +-- | Produces a plane. If r lies counter clockwise of q w.r.t. p then +-- 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} 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 in HyperPlane p (u `cross` v) +instance OnSideUpDownTest (Plane r) where + -- >>> (Point3 5 5 5) `onSideUpDown` from3Points origin (Point3 1 0 0) (Point3 0 1 0) + -- Above + -- >>> (Point3 5 5 (-5)) `onSideUpDown` from3Points origin (Point3 1 0 0) (Point3 0 1 0) + -- Below + -- >>> (Point3 5 5 0) `onSideUpDown` from3Points origin (Point3 1 0 0) (Point3 0 1 0) + -- On + q `onSideUpDown` (Plane p n) = let v = q .-. p in case (n `dot` v) `compare` 0 of + LT -> Below + EQ -> On + GT -> Above 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 `HasIntersectionWith` Plane r + +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 @@ -107,3 +140,23 @@ instance HasSupportingPlane (HyperPlane d r) where supportingPlane = id + + +-- | Given +-- * a plane, +-- * a unit vector in the plane that will represent the y-axis (i.e. the "view up" vector), and +-- * a point in the plane, +-- +-- computes the plane coordinates of the given point, using the +-- inPlane point as the origin, the normal vector of the plane as the +-- unit vector in the "z-direction" and the view up vector as the +-- y-axis. +-- +-- >>> planeCoordinatesWith (Plane origin (Vector3 0 0 1)) (Vector3 0 1 0) (Point3 10 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) + +planeCoordinatesTransform :: Num r => Plane r -> Vector 3 r -> Transformation 3 r +planeCoordinatesTransform (HyperPlane o n) v = rotateTo (Vector3 (v `cross` n) v n) + |.| translation ((-1) *^ toVec o) 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,30 +1,37 @@ -{-# 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(..) - , pattern OpenInterval - , pattern ClosedInterval - , pattern Interval + -- * 1 dimensional Intervals + Interval (Interval, OpenInterval,ClosedInterval) + , fromRange, toRange + , _Range - -- * querying the start and end of intervals + -- * querying the start and end of intervals , HasStart(..), HasEnd(..) -- * Working with intervals - , inInterval + , intersectsInterval, inInterval , shiftLeft' + , asProperInterval, flipInterval + , module Data.Range - ) - where + ) where import Control.DeepSeq -import Control.Lens (makeLenses, (^.),(%~),(&), Lens') +import Control.Lens (Iso', Lens', iso, (%~), (&), (^.)) import Data.Bifunctor import Data.Bitraversable import Data.Ext import qualified Data.Foldable as F +import Data.Geometry.Boundary import Data.Geometry.Properties import Data.Range -import Data.Semigroup(Arg(..)) +import Data.Semigroup (Arg (..)) import qualified Data.Traversable as T import Data.Vinyl import Data.Vinyl.CoRec @@ -34,20 +41,36 @@ -------------------------------------------------------------------------------- -- | An Interval is essentially a 'Data.Range' but with possible payload -newtype Interval a r = GInterval { _unInterval :: Range (r :+ a) } +-- +-- 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 (Range (r :+ a)) deriving (Eq,Generic,Arbitrary) -makeLenses ''Interval +-- | 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 +fromRange :: Range (r :+ a) -> Interval a r +fromRange = GInterval + deriving instance (NFData a, NFData r) => NFData (Interval a r) instance (Show a, Show r) => Show (Interval a r) where show ~(Interval l u) = concat [ "Interval (", show l, ") (", show u,")"] instance Functor (Interval a) where - fmap = T.fmapDefault + fmap f (GInterval r) = GInterval $ fmap (first f) r instance F.Foldable (Interval a) where - foldMap = T.foldMapDefault + foldMap f (GInterval r) = foldMap (f . (^.core)) r instance T.Traversable (Interval a) where traverse f (GInterval r) = GInterval <$> T.traverse f' r @@ -58,14 +81,39 @@ bimap f g (GInterval r) = GInterval $ fmap (bimap g f) r +-- type instance IntersectionOf r (Interval b r) = [NoIntersection, r] +-- -- somehow: GHC does not understand the r here cannot be 'Interval a r' itself :( +-- instance Ord r => r `HasIntersectionWith` Interval b r where +-- x `intersects` r = x `inRange` fmap (^.core) (r^._Range ) + + +-- instance Ord r => r `IsIntersectableWith` Interval b r where +-- x `intersect` r | x `intersects` r = coRec x +-- | otherwise = coRec NoIntersection + -- | Test if a value lies in an interval. Note that the difference between -- 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^.unInterval ) +intersectsInterval :: Ord r => r -> Interval a r -> Bool +x `intersectsInterval` r = x `inRange` fmap (^.core) (r^._Range ) +-- | Compute where the given query value is with respect to the interval. +-- +-- Note that even if the boundary of the interval is open we may +-- return "OnBoundary". +inInterval :: Ord r => r -> Interval a r -> PointLocationResult +x `inInterval` (Interval l r) = + case x `compare` (l^.unEndPoint.core) of + LT -> Outside + EQ -> OnBoundary + GT -> case x `compare` (r^.unEndPoint.core) of + LT -> Inside + EQ -> OnBoundary + GT -> Outside + + pattern OpenInterval :: (r :+ a) -> (r :+ a) -> Interval a r pattern OpenInterval l u = GInterval (OpenRange l u) @@ -87,7 +135,8 @@ instance HasStart (Interval a r) where type StartCore (Interval a r) = r type StartExtra (Interval a r) = a - start = unInterval.lower.unEndPoint + start = _Range.lower.unEndPoint + {-# INLINE start #-} class HasEnd t where type EndCore t @@ -97,30 +146,45 @@ instance HasEnd (Interval a r) where type EndCore (Interval a r) = r type EndExtra (Interval a r) = a - end = unInterval.upper.unEndPoint + end = _Range.upper.unEndPoint + {-# INLINE end #-} type instance Dimension (Interval a r) = 1 type instance NumType (Interval a r) = r -type instance IntersectionOf (Interval a r) (Interval a r) = [NoIntersection, Interval a r] +type instance IntersectionOf (Interval a r) (Interval b r) + = [NoIntersection, Interval (Either a b) r] -instance Ord r => (Interval a r) `IsIntersectableWith` (Interval a r) where +instance Ord r => Interval a r `HasIntersectionWith` Interval b r +instance Ord r => Interval a r `IsIntersectableWith` Interval b 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 - r' = fmap f r - s' = fmap f s + r' :: Range (Arg r (r :+ Either a b)) + r' = fmap (\(x :+ a) -> Arg x (x :+ Left a)) r + s' :: Range (Arg r (r :+ Either a b)) + s' = fmap (\(x :+ b) -> Arg x (x :+ Right b)) s g (Arg _ x) = x +-- | Shifts the interval to the left by delta +shiftLeft' :: Num r => r -> Interval a r -> Interval a r +shiftLeft' delta = fmap (subtract delta) -shiftLeft' :: Num r => r -> Interval a r -> Interval a r -shiftLeft' x = fmap (subtract x) + +-- | Makes sure the start and endpoint are oriented such that the +-- starting value is smaller than the ending value. +asProperInterval :: Ord r => Interval p r -> Interval p r +asProperInterval i | (i^.start.core) > (i^.end.core) = flipInterval i + | otherwise = i + +-- | Flips the start and endpoint of the interval. +flipInterval :: Interval a r -> Interval a r +flipInterval = _Range %~ \(Range s t) -> Range t s 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 @@ -55,7 +62,7 @@ => [i] -> IntervalTree i r fromIntervals is = foldr insert (createTree pts) is where - endPoints (toRange -> Range' a b) = [a,b] + endPoints (asRange -> Range' a b) = [a,b] pts = List.sort . concatMap endPoints $ is -- | Lists the intervals. We don't guarantee anything about the order @@ -100,7 +107,7 @@ => i -> IntervalTree i r -> IntervalTree i r insert i (IntervalTree t) = IntervalTree $ insert' t where - ri@(Range a b) = toRange i + ri@(Range a b) = asRange i insert' Nil = Nil insert' (Internal l nd@(_splitPoint -> m) r) @@ -119,7 +126,7 @@ => i -> IntervalTree i r -> IntervalTree i r delete i (IntervalTree t) = IntervalTree $ delete' t where - ri@(Range a b) = toRange i + ri@(Range a b) = asRange i delete' Nil = Nil delete' (Internal l nd@(_splitPoint -> m) r) @@ -137,15 +144,13 @@ -- | Anything that looks like an interval class IntervalLike i where - toRange :: i -> Range (NumType i) + asRange :: i -> Range (NumType i) instance IntervalLike (Range r) where - toRange = id + asRange = id instance IntervalLike (Interval p r) where - toRange = fmap (^.core) . _unInterval - - + asRange = fmap (^.core) . toRange -------------------------------------------------------------------------------- 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 @@ -183,6 +189,6 @@ asSingleton :: (1 <= d, Arity d) => PointSet (LSeq 1) d p r -> Either (Point d r :+ p) (PointSet (LSeq 2) d p r) -asSingleton v = case v^.element (C :: C 0) of +asSingleton v = case v^.element @0 of (p :<| s) | null s -> Left p -- only one lement _ -> Right $ unsafeCoerce v 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 @@ -16,12 +16,13 @@ ) where import Control.Lens +import Data.Bifunctor import Data.Ext import Data.Geometry.Boundary import Data.Geometry.Box import Data.Geometry.Line.Internal import Data.Geometry.LineSegment -import Data.Geometry.Point +import Data.Geometry.Point.Internal import Data.Geometry.Properties import Data.Geometry.SubLine import Data.Geometry.Transformation @@ -48,39 +49,41 @@ 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 - nonEmptyIntersection = defaultNonEmptyIntersection +instance (Eq r, Fractional r, Arity d) => Point d r `HasIntersectionWith` Line d r where intersects = onLine +instance {-# OVERLAPPING #-} (Ord r, Num r) => Point 2 r `HasIntersectionWith` Line 2 r where + intersects = onLine2 + +instance (Eq r, Fractional r, Arity d) => Point d r `IsIntersectableWith` Line d r where + nonEmptyIntersection = defaultNonEmptyIntersection 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 +instance {-# OVERLAPPING #-} (Ord r, Num r) => Point 2 r `IsIntersectableWith` Line 2 r where nonEmptyIntersection = defaultNonEmptyIntersection - intersects = onLine2 p `intersect` l | p `intersects` l = coRec p | otherwise = coRec NoIntersection - type instance IntersectionOf (Line 2 r) (Boundary (Rectangle p r)) = [ NoIntersection, Point 2 r, (Point 2 r, Point 2 r) , LineSegment 2 () r] - instance (Ord r, Fractional r) - => (Line 2 r) `IsIntersectableWith` (Boundary (Rectangle p r)) where + => Line 2 r `HasIntersectionWith` Boundary (Rectangle p r) +instance (Ord r, Fractional r) + => Line 2 r `IsIntersectableWith` Boundary (Rectangle p r) where nonEmptyIntersection = defaultNonEmptyIntersection line' `intersect` (Boundary rect) = case asAP segP of [sl'] -> case fromUnbounded sl' of Nothing -> error "intersect: line x boundary rect; unbounded line? absurd" - Just sl'' -> coRec $ sl''^.re _SubLine + Just sl'' -> coRec $ first (either id id) $ sl''^.re _SubLine [] -> case nub' $ asAP pointP of [p] -> coRec p [p,q] -> coRec (p,q) _ -> coRec NoIntersection _ -> error "intersect; line x boundary rect; absurd" where - (t,r,b,l) = sides' rect + Sides t r b l = sides' rect ints = map (\s -> sl `intersect` toSL s) [t,r,b,l] nub' = map L.head . L.group . L.sort @@ -95,21 +98,22 @@ => proxy t -> [t] asAP _ = mapMaybe (asA @t) ints - segP = Proxy :: Proxy (SubLine 2 () (UnBounded r) r) + segP = Proxy :: Proxy (SubLine 2 (Either () ()) (UnBounded r) r) pointP = Proxy :: Proxy (Point 2 r) type instance IntersectionOf (Line 2 r) (Rectangle p r) = [ NoIntersection, Point 2 r, LineSegment 2 () r] - instance (Ord r, Fractional r) - => (Line 2 r) `IsIntersectableWith` (Rectangle p r) where + => Line 2 r `HasIntersectionWith` Rectangle p r +instance (Ord r, Fractional r) + => 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 #-} -------------------------------------------------------------------------------- @@ -16,7 +15,9 @@ import Control.DeepSeq import Control.Lens import qualified Data.Foldable as F -import Data.Geometry.Point +import Data.Geometry.Point.Internal +import Data.Geometry.Point.Orientation.Degenerate +import Data.Geometry.Point.Class import Data.Geometry.Properties import Data.Geometry.Vector import Data.Ord (comparing) @@ -34,8 +35,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, ")" ] @@ -53,6 +61,8 @@ instance (Arity d, Eq r, Fractional r) => Eq (Line d r) where l@(Line p _) == m = l `isParallelTo` m && p `onLine` m + + instance (Arbitrary r, Arity d, Num r, Eq r) => Arbitrary (Line d r) where arbitrary = do p <- arbitrary q <- suchThat arbitrary (/= p) @@ -67,9 +77,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) @@ -78,7 +90,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) @@ -101,8 +113,17 @@ isParallelTo :: (Eq r, Fractional r, Arity d) => Line d r -> Line d r -> Bool (Line _ u) `isParallelTo` (Line _ v) = u `isScalarMultipleOf` v - -- TODO: Maybe use a specialize pragma for 2D (see intersect instance for two lines.) +{-# RULES +"isParallelTo/isParallelTo2" [3] + forall (l1 :: forall r. Line 2 r) l2. isParallelTo l1 l2 = isParallelTo2 l1 l2 +#-} +{-# INLINE[2] isParallelTo #-} +-- | Check whether two lines are parallel +isParallelTo2 :: (Eq r, Num r) => Line 2 r -> Line 2 r -> Bool +isParallelTo2 (Line _ (Vector2 ux uy)) (Line _ (Vector2 vx vy)) = denom == 0 + where + denom = vy * ux - vx * uy -- | Test if point p lies on line l -- @@ -120,9 +141,6 @@ p `onLine2` (Line q v) = ccw p q (q .+^ v) == CoLinear - - - -- | Get the point at the given position along line, where 0 corresponds to the -- anchorPoint of the line, and 1 to the point anchorPoint .+^ directionVector pointAt :: (Num r, Arity d) => r -> Line d r -> Point d r @@ -135,15 +153,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 +-- +-- The point (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. @@ -152,14 +179,14 @@ , Line 2 r ] -instance (Eq r, Fractional r) => (Line 2 r) `IsIntersectableWith` (Line 2 r) where - +instance (Ord r, Num r) => Line 2 r `HasIntersectionWith` Line 2 r where + l1 `intersects` l2@(Line q _) = not (l1 `isParallelTo2` l2) || q `onLine2` l1 +instance (Ord r, Fractional r) => Line 2 r `IsIntersectableWith` Line 2 r where nonEmptyIntersection = defaultNonEmptyIntersection - l@(Line p ~(Vector2 ux uy)) `intersect` (Line q ~v@(Vector2 vx vy)) - | areParallel = if q `onLine` l then coRec l - else coRec NoIntersection + | areParallel = if q `onLine2` l then coRec l + else coRec NoIntersection | otherwise = coRec r where r = q .+^ alpha *^ v @@ -205,9 +232,10 @@ 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) +toLinearFunction :: forall r. (Fractional r, Ord r) => Line 2 r -> Maybe (r,r) toLinearFunction l@(Line _ ~(Vector2 vx vy)) = match (l `intersect` verticalLine (0 :: r)) $ (H $ \NoIntersection -> Nothing) -- l is a vertical line @@ -215,30 +243,44 @@ :& (H $ \_ -> Nothing) -- l is a vertical line (through x=0) :& RNil + +instance (Fractional r, Arity d) => HasSquaredEuclideanDistance (Line d r) where + pointClosestTo p (Line a m) = a .+^ (t0 *^ m) + where + -- see https://monkeyproofsolutions.nl/wordpress/how-to-calculate-the-shortest-distance-between-a-point-and-a-line/ + t0 = numerator / divisor + numerator = (p .-. a) `dot` m + divisor = m `dot` m + + -- | Result of a side test data SideTestUpDown = Below | On | Above deriving (Show,Read,Eq,Ord) --- | Given a point q and a line l, compute to which side of l q lies. For --- vertical lines the left side of the line is interpeted as below. --- --- >>> Point2 10 10 `onSideUpDown` (lineThrough origin $ Point2 10 5) --- Above --- >>> Point2 10 10 `onSideUpDown` (lineThrough origin $ Point2 (-10) 5) --- Above --- >>> Point2 5 5 `onSideUpDown` (verticalLine 10) --- Below --- >>> Point2 5 5 `onSideUpDown` (lineThrough origin $ Point2 (-3) (-3)) --- On -onSideUpDown :: (Ord r, Num r) => Point 2 r -> Line 2 r -> SideTestUpDown -q `onSideUpDown` (Line p v) = let r = p .+^ v - f z = (z^.xCoord, -z^.yCoord) - minBy g a b = F.minimumBy (comparing g) [a,b] - maxBy g a b = F.maximumBy (comparing g) [a,b] - in case ccw (minBy f p r) (maxBy f p r) q of - CCW -> Above - CW -> Below - CoLinear -> On +class OnSideUpDownTest t where + onSideUpDown :: (d ~ Dimension t, r ~ NumType t, Ord r, Num r) + => Point d r -> t -> SideTestUpDown +instance OnSideUpDownTest (Line 2 r) where + -- | Given a point q and a line l, compute to which side of l q lies. For + -- vertical lines the left side of the line is interpeted as below. + -- + -- >>> Point2 10 10 `onSideUpDown` (lineThrough origin $ Point2 10 5) + -- Above + -- >>> Point2 10 10 `onSideUpDown` (lineThrough origin $ Point2 (-10) 5) + -- Above + -- >>> Point2 5 5 `onSideUpDown` (verticalLine 10) + -- Below + -- >>> Point2 5 5 `onSideUpDown` (lineThrough origin $ Point2 (-3) (-3)) + -- On + q `onSideUpDown` (Line p v) = let r = p .+^ v + f z = (z^.xCoord, -z^.yCoord) + minBy g a b = F.minimumBy (comparing g) [a,b] + maxBy g a b = F.maximumBy (comparing g) [a,b] + in case ccw (minBy f p r) (maxBy f p r) q of + CCW -> Above + CW -> Below + CoLinear -> On + -- | Result of a side test data SideTest = LeftSide | OnLine | RightSide deriving (Show,Read,Eq,Ord) @@ -267,6 +309,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 @@ -1,5 +1,6 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} -------------------------------------------------------------------------------- -- | -- Module : Data.Geometry.LineSegment @@ -10,285 +11,128 @@ -- Line segment data type and some basic functions on line segments -- -------------------------------------------------------------------------------- -module Data.Geometry.LineSegment( LineSegment - , pattern LineSegment - , pattern LineSegment' - , pattern ClosedLineSegment - , endPoints +module Data.Geometry.LineSegment + ( LineSegment(LineSegment, LineSegment', ClosedLineSegment, OpenLineSegment) + , endPoints - , _SubLine - , module Data.Geometry.Interval + , _SubLine + , module Data.Geometry.Interval + , toLineSegment + , orderedEndPoints + , segmentLength + , sqSegmentLength + , sqDistanceToSeg, sqDistanceToSegArg + , flipSegment - , toLineSegment - , onSegment - , orderedEndPoints - , segmentLength - , sqDistanceToSeg, sqDistanceToSegArg - , flipSegment - ) where + , interpolate, sampleLineSegment + , ordAtX, ordAtY, xCoordAt, yCoordAt + ) where -import Control.Arrow ((&&&)) -import Control.DeepSeq -import Control.Lens +-- import Control.Lens import Data.Ext -import qualified Data.Foldable as F +-- import qualified Data.Foldable as F +import Data.Geometry.Boundary import Data.Geometry.Box.Internal +import Data.Geometry.Box.Sides import Data.Geometry.Interval hiding (width, midPoint) -import Data.Geometry.Line.Internal +import Data.Geometry.LineSegment.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 +-- import Data.Geometry.SubLine +import Data.Util +-- import Data.Vinyl.CoRec +-- import Data.Bifunctor +-- import Data.Either +-- import Data.Maybe (mapMaybe) --------------------------------------------------------------------------------- --- * 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 #-} - -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) +type instance IntersectionOf (LineSegment 2 p r) (Boundary (Rectangle q r)) = + [ NoIntersection, Point 2 r, Two (Point 2 r) , LineSegment 2 () r ] -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) +type instance IntersectionOf (LineSegment 2 p r) (Rectangle q r) = + [ NoIntersection, Point 2 r, LineSegment 2 (Maybe p) r ] -instance PointFunctor (LineSegment d p) where - pmap f ~(LineSegment s e) = LineSegment (s&unEndPoint.core %~ f) - (e&unEndPoint.core %~ f) +instance (Fractional r, Ord r) + => LineSegment 2 p r `HasIntersectionWith` Boundary (Rectangle q r) where + seg `intersects` (Boundary rect) = any (seg `intersects`) $ sides rect -instance Arity d => IsBoxable (LineSegment d p r) where - boundingBox l = boundingBox (l^.start.core) <> boundingBox (l^.end.core) +instance (Fractional r, Ord r) => LineSegment 2 p r `HasIntersectionWith` Rectangle q r where + seg@(LineSegment p q) `intersects` rect = + inRect p || inRect q || any (seg `intersects`) (sides rect) || bothOpenAndOnBoundary seg + where + inRect = \case + Open (a :+ _) -> a `insideBox` rect -- if strictly inside the seg intersects. + Closed (a :+ _) -> a `inBox` rect -- in or on the boundary is fine -instance (Fractional r, Arity d, Arity (d + 1)) => IsTransformable (LineSegment d p r) where - transformBy = transformPointFunctor + -- if somehow the segment is open, and both endpoints lie on + -- different sides of the boundary, (so the segment crosses the + -- interior) it also intersects. Handle that case. + bothOpenAndOnBoundary (LineSegment (Open _) (Open _)) = + interpolate (1/2) seg `intersects` rect + bothOpenAndOnBoundary _ = False -instance Arity d => Bifunctor (LineSegment d) where - bimap f g (GLineSegment i) = GLineSegment $ bimap f (fmap g) i +-- instance (Num r, Ord r) +-- => (LineSegment 2 p r) `IsIntersectableWith` (Boundary (Rectangle q r)) where +-- seg `intersect` (Boundary rect) = case partitionEithers res of +-- (s : _, _) -> coRec s -- if we find a segment that should be the +-- -- answer; we shouldn't fine more than one +-- -- by the way. +-- ([], []) -> coRec NoIntersection +-- ([], [p]) -> coRec p +-- ([], (p:q:_)) -> coRec $ Two p q +-- -- more than two points is impossible anwyay +-- where +-- res = mapMaybe (\side -> match (seg `intersect` side) $ +-- (H $ \NoIntersection -> Nothing) +-- :& (H $ \(p :: Point 2 r) -> Just $ Right p) +-- :& (H $ \(s :: LineSegment 2 () r) -> Just $ Left s) +-- :& RNil +-- ) . F.toList $ sides rect --- ** 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' - - --- ff = bimap (fmap Val) (const ()) +-- -- instance (Num r, Ord r) => (LineSegment 2 p r) `IsIntersectableWith` (Rectangle q r) where +-- -- seg@(LineSegment' (p :+ _) (q :+ _)) `intersect` rect = +-- -- case (p `intersects` rect, q `intersects` rect) of +-- -- (True,True) -> coRec seg' +-- -- (False,False) -> match boundaryIntersection $ -- both endpoints outside +-- -- (H $ \NoIntersection -> coRec NoIntersection) +-- -- :& (H $ \(a :: Point 2 r) -> coRec a) +-- -- :& (H $ \(Two a b) -> coRec $ ClosedLineSegment (ext a) (ext b)) +-- -- :& (H $ \s -> coRec s) +-- -- :& RNil +-- -- (True,False) -> withInside p (\other -> LineSegment p' (closed other)) +-- -- (False,True) -> withInside q (\other -> LineSegment (closed other) q') +-- -- where +-- -- seg'@(LineSegment p' q') = first (const ()) seg --- ss' = let (LineSegment p q) = testSeg in --- LineSegment (p&unEndPoint %~ ff) --- (q&unEndPoint %~ ff) +-- -- boundaryIntersection = seg `intersect` (Boundary rect) +-- -- closed :: Point 2 r -> EndPoint (Point 2 r :+ ()) +-- -- closed = Closed . ext --- ss'' = ss'^._SubLine +-- -- -- the given endpoint endPt is inside the box [*], while the +-- -- -- other endpoint is not. The second arg is a function that +-- -- -- rebuilds the segment given the replacement endpoint, compute +-- -- -- the right segment that is inside the rectangle. +-- -- -- +-- -- -- [*] We require that the *point* lies in or on the box. If the +-- -- -- endpoint was open, it may still be the case that we do not +-- -- -- actually intersect the rectangle (i.e. if the open endPoint +-- -- -- was on a corner of the rect). +-- -- -- withInside :: Point 2 r +-- -- -- -> (Point 2 r -> LineSegment 2 () r) +-- -- -- -> IntersectionOf .... +-- -- withInside endPt mkSeg = match boundaryIntersection $ +-- -- (H $ \NoIntersection -> coRec NoIntersection) +-- -- -- seems this should happen only if the endpoint that was +-- -- -- suposedly in/on the rect was open. +-- -- :& (H $ \(a :: Point 2 r) -> coRec . mkSeg $ a) +-- -- :& (H $ \(Two a b) -> coRec . mkSeg $ if a == endPt then b else a) +-- -- :& (H $ \s -> coRec s) +-- -- :& RNil 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,551 @@ +{-# 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 -- todo, at some point remove these. They are superfluous + , flipSegment + + , interpolate + , validSegment + , sampleLineSegment + + , ordAtX, ordAtY, xCoordAt, yCoordAt + ) 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.Internal +import Data.Geometry.Vector +import Data.Ord (comparing) +import Data.Tuple (swap) +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) + +-- | Compute a random line segmeent +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 + +-- | Transform a segment into a closed line segment +toClosedSegment :: LineSegment d p r -> LineSegment d p r +toClosedSegment (LineSegment' s t) = ClosedLineSegment s t + + +-- ** Converting between Lines and LineSegments + +-- | Directly convert a line into a Closed 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) (LineSegment 2 q r) = + [ NoIntersection, Point 2 r, LineSegment 2 (Either p q) 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 `HasIntersectionWith` LineSegment 2 p r where + intersects = onSegment2 + +instance {-# OVERLAPPING #-} (Ord r, Num r) + => Point 2 r `IsIntersectableWith` LineSegment 2 p r where + nonEmptyIntersection = defaultNonEmptyIntersection + p `intersect` seg | p `intersects` seg = coRec p + | otherwise = coRec NoIntersection + + +instance {-# OVERLAPPABLE #-} (Ord r, Fractional r, Arity d) + => Point d r `HasIntersectionWith` LineSegment d p r where + intersects = onSegment + +instance {-# OVERLAPPABLE #-} (Ord r, Fractional r, Arity d) + => Point d r `IsIntersectableWith` LineSegment d p r where + nonEmptyIntersection = defaultNonEmptyIntersection + 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 + + +-- | Orders the endpoints of the segments in the given direction. +withRank :: forall p q r. (Ord r, Num r) + => Vector 2 r + -> LineSegment 2 p r -> LineSegment 2 q r + -> (Interval p Int, Interval q Int) +withRank v (LineSegment p q) (LineSegment a b) = (i1,i2) + where + -- let rank p = 3, rank q = 6 + i1 = Interval (p&unEndPoint.core .~ 3) (q&unEndPoint.core .~ 6) + + i2 = Interval (a&unEndPoint.core .~ assign' 1 a') (a&unEndPoint.core .~ assign' 2 b') + + -- make sure the intervals are in the same order, otherwise flip them. + (a',b') = case cmp a b of + LT -> (a,b) + EQ -> (a,b) + GT -> (b,a) + + assign' x c = case cmp c p of + LT -> x + EQ -> 3 + GT -> case cmp c q of + LT -> 4 + x + EQ -> 6 + GT -> 7 + x + + cmp :: EndPoint (Point 2 r :+ a) -> EndPoint (Point 2 r :+ b) -> Ordering + cmp c d = cmpInDirection v (c^.unEndPoint.core) (d^.unEndPoint.core) + +instance (Ord r, Num r) => + LineSegment 2 p r `HasIntersectionWith` LineSegment 2 q r where + s1@(LineSegment p _) `intersects` s2 + | l1 `isParallelTo2` l2 = parallelCase + | otherwise = s1 `intersects` l2 && s2 `intersects` l1 + where + l1@(Line _ v) = supportingLine s1 + l2 = supportingLine s2 + + parallelCase = (p^.unEndPoint.core) `onLine2` l2 && i1 `intersects` i2 + (i1,i2) = withRank v s1 s2 + + -- correctness argument: + -- if the segments share a supportingLine (l1 and l2 parallel, and point of l1 on l2) + -- the segments intersect iff their intervals along the line intersect. + + -- if the supporting lines intersect in a point, say x the + -- segments intersect iff s1 intersects the supporting line and + -- vice versa: + --- + -- => direction: is trivial + -- <= direction: s1 intersects l2 means x + -- lies on s1. Symmetrically s2 intersects l1 means x lies on + -- s2. Hence, x lies on both s1 and s2, and thus the segments + -- intersect. + + + + + + +instance (Ord r, Fractional r) => + LineSegment 2 p r `IsIntersectableWith` LineSegment 2 q r where + nonEmptyIntersection = defaultNonEmptyIntersection + + a `intersect` b = match ((a^._SubLine) `intersect` (b^._SubLine)) $ + H coRec + :& H coRec + :& H (coRec . subLineToSegment) + :& RNil + +instance (Ord r, Num r) => + LineSegment 2 p r `HasIntersectionWith` Line 2 r where + (LineSegment p q) `intersects` l = case onSide (p^.unEndPoint.core) l of + OnLine -> isClosed p || case onSide (q^.unEndPoint.core) l of + OnLine -> isClosed q || (p^.unEndPoint.core) /= (q^.unEndPoint.core) + _ -> False + sp -> case onSide (q^.unEndPoint.core) l of + OnLine -> isClosed q + sq -> sp /= sq + + +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) + +-- | Squared length of a line segment. +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. +{-# DEPRECATED sqDistanceToSeg "use squaredEuclideanDistTo instead" #-} +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). +-- +-- >>> :{ +-- let ls = OpenLineSegment (Point2 0 0 :+ ()) (Point2 1 0 :+ ()) +-- p = Point2 2 0 +-- in snd (sqDistanceToSegArg p ls) == Point2 1 0 +-- :} +-- True +sqDistanceToSegArg :: (Arity d, Fractional r, Ord r) + => Point d r -> LineSegment d p r -> (r, Point d r) +sqDistanceToSegArg p (toClosedSegment -> 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 + +instance (Fractional r, Arity d, Ord r) => HasSquaredEuclideanDistance (LineSegment d p r) where + pointClosestToWithDistance q = swap . sqDistanceToSegArg q + + +-- | 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 + + + +-- | Given a y-coordinate, compare the segments based on the +-- x-coordinate of the intersection with the horizontal line through y +ordAtY :: (Fractional r, Ord r) => r + -> LineSegment 2 p r -> LineSegment 2 p r -> Ordering +ordAtY y = comparing (xCoordAt y) + +-- | Given an x-coordinate, compare the segments based on the +-- y-coordinate of the intersection with the horizontal line through y +ordAtX :: (Fractional r, Ord r) => r + -> LineSegment 2 p r -> LineSegment 2 p r -> Ordering +ordAtX x = comparing (yCoordAt x) + +-- | 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) + + +-- | 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 -> 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/Geometry/Matrix.hs b/src/Data/Geometry/Matrix.hs new file mode 100644 --- /dev/null +++ b/src/Data/Geometry/Matrix.hs @@ -0,0 +1,95 @@ +-------------------------------------------------------------------------------- +-- | +-- Module : Data.Geometry.Matrix +-- Copyright : (C) Frank Staals +-- License : see the LICENSE file +-- Maintainer : Frank Staals +-- +-- type-indexed matrices. +-- +-------------------------------------------------------------------------------- +module Data.Geometry.Matrix( + Matrix(Matrix) + , identityMatrix + + , multM + , mult + + , Invertible(..) + , HasDeterminant(..) + ) where + +import Control.Lens (imap) +import Data.Coerce +import Data.Geometry.Matrix.Internal (mkRow) +import Data.Geometry.Vector +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. +newtype Matrix n m r = Matrix (Vector n (Vector m r)) + +deriving instance (Show r, Arity n, Arity m) => Show (Matrix n m r) +deriving instance (Eq r, Arity n, Arity m) => Eq (Matrix n m r) +deriving instance (Ord r, Arity n, Arity m) => Ord (Matrix n m r) +deriving instance (Arity n, Arity m) => Functor (Matrix n m) +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. +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' = 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' = withM33 Lin.inv33 + +instance Fractional r => Invertible 4 r where + 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 . coerce +instance HasDeterminant 3 where + det = Lin.det33 . coerce +instance HasDeterminant 4 where + 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/Matrix/Internal.hs b/src/Data/Geometry/Matrix/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Data/Geometry/Matrix/Internal.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE Unsafe #-} +module Data.Geometry.Matrix.Internal where + +import Control.Lens (set) +import Data.Geometry.Vector +import qualified Data.Vector.Fixed as FV + +-------------------------------------------------------------------------------- +-- * Helper functions to easily create matrices + +-- | Creates a row with zeroes everywhere, except at position i, where the +-- value is the supplied value. +mkRow :: forall d r. (Arity d, Num r) => Int -> r -> Vector d r +mkRow i x = set (FV.element i) x zero 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 #-} -------------------------------------------------------------------------------- @@ -23,9 +22,8 @@ import qualified Data.List.NonEmpty as NonEmpty import Data.Geometry.PlanarSubdivision.Basic import Data.Geometry.PlanarSubdivision.Merge +import Data.Geometry.PlanarSubdivision.TreeRep import Data.Geometry.Polygon -import qualified Data.PlaneGraph as PG -import Data.Proxy -- import Data.Geometry.Point @@ -43,25 +41,23 @@ -- -- runningtime: \(O(n\log n\log k)\) in case of polygons with holes, -- and \(O(n\log k)\) in case of simple polygons. -fromPolygons :: (Foldable1 c, Ord r, Fractional r) - => proxy s - -> f -- ^ outer face data - -> c (Polygon t p r :+ f) -- ^ the disjoint polygons - -> PlanarSubdivision s p () f r -fromPolygons px oD = mergeAllWith const - . fmap (\(pg :+ iD) -> fromPolygon px pg iD oD) . toNonEmpty +fromPolygons :: forall s c t p r f. (Foldable1 c, Ord r, Num r) + => f -- ^ outer face data + -> c (Polygon t p r :+ f) -- ^ the disjoint polygons + -> PlanarSubdivision s p () f r +fromPolygons oD = mergeAllWith const + . fmap (\(pg :+ iD) -> fromPolygon pg iD oD) . toNonEmpty -- | Version of 'fromPolygons' that accepts 'SomePolygon's as input. -fromPolygons' :: forall proxy c s p r f. (Foldable1 c, Ord r, Fractional r) - => proxy s - -> f -- ^ outer face data +fromPolygons' :: forall s c p r f. (Foldable1 c, Ord r, Num r) + => f -- ^ outer face data -> c (SomePolygon p r :+ f) -- ^ the disjoint polygons -> PlanarSubdivision s p () f r -fromPolygons' px oD = +fromPolygons' oD = mergeAllWith const . fmap (\(pg :+ iD) -> either (build iD) (build iD) pg) . toNonEmpty where build :: f -> Polygon t p r -> PlanarSubdivision s p () f r - build iD pg = fromPolygon px pg iD oD + build iD pg = fromPolygon pg iD oD -- | Construct a planar subdivision from a polygon. Since our PlanarSubdivision -- models only connected planar subdivisions, this may add dummy/invisible @@ -71,21 +67,19 @@ -- -- running time: \(O(n)\) for a simple polygon, \(O(n\log n)\) for a -- polygon with holes. -fromPolygon :: forall proxy t p f r s. (Ord r, Fractional r) - => proxy s - -> Polygon t p r +fromPolygon :: forall s t p f r. (Ord r, Num r) + => Polygon t p r -> 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 (MultiPolygon vs hs) iD oD = case NonEmpty.nonEmpty hs of +fromPolygon pg@SimplePolygon{} iD oD = fromSimplePolygon @s pg iD oD +fromPolygon (MultiPolygon vs hs) iD oD = case NonEmpty.nonEmpty hs of Nothing -> outerPG - Just hs' -> let hs'' = (\pg -> fromSimplePolygon wp (toCounterClockWiseOrder pg) oD iD) <$> hs' + Just hs' -> let hs'' = (\pg -> fromSimplePolygon @(Wrap s) + (toCounterClockWiseOrder pg) oD iD) <$> hs' in embedAsHolesIn hs'' (\_ x -> x) i outerPG where - wp = Proxy :: Proxy (Wrap s) - - outerPG = fromSimplePolygon p (SimplePolygon vs) iD oD + outerPG = fromSimplePolygon @s vs iD oD i = V.last $ faces' outerPG @@ -123,13 +117,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 -------------------------------------------------------------------------------- @@ -158,3 +152,26 @@ -- mySubDiv = fromSimplePolygons (Id Test) -- 0 -- (NonEmpty.fromList [simplePg' :+ 1, trianglePG :+ 2]) + + + + +-- type R = Int +-- data MyWorld + +-- mySubDiv :: PlanarSubdivision MyWorld Int (Int,Int) String R +-- mySubDiv = undefined + +-- faceData xs = FaceData (Seq.fromList xs) + + + +-- fromTreeRep :: TreeRep v e f r -> PlanarSubdivision s v e f r +-- fromTreeRep (PlanarSD of' (InnerSD ajs fs)) = undefined + + +-- fromInnerRep :: forall s v e f r. (Ord r, Fractional r) +-- => InnerRep v e f r -> PlanarSubdivision s v e () r +-- fromInnerRep f (InnerSD ajs fs) = fromConnectedSegments (Proxy @s) segs +-- where +-- segs = adjs 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 @@ -1,6 +1,4 @@ {-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PartialTypeSignatures #-} {-# LANGUAGE ScopedTypeVariables #-} -------------------------------------------------------------------------------- -- | @@ -35,14 +33,16 @@ , components, component , vertices', vertices , edges', edges - , faces', faces, internalFaces + , faces', internalFaces', faces, internalFaces , darts' - -- , traverseVertices, traverseDarts, traverseFaces + , traverseVertices, traverseDarts, traverseFaces + , mapVertices, mapDarts, mapFaces , headOf, tailOf, twin, endPoints , incidentEdges, incomingEdges, outgoingEdges - , nextIncidentEdge + , nextIncidentEdge, prevIncidentEdge + , nextIncidentEdgeFrom, prevIncidentEdgeFrom , neighboursOf , leftFace, rightFace @@ -58,8 +58,10 @@ , faceDataOf , edgeSegment, edgeSegments - , rawFacePolygon, rawFaceBoundary - , rawFacePolygons + , faceBoundary + , internalFacePolygon, internalFacePolygons + , outerFacePolygon, outerFacePolygon' + , facePolygons , VertexId(..), FaceId(..), Dart, World(..) @@ -68,9 +70,14 @@ , dataVal , dartMapping, Raw(..) + + , asLocalD, asLocalV, asLocalF + , Incident (incidences) + , common, commonVertices, commonDarts, commonFaces ) where import Control.Lens hiding (holes, holesOf, (.=)) +import Data.Bifunctor (first, second) import Data.Coerce import Data.Ext import qualified Data.Foldable as F @@ -92,6 +99,7 @@ , HasDataOf(..) ) import qualified Data.Sequence as Seq +import qualified Data.Set as Set import qualified Data.Vector as V import qualified Data.Vector.Mutable as MV import GHC.Generics (Generic) @@ -136,6 +144,7 @@ boundingBox = boundingBoxList' . V.toList . _components +-- | Lens to access a particular component of the planar subdivision. component :: ComponentId s -> Lens' (PlanarSubdivision s v e f r) (Component s r) component ci = components.singular (ix $ unCI ci) @@ -151,10 +160,11 @@ -- | Constructs a planarsubdivision from a PlaneGraph -- -- runningTime: \(O(n)\) -fromPlaneGraph :: forall s v e f r. (Ord r, Fractional r) +fromPlaneGraph :: forall s v e f r. (Ord r, Num r) => 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 -- @@ -202,24 +212,22 @@ -- -- pre: the input polygon is given in counterclockwise order -- running time: \(O(n)\). -fromSimplePolygon :: (Ord r, Fractional r) - => proxy s - -> SimplePolygon p r +fromSimplePolygon :: forall s p f r. (Ord r, Num r) + => SimplePolygon p r -> f -- ^ data inside -> f -- ^ data outside the polygon -> PlanarSubdivision s p () f r -fromSimplePolygon p pg iD oD = - fromPlaneGraph (PG.fromSimplePolygon p pg iD oD) +fromSimplePolygon pg iD oD = + fromPlaneGraph (PG.fromSimplePolygon pg iD oD) -- | Constructs a connected planar subdivision. -- -- pre: the segments form a single connected component -- running time: \(O(n\log n)\) -fromConnectedSegments :: (Foldable f, Ord r, Fractional r) - => proxy s - -> f (LineSegment 2 p r :+ e) - -> PlanarSubdivision s (NonEmpty p) e () r -fromConnectedSegments px = fromPlaneGraph . PG.fromConnectedSegments px +fromConnectedSegments :: forall s p e r f. (Foldable f, Ord r, Num r) + => f (LineSegment 2 p r :+ e) + -> PlanarSubdivision s (NonEmpty p) e () r +fromConnectedSegments = fromPlaneGraph . PG.fromConnectedSegments -- g1 = PG.fromConnectedSegments (Identity Test1) testSegs -- ps1 = fromConnectedSegments (Identity Test1) testSegs @@ -280,7 +288,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 +335,16 @@ 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. +internalFaces' :: PlanarSubdivision s v e f r -> V.Vector (FaceId' s) +internalFaces' = V.tail . faces' + +-- | \( 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 @@ -414,8 +427,8 @@ in (\d -> g^.dataOf d) <$> ds --- | Given a dart d that points into some vertex v, report the next --- dart e in the cyclic order around v. +-- | Given a dart d that points into some vertex v, report the next dart in the +-- cyclic (counterclockwise) order around v. -- -- running time: \(O(1)\) nextIncidentEdge :: Dart s -> PlanarSubdivision s v e f r -> Dart s @@ -423,13 +436,57 @@ d'' = PG.nextIncidentEdge d' g in g^.dataOf d'' --- | All incoming edges incident to vertex v, in counterclockwise order around v. +-- | Given a dart d that points into some vertex v, report the +-- previous dart in the cyclic (counterclockwise) order around v. +-- +-- running time: \(O(1)\) +-- +-- >>> prevIncidentEdge (dart 1 "+1") smallG +-- Dart (Arc 3) +1 +prevIncidentEdge :: Dart s -> PlanarSubdivision s v e f r -> Dart s +prevIncidentEdge d ps = let (_,d',g) = asLocalD d ps + d'' = PG.prevIncidentEdge d' g + in g^.dataOf d'' + +-- | Given a dart d that points away from some vertex v, report the +-- next dart in the cyclic (counterclockwise) order around v. +-- +-- +-- running time: \(O(1)\) +-- +nextIncidentEdgeFrom :: Dart s -> PlanarSubdivision s v e f r -> Dart s +nextIncidentEdgeFrom d ps = let (_,d',g) = asLocalD d ps + d'' = PG.nextIncidentEdgeFrom d' g + in g^.dataOf d'' + +-- | Given a dart d that points into away from vertex v, report the previous dart in the +-- cyclic (counterclockwise) order around v. +-- +-- running time: \(O(1)\) +-- +prevIncidentEdgeFrom :: Dart s -> PlanarSubdivision s v e f r -> Dart s +prevIncidentEdgeFrom d ps = let (_,d',g) = asLocalD d ps + d'' = PG.prevIncidentEdgeFrom d' g + in g^.dataOf d'' + + +-- | All edges incident to vertex v in incoming direction +-- (i.e. pointing into v) in counterclockwise order around v. +-- +-- running time: \(O(k)\), where \(k) is the total number of incident edges of v incomingEdges :: VertexId' s -> PlanarSubdivision s v e f r -> V.Vector (Dart s) -incomingEdges v ps = V.filter (not . isPositive) $ incidentEdges v ps +incomingEdges v ps = orient <$> incidentEdges v ps + where + orient d = if headOf d ps == v then d else twin d --- | All outgoing edges incident to vertex v, in counterclockwise order around v. +-- | All edges incident to vertex v in outgoing direction +-- (i.e. pointing away from v) in counterclockwise order around v. +-- +-- running time: \(O(k)\), where \(k) is the total number of incident edges of v outgoingEdges :: VertexId' s -> PlanarSubdivision s v e f r -> V.Vector (Dart s) -outgoingEdges v ps = V.filter isPositive $ incidentEdges v ps +outgoingEdges v ps = orient <$> incidentEdges v ps + where + orient d = if tailOf d ps == v then d else twin d -- | Gets the neighbours of a particular vertex, in counterclockwise order @@ -437,10 +494,7 @@ -- -- running time: \(O(k)\), where \(k\) is the output size neighboursOf :: VertexId' s -> PlanarSubdivision s v e f r -> V.Vector (VertexId' s) -neighboursOf v ps = otherVtx <$> incidentEdges v ps - where - otherVtx d = let u = tailOf d ps in if u == v then headOf d ps else u - +neighboursOf v ps = flip tailOf ps <$> incomingEdges v ps -- | The face to the left of the dart -- @@ -458,10 +512,11 @@ fi = PG.rightFace d' g in g^.dataOf fi --- | The darts on the outer boundary of the face, for internal faces --- the darts are in clockwise order. For the outer face the darts are --- in counterclockwise order, and the darts from various components are in no particular order. --- +-- | The darts on the outer boundary of this face. The darts are +-- reported in order along the face. This means that for internal +-- faces the darts are reported in *clockwise* order along the +-- boundary, whereas for the outer face the darts are reported in +-- counter clockwise order. -- -- running time: \(O(k)\), where \(k\) is the output size. outerBoundaryDarts :: FaceId' s -> PlanarSubdivision s v e f r -> V.Vector (Dart s) @@ -469,6 +524,7 @@ where single (_,f',g) = (\d -> g^.dataOf d) <$> PG.boundary f' g + -- | Get the local face and component from a given face. asLocalF :: FaceId' s -> PlanarSubdivision s v e f r -> NonEmpty (ComponentId s, FaceId' (Wrap s), Component s r) @@ -478,14 +534,15 @@ where toLocalF d = let (ci,d',c) = asLocalD d ps in (ci,PG.leftFace d' c,c) --- | The vertices of the outer boundary of the face, for internal faces in --- clockwise order, for the outer face in counter clockwise order. +-- | The vertices of the outer boundary of the face, for internal +-- faces in clockwise order, for the outer face in counter clockwise +-- order. -- -- -- 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 @@ -517,7 +574,10 @@ asLocalV (VertexId v) ps = let (Raw ci v' _) = ps^?!rawVertexData.ix v in (ci,v',ps^.component ci) --- | Note that using the setting part of this lens may be very expensive!! +-- | Lens to access the vertex data +-- +-- Note that using the setting part of this lens may be very +-- expensive!! (O(n)) vertexDataOf :: VertexId' s -> Lens' (PlanarSubdivision s v e f r ) (VertexData r v) vertexDataOf (VertexId vi) = lens get' set'' @@ -529,10 +589,17 @@ in ps&rawVertexData.ix vi.dataVal .~ (x^.vData) &component ci.PG.vertexDataOf wvdi.location .~ (x^.location) + +-- | Get the location of a vertex in the planar subdivision. +-- +-- Note that the setting part of this lens may be very expensive! +-- Moreover, use with care (as this may destroy planarity etc.) locationOf :: VertexId' s -> Lens' (PlanarSubdivision s v e f r ) (Point 2 r) locationOf v = vertexDataOf v.location +-- | Lens to get the face data of a particular face. Note that the +-- setting part of this lens may be very expensive! (O(n)) faceDataOf :: FaceId' s -> Lens' (PlanarSubdivision s v e f r) (FaceData (Dart s) f) faceDataOf fi = lens getF setF @@ -553,33 +620,54 @@ type DataOf (PlanarSubdivision s v e f r) (FaceId' s) = f dataOf f = faceDataOf f.fData +-- | Traverse the vertices of the planar subdivision +traverseVertices :: Applicative g + => (VertexId' s -> v -> g v') + -> PlanarSubdivision s v e f r -> g (PlanarSubdivision s v' e f r) +traverseVertices h = traverseOf rawVertexData (traverseWith VertexId h) --- -- | Traverse the vertices --- -- --- traverseVertices :: Applicative m --- => (VertexId' s -> v -> m v') --- -> PlanarSubdivision s v e f r --- -> m (PlanarSubdivision s v' e f r) --- traverseVertices f = itraverseOf (vertexData.itraversed) (\i -> f (VertexId i)) +-- | Traverse the darts of the Planar subdivision +traverseDarts :: Applicative g + => (Dart s -> e -> g e') + -> PlanarSubdivision s v e f r -> g (PlanarSubdivision s v e' f r) +traverseDarts h = traverseOf rawDartData (traverseWith toEnum h) --- -- | Traverses the darts --- -- --- traverseDarts :: Applicative m --- => (Dart s -> e -> m e') --- -> PlanarSubdivision s v e f r --- -> m (PlaneGraph s v e' f r) --- traverseDarts f = traverseOf (dart) (PG.traverseDarts f) +-- | Traverse the faces of the planar subdivision. +traverseFaces :: Applicative g + => (FaceId' s -> f -> g f') + -> PlanarSubdivision s v e f r -> g (PlanarSubdivision s v e f' r) +traverseFaces h = traverseOf rawFaceData (traverseFaces' h) + where + traverseFaces' h' = itraverse (\i -> traverse (h' (FaceId . VertexId $ i))) --- -- | Traverses the faces --- -- --- traverseFaces :: Applicative m --- => (FaceId' s -> f -> m f') --- -> PlaneGraph s v e f r --- -> m (PlaneGraph s v e f' r) --- traverseFaces f = traverseOf graph (PG.traverseFaces f) +-- | Helper function to implement traver(vertertices|darts|faces) +traverseWith :: Applicative g + => (Int -> w s) + -> (w s -> v -> g v') + -> V.Vector (Raw ci i v) + -> g (V.Vector (Raw ci i v')) +traverseWith mkIdx h = itraverse (\i -> traverse (h $ mkIdx i)) +-------------------------------------------------------------------------------- +-- | Map with index over all faces +mapFaces :: (FaceId' s -> t -> f') + -> PlanarSubdivision s v e t r -> PlanarSubdivision s v e f' r +mapFaces h = runIdentity . traverseFaces (\i x -> Identity $ h i x) + +-- | Map with index over all vertices +mapVertices :: (VertexId' s -> t -> v') + -> PlanarSubdivision s t e f r -> PlanarSubdivision s v' e f r +mapVertices h = runIdentity . traverseVertices (\i x -> Identity $ h i x) + +-- | Map with index over all darts +mapDarts :: (Dart s -> t -> e') + -> PlanarSubdivision s v t f r -> PlanarSubdivision s v e' f r +mapDarts h = runIdentity . traverseDarts (\i x -> Identity $ h i x) + +-------------------------------------------------------------------------------- + -- | Getter for the data at the endpoints of a dart -- -- running time: \(O(1)\) @@ -612,7 +700,9 @@ edgeSegments ps = (\d -> (d,edgeSegment d ps)) <$> edges' ps --- | Given a dart and the subdivision constructs the line segment representing it +-- | Given a dart and the subdivision constructs the line segment +-- representing it. The segment \(\overline{uv})\) is has \(u\) as its +-- tail and \(v\) as its head. -- -- \(O(1)\) edgeSegment :: Dart s -> PlanarSubdivision s v e f r -> LineSegment 2 v r :+ e @@ -620,45 +710,106 @@ in ClosedLineSegment p q :+ ps^.dataOf d --- | Generates the darts incident to a face, starting with the given dart. +-- | Given a dart d, generates the darts on (the current component of) +-- the boundary of the the face that is to the right of the given +-- dart. The darts are reported in order along the face. This means +-- that for -- +-- - (the outer boundary of an) internal faces the darts are reported +-- in *clockwise* order along the boundary, +-- - the "inner" boundary of a face, i.e. the boundary of ahole, the +-- darts are reported in *counter clockwise* order. -- +-- Note that this latter case means that in the darts of a a component +-- of the outer face are reported in counter clockwise order. +-- -- \(O(k)\), where \(k\) is the number of darts reported boundary' :: Dart s -> PlanarSubdivision s v e f r -> V.Vector (Dart s) boundary' d ps = let (_,d',g) = asLocalD d ps in (\d'' -> g^.dataOf d'') <$> PG.boundary' d' g - --- | Constructs the outer boundary of the face +-- | The outerboundary of the face as a simple polygon. For internal +-- faces the polygon that is reported has its vertices stored in CCW +-- order (as expected). -- --- \(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) +-- pre: FaceId refers to an internal face. +-- +-- \(O(k)\), where \(k\) is the complexity of the outer boundary of +-- the face +faceBoundary :: FaceId' s -> PlanarSubdivision s v e f r -> SimplePolygon v r :+ f +faceBoundary i ps = unsafeFromPoints (reverse pts) :+ (ps^.dataOf i) where d = V.head $ outerBoundaryDarts i ps pts = (\d' -> PG.vtxDataToExt $ ps^.vertexDataOf (headOf d' ps)) <$> V.toList (boundary' d ps) - + -- for internal faces boundary' produces the boundary darts in + -- clockwise order. Hence, we reverse the sequence of points we + -- obtain to get the points/vertices in CCW order, so that we can + -- construct a simplepolygon out of them. --- | Constructs the boundary of the given face +-- | Constructs the boundary of the given face. -- -- \(O(k)\), where \(k\) is the complexity of the face -rawFacePolygon :: FaceId' s -> PlanarSubdivision s v e f r - -> SomePolygon v r :+ f -rawFacePolygon i ps = case F.toList $ holesOf i ps of +internalFacePolygon :: FaceId' s -> PlanarSubdivision s v e f r + -> SomePolygon v r :+ f +internalFacePolygon 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 = faceBoundary i ps + toHole d = faceBoundary (leftFace d ps) ps ^. core +-- TODO: Verify that holes are in the right orientation. --- | Lists all *internal* faces of the planar subdivision. -rawFacePolygons :: PlanarSubdivision s v e f r - -> V.Vector (FaceId' s, SomePolygon v r :+ f) -rawFacePolygons ps = fmap (\(i,_) -> (i,rawFacePolygon i ps)) . internalFaces $ ps +-- | Returns a sufficiently large, rectangular, polygon that contains +-- the entire planar subdivision. Each component corresponds to a hole +-- in this polygon. +outerFacePolygon :: (Num r, Ord r) + => PlanarSubdivision s v e f r -> MultiPolygon (Maybe v) r :+ f +outerFacePolygon ps = outerFacePolygon' outer ps & core %~ first (either (const Nothing) Just) + where + outer = rectToPolygon . grow 1 . boundingBox $ ps + rectToPolygon = unsafeFromPoints . reverse . F.toList . corners +-- | Given a sufficiently large outer boundary, draw the outerface as +-- a polygon with a hole. +outerFacePolygon' :: SimplePolygon v' r + -> PlanarSubdivision s v e f r -> MultiPolygon (Either v' v) r :+ f +outerFacePolygon' outer ps = MultiPolygon (first Left outer) holePgs :+ ps^.dataOf i + where + i = outerFaceId ps + holePgs = map getBoundary . F.toList $ holesOf i ps + -- get the bondary of a hole. Note that for holes, the function + -- 'boundary' promisses to report the darts, and therefore the + -- vertices in CCW order. Hence, we can directly construct a SimplePolygon out of it. + getBoundary d = unsafeFromPoints . fmap (second Right) $ faceBoundary' (twin d) + faceBoundary' d = (\d' -> PG.vtxDataToExt $ ps^.vertexDataOf (headOf d' ps)) + <$> V.toList (boundary' d ps) +-- | Procuces a polygon for each *internal* face of the planar +-- subdivision. +internalFacePolygons :: PlanarSubdivision s v e f r + -> V.Vector (FaceId' s, SomePolygon v r :+ f) +internalFacePolygons ps = fmap (\(i,_) -> (i,internalFacePolygon i ps)) . internalFaces $ ps + + +-- | Procuces a polygon for each face of the planar subdivision. +facePolygons :: (Num r, Ord r) + => PlanarSubdivision s v e f r + -> V.Vector (FaceId' s, SomePolygon (Maybe v) r :+ f) +facePolygons ps = V.cons (outerFaceId ps, first Right $ outerFacePolygon ps) ifs + where + ifs = wrapJust <$> internalFacePolygons ps + g :: Bifunctor g => g a b -> g (Maybe a) b + g = first Just + + wrapJust :: (FaceId' s, SomePolygon v r :+ f) + -> (FaceId' s, SomePolygon (Maybe v) r :+ f) + wrapJust (i,(spg :+ f)) = (i,bimap g g spg :+ f) + + + +-- | Mapping between the internal and extenral darts dartMapping :: PlanarSubdivision s v e f r -> V.Vector (Dart (Wrap s), Dart s) dartMapping ps = ps^.component (ComponentId 0).PG.dartData @@ -674,3 +825,63 @@ -- $ trianglePG -- trianglePG = fromPoints . map ext $ [origin, Point2 10 0, Point2 10 10] + + + + + + + + + + + + + + +-------------------------------------------------------------------------------- + + +-- | A class for describing which features (vertex, edge, face) of a planar subdivision +-- can be incident to each other. +class Incident s a b where + incidences :: PlanarSubdivision s v e f r -> a -> [b] + +instance Incident s (VertexId' s) (Dart s) where + incidences psd i = V.toList (incidentEdges i psd) ++ map twin (V.toList $ incidentEdges i psd) + +instance Incident s (VertexId' s) (FaceId' s) where + incidences psd i = map ((flip leftFace) psd) $ V.toList $ incidentEdges i psd + +instance Incident s (Dart s) (VertexId' s) where + incidences psd i = [headOf i psd, tailOf i psd] + +instance Incident s (Dart s) (FaceId' s) where + incidences psd i = [leftFace i psd, rightFace i psd] + +instance Incident s (FaceId' s) (VertexId' s) where + incidences psd i = V.toList $ boundaryVertices i psd + +instance Incident s (FaceId' s) (Dart s) where + incidences psd i = V.toList (outerBoundaryDarts i psd) ++ map twin (V.toList $ outerBoundaryDarts i psd) + +-- | Given two features (vertex, edge, or face) of a subdivision, +-- report all features of a given type that are incident to both. +common :: (Incident s a c, Incident s b c, Ord c) => PlanarSubdivision s v e f r -> a -> b -> [c] +common psd a b = Set.toList $ Set.intersection (Set.fromList $ incidences psd a) (Set.fromList $ incidences psd b) + +-- | Given two features (edge or face) of a subdivision, report all +-- vertices that are incident to both. +commonVertices :: (Incident s a (VertexId' s), Incident s b (VertexId' s)) => PlanarSubdivision s v e f r -> a -> b -> [VertexId' s] +commonVertices = common + +-- | Given two features (vertex or face) of a subdivision, report all +-- edges that are incident to both. Returns both darts of each +-- qualifying edge. +commonDarts :: (Incident s a (Dart s), Incident s b (Dart s)) => PlanarSubdivision s v e f r -> a -> b -> [Dart s] +commonDarts = common + +-- | Given two features (vertex or edge) of a subdivision, report all +-- faces that are incident to both. +commonFaces :: (Incident s a (FaceId' s), Incident s b (FaceId' s)) => PlanarSubdivision s v e f r -> a -> b -> [FaceId' s] +commonFaces = common diff --git a/src/Data/Geometry/PlanarSubdivision/Dynamic.hs b/src/Data/Geometry/PlanarSubdivision/Dynamic.hs new file mode 100644 --- /dev/null +++ b/src/Data/Geometry/PlanarSubdivision/Dynamic.hs @@ -0,0 +1,526 @@ +module Data.Geometry.PlanarSubdivision.Dynamic + ( splitEdge, unSplitEdge + , sproutIntoFace + , splitFace + ) where + +import Control.Lens +import Data.Ext +import Data.Functor.Identity +import Data.Geometry hiding (Vector, head, imap) +import Data.Geometry.PlanarSubdivision +import Data.Geometry.PlanarSubdivision.Basic +import Data.Geometry.PlanarSubdivision.Raw +import Data.List (sort, sortOn, findIndex) +import Data.List.NonEmpty (NonEmpty(..)) +import qualified Data.List.NonEmpty as NonEmpty +import Data.PlanarGraph (Dart (Dart), Arc (Arc), VertexId (VertexId), FaceId (FaceId), Direction (Positive, Negative)) +import Data.PlaneGraph (PlaneGraph) +import qualified Data.PlaneGraph as PG +import qualified Data.PlaneGraph.AdjRep as AR (id, vData, fData, faces, Face (..)) +import Data.PlaneGraph.AdjRep hiding (id, vData, faces) +import Data.Vector (Vector, toList, (//), empty) +import qualified Data.Vector as V + +import Debug.Trace + + +tracingOn = False + +tr :: Show a => String -> a -> a +tr s a | tracingOn = trace ("\9608 " ++ s ++ ": " ++ show a) a + | otherwise = a + + +-- TO DO: +-- ADD EDGE JOINING TWO COMPONENTS +-- CREATE NEW COMPONENT (SINGLE VERTEX) +-- DELETIONS + + +-- | Splits a given edge of a planar subdivision by inserting a new vertex on the edges. +-- Increases #vertices and #edges by 1. +splitEdge + :: (Show v, Show e, Show f, Show r) + => VertexId' s + -> VertexId' s + -> Point 2 r + -> v + -> (e -> (e, e)) + -> PlanarSubdivision s v e f r + -> PlanarSubdivision s v e f r + +splitEdge a b p v f d = + let (_, la, _) = asLocalV a d + (_, lb, _) = asLocalV b d + v' = (freeVertexId d, v) + fd = freeDart d + f' (Dart i Positive, e) = ((Dart i Positive, fst $ f e), (fd, snd $ f e)) + f' (Dart i Negative, e) = ((twin fd, fst $ f e), (Dart i Negative, snd $ f e)) + in tr "splitEdge" $ d & components' %~ fmap (splitEdgeInPlaneGraph la lb p v' f') + +-- | Sprouts a new edge from a given vertex into the interior of a given (incident) face. +-- Increases #vertices and #edges by 1. +sproutIntoFace + :: (Show v, Show e, Show f, Show r) + => VertexId' s + -> FaceId' s + -> Point 2 r + -> v + -> (e, e) + -> PlanarSubdivision s v e f r + -> PlanarSubdivision s v e f r + +sproutIntoFace a f p v (e1, e2) d = + let [ea] = tr "[ea]" $ filter (\e -> headOf e d == a && leftFace e d == f) $ commonDarts d a f + (_, la, _) = asLocalV a d + (_, lc, _) = asLocalV (tailOf ea d) d + v' = (freeVertexId d, v) + fd = freeDart d + e1' = (fd, e1) + e2' = (twin fd, e2) + in tr "sproutIntoFace" $ d & components' %~ fmap (sproutIntoFaceInPlaneGraph la lc p v' (e1', e2')) + +-- | Inserts a new edge between two given vertices, adjacent to a common face. +-- Increases #edges and #faces by 1. +splitFace + :: (Show v, Show e, Show f, Show r) + => VertexId' s + -> VertexId' s + -> (e, e) + -> (f -> (f, f)) + -> PlanarSubdivision s v e f r + -> PlanarSubdivision s v e f r + +splitFace a b e g d = + let (ca, _, _) = asLocalV a d + (cb, _, _) = asLocalV b d + in if ca == cb then splitFaceSameComponent a b e g d + else splitFaceDifferentComponents a b e g d + +splitFaceSameComponent a b e g d = + let fs = commonFaces d a b + f | length fs == 1 = tr "f(a)" $ headTrace "splitFaceSameComponent f" fs + | otherwise = tr "f(b)" $ headTrace "splitFaceSameComponent f" $ filter (not . isOuterFace) fs + [ea] = tr "[ea]" $ filter (\e -> headOf e d == a && leftFace e d == f) $ commonDarts d a f + [eb] = tr "[eb]" $ filter (\e -> headOf e d == b && leftFace e d == f) $ commonDarts d b f + (_, la, _) = asLocalV a d + (_, lb, _) = asLocalV b d + (_, lc, _) = asLocalV (tailOf ea d) d + (_, ld, _) = asLocalV (tailOf eb d) d + (_, lf, _) :| [] = asLocalF f d + fd = freeDart d + e' = ((fd, fst e), (twin fd, snd e)) + tf = freeFaceId d + g' (ef, x) = ((ef, fst $ g x), (tf, snd $ g x)) + in tr "splitFaceSameComponent" $ d & components' %~ fmap (splitFaceInPlaneGraph (tr "la" la) (tr "lb" lb) (tr "lc" lc) (tr "ld" ld) (tr "lf" lf) e' g') + +splitFaceDifferentComponents = undefined + + +-- | Splits a given edge of a planar subdivision by inserting a new vertex on the edges. +-- Increases #vertices and #edges by 1. +unSplitEdge + :: (Show v, Show e, Show f, Show r) + => VertexId' s + -> ((e, e) -> e) + -> PlanarSubdivision s v e f r + -> PlanarSubdivision s v e f r + +unSplitEdge b f d = + let [a, c] = tr "[a, c]" $ toList $ neighboursOf b d + (_, la, _) = asLocalV a d + (_, lb, _) = asLocalV b d + (_, lc, _) = asLocalV c d + [dab] = filter (\e -> tailOf e d == a) $ commonDarts d a b + [dcb] = filter (\e -> tailOf e d == c) $ commonDarts d b c + f' ((di, ei), (dj, ej)) | di == dab = ( dab, f (ei, ej)) + | di == dcb = (twin dab, f (ei, ej)) + | otherwise = error "you shouldn't call f' on any other dart" + -- no longer used: vertex id b and dart id dcb + in tr "unSplitEdge" $ d & components' %~ fmap (unSplitEdgeInPlaneGraph la lb lc f') +-- globally, need to restore VertexId and DartIds ??? + + + + + +-- nodig: + +freeVertexId :: PlanarSubdivision s v e f r -> VertexId' s +freeDart :: PlanarSubdivision s v e f r -> Dart s +freeFaceId :: PlanarSubdivision s v e f r -> FaceId' s + +freeVertexId = VertexId . numVertices +freeDart = flip Dart Positive . Arc . numEdges +freeFaceId = FaceId . VertexId . numFaces + +components' :: (Show v, Show e, Show f, Show r) => Lens' (PlanarSubdivision s v e f r) (Vector (Component' s v e f r)) +type Component' s v e f r = PlaneGraph (Wrap s) (VertexId' s, v) (Dart s, e) (FaceId' s, f) r +components' = lens getComponents' setComponents' + +getComponents' :: PlanarSubdivision s v e f r -> Vector (Component' s v e f r) +getComponents' p = fmap (addExtraData p) $ p ^. components + +addExtraData :: PlanarSubdivision s v e f r -> Component s r -> Component' s v e f r +addExtraData p c = c & PG.vertexData . traverse %~ (\i -> (i, p ^. dataOf i)) + & PG.rawDartData . traverse %~ (\i -> (i, p ^. dataOf i)) + & PG.faceData . traverse %~ (\i -> (i, p ^. dataOf i)) + +setComponents' :: (Show v, Show e, Show f, Show r) => PlanarSubdivision s v e f r -> Vector (Component' s v e f r) -> PlanarSubdivision s v e f r +setComponents' p cs = p & components .~ fmap remExtraData cs + & rawVertexData .~ (tr "rawVertexData" . vectorise $ getRawVertexData cs) + & rawDartData .~ (tr "rawDartData" . vectorise $ getRawEdgeData cs) + & rawFaceData .~ (tr "rawFaceData" . vectorise $ getRawFaceData cs) + +getRawVertexData :: Vector (Component' s v e f r) + -> [(VertexId' s, Raw s (VertexId' (Wrap s)) v)] +getRawVertexData = concat . imap (\ci g -> map (\(li, VertexData _ (gi, v)) -> (gi, Raw (toEnum ci) li v)) $ toList $ PG.vertices g) . toList + +--getEdgeData :: Vector (Component' s v e f r) -> [(Dart s, (Dart s, e))] +--getEdgeData = map (\(a, b) -> (a, (a, b))) . concatMap (toList . (^. PG.rawDartData)) . toList + +getRawEdgeData :: Vector (Component' s v e f r) + -> [(Dart s, Raw s (Dart (Wrap s)) e)] +getRawEdgeData = concat . imap (\ci g -> map (\(li, (gi, e)) -> (gi, Raw (toEnum ci) li e)) $ toList $ PG.darts g) . toList + + +--getFaceData :: Vector (Component' s v e f r) -> [(FaceId' s, f)] +--getFaceData = concatMap (toList . (^. PG.faceData)) . toList + + +-- data RawFace s f +-- _faceIdx :: !(Maybe (ComponentId s, FaceId' (Wrap s))) +-- _faceDataVal :: !(FaceData (Dart s) f) + +-- | Something in this implementation is not right. It makes asLocalF produce an error. +getRawFaceData :: Vector (Component' s v e f r) + -> [(FaceId' s, RawFace s f)] +getRawFaceData = concat . imap (\ci g -> map (bla ci) $ toList $ PG.faces g) . toList + where + bla ci (li, (gi, f)) | isOuterFace gi = (gi, RawFace Nothing (FaceData Empty f)) + | otherwise = (gi, RawFace (Just (toEnum ci, li)) (FaceData Empty f)) +-- holes are always empty! (where to get them from?) + +isOuterFace :: FaceId' s -> Bool +isOuterFace i = fromEnum i == 0 + +remExtraData :: Component' s v e f r -> Component s r +remExtraData c = c & PG.vertexData . traverse %~ fst + & PG.rawDartData . traverse %~ fst + & PG.faceData . traverse %~ fst + + +vectorise :: (Enum i, Show i) => [(i, a)] -> Vector a +vectorise vs = V.replicate (length vs) undefined // map (\(i, a) -> (fromEnum i, a)) vs + + + + +------------------ +-- PLANE GRAPHS -- +------------------ + + +-- INSERTIONS -- + + +splitEdgeInPlaneGraph + :: (Show v, Show e, Show f, Show r) + => VertexId' s + -> VertexId' s + -> Point 2 r + -> v + -> (e -> (e, e)) + -> PlaneGraph s v e f r + -> PlaneGraph s v e f r +-- LET OP! TEST OF a EN b WEL VOORKOMEN! +splitEdgeInPlaneGraph a b p v f + = tr "splitEdgeInPlaneGraph" + . PG.fromAdjRep + . splitEdgeInAdjRep (fromEnum a) (fromEnum b) p v f + . PG.toAdjRep + +sproutIntoFaceInPlaneGraph + :: (Show v, Show e, Show f, Show r) + => VertexId' s + -> VertexId' s + -> Point 2 r + -> v + -> (e, e) + -> PlaneGraph s v e f r + -> PlaneGraph s v e f r +sproutIntoFaceInPlaneGraph a c p v e g = + let ai = fromEnum a + ci = fromEnum c + in tr "splitEdgeInPlaneGraph" + $ PG.fromAdjRep + $ sproutInAdjRep ai ci p v e + $ PG.toAdjRep g + + +-- PG.toAdjRep :: PlaneGraph s v e f r -> Gr (Vtx v e r) (Face f) +-- PG.fromAdjRep :: proxy s -> Gr (Vtx v e r) (Face f) -> PlaneGraph s v e f r + + +splitFaceInPlaneGraph + :: (Show v, Show e, Show f, Show r) + => VertexId' s -- index van vertex a + -> VertexId' s -- index van vertex b + -> VertexId' s -- index van vertex c + -> VertexId' s -- index van vertex d + -> FaceId' s -- index van te splitsen face + -> (e, e) -- extra data voor nieuwe edge ab + -> (f -> (f, f)) -- functie om face data in twee stukken te knippen + -> PlaneGraph s v e f r -- input graaf + -> PlaneGraph s v e f r -- output graaf + +splitFaceInPlaneGraph a b c d f e h g = + let ai = fromEnum a + bi = fromEnum b + ci = fromEnum c + di = fromEnum d + fi = fromEnum $ tr "fi" $ traceShow (g ^. dataOf f) $ PG.tailOf (PG.boundaryDart f g) g + fj = fromEnum $ tr "fj" $ PG.headOf (PG.boundaryDart f g) g + -- ^ boundaryDart seems not working either + in tr "splitFaceInPlaneGraph" + $ PG.fromAdjRep + $ splitFaceInAdjRep ai bi ci di fi fj e h + $ PG.toAdjRep g + + +-- DELETIONS -- + + +unSplitEdgeInPlaneGraph + :: (Show v, Show e, Show f, Show r) + => VertexId' s + -> VertexId' s + -> VertexId' s + -> ((e, e) -> e) + -> PlaneGraph s v e f r + -> PlaneGraph s v e f r + +unSplitEdgeInPlaneGraph a b c f + = tr "unSplitEdgeInPlaneGraph" + . PG.fromAdjRep + . unSplitEdgeInAdjRep (fromEnum a) (fromEnum b) (fromEnum c) f + . PG.toAdjRep + + +------------- +-- ADJREPS -- +------------- + +-- Gr +-- adjacencies :: [v] +-- faces :: [f] + +-- Vtx +-- id :: Int +-- loc :: Point 2 r +-- adj :: [(Int, e)] +-- vData :: v + +-- Face +-- incidentEdge :: (Int, Int) +-- fData :: f + +--deriving instance (Show v, Show f) => Show (Gr v f) +--deriving instance (Show v, Show e, Show r) => Show (Vtx v e r) +--deriving instance Show f => Show (Face f) + + +-- instance {-# OVERLAPS #-} Show (VertexId s Primal) where show i = 'v' : show (fromEnum i) +-- instance {-# OVERLAPS #-} Show (FaceId s Primal) where show i = 'f' : show (fromEnum i) +-- instance {-# OVERLAPS #-} Show (Dart s, v) where +-- show (Dart (Arc s) Positive, _) = 'd' : show (fromEnum s) ++ "+" +-- show (Dart (Arc s) Negative, _) = 'd' : show (fromEnum s) ++ "-" + +-- instance Show f => Show (Face f) where show f = (show $ AR.fData f) ++ "~>" ++ (show $ incidentEdge f) +-- instance (Show e, Show r) => Show (Vtx v e r) where show v = (show $ AR.id v) ++ "~>" ++ (show $ adj v) +-- instance (Show v, Show f) => Show (Gr v f) where show g = "Gr " ++ (show $ adjacencies g) ++ " " ++ (show $ AR.faces g) + +-- ik heb: +splitEdgeInAdjRep + :: (Show v, Show e, Show f, Show r) + => Int -- index van vertex a + -> Int -- index van vertex b + -> Point 2 r -- locatie voor nieuwe vertex c + -> v -- extra data voor vertex c + -> (e -> (e, e)) -- functie om edge data in twee stukken te knippen + -> Gr (Vtx v e r) (Face f) -- input graaf + -> Gr (Vtx v e r) (Face f) -- output graaf + +splitEdgeInAdjRep a b p v f g = + let n = length $ adjacencies g + -- first find vertices a and b + oa = headTrace "splitEdgeInAdjRep oa" $ filter ((== a) . AR.id) $ adjacencies g + ob = headTrace "splitEdgeInAdjRep ob" $ filter ((== b) . AR.id) $ adjacencies g + os = filter ((lift (&&) (/= a) (/= b)) . AR.id) $ adjacencies g + -- find edge data + e1 = snd $ headTrace "splitEdgeInAdjRep e1" $ filter ((== b) . fst) $ adj oa + e2 = snd $ headTrace "splitEdgeInAdjRep e2" $ filter ((== a) . fst) $ adj ob + -- create new adjacencies to c in a and b + na = oa {adj = replace ((== b) . fst) (const (n, fst $ f e1)) $ adj oa} + nb = ob {adj = replace ((== a) . fst) (const (n, fst $ f e2)) $ adj ob} + -- create new vertex c + nc = Vtx {AR.id = n, loc = p, adj = [(a, snd $ f e2), (b, snd $ f e1)], AR.vData = v} + -- update faces (only if incidentEdge happens to point to ab) + nf = replace ((== (a, b)) . incidentEdge) (\f -> f {incidentEdge = (a, n)}) + $ replace ((== (b, a)) . incidentEdge) (\f -> f {incidentEdge = (b, n)}) + $ AR.faces g + in tr "splitEdgeInAdjRep" $ (tr "original" g) {adjacencies = sortOn AR.id $ na : nb : nc : os, AR.faces = nf} + + +sproutInAdjRep + :: (Show v, Show e, Show f, Show r) + => Int -- index van vertex a + -> Int -- index van vertex c (andere kant van edge a) + -> Point 2 r -- locatie voor nieuwe vertex c + -> v -- extra data voor vertex c + -> (e, e) -- extra data voor nieuwe edge + -> Gr (Vtx v e r) (Face f) -- input graaf + -> Gr (Vtx v e r) (Face f) -- output graaf + +sproutInAdjRep a c p v e g = + let n = length $ adjacencies g + -- first find vertex a + oa = tr "oa" $ headTrace "sproutInAdjRep oa" $ filter ((== a) . AR.id) $ adjacencies g + os = tr "os" $ filter ((/= a) . AR.id) $ adjacencies g + -- need to find index of c + fj (Just x) = x + fj Nothing = error "splitFaceInAdjRep got Nothing" + ci = tr "ci" $ fj $ findIndex ((== c) . fst) $ adj oa + -- create new adjacency to new vertex z in a + na = tr "na" $ oa {adj = take ci (adj oa) ++ (n, fst e) : drop ci (adj oa)} + -- create new vertex z + nz = Vtx {AR.id = n, loc = p, adj = [(a, snd e)], AR.vData = v} + in tr "splitFaceInAdjRep" $ (tr "original" g) {adjacencies = sortOn AR.id $ na : nz : os} + +splitFaceInAdjRep + :: (Show v, Show e, Show f, Show r) + => Int -- index van vertex a + -> Int -- index van vertex b + -> Int -- index van vertex c (andere kant van edge a) + -> Int -- index van vertex d (andere kant van edge b) + -> Int -- index van face edge start + -> Int -- index van face edge eind + -> (e, e) -- extra data voor nieuwe edge ab + -> (f -> (f, f)) -- functie om face data in twee stukken te knippen + -> Gr (Vtx v e r) (Face f) -- input graaf + -> Gr (Vtx v e r) (Face f) -- output graaf + +-- is it easier to split a vertex than a face? + +splitFaceInAdjRep a b c d u v e f g = + let + -- first find vertices a and b + oa = tr "oa" $ headTrace "splitFaceInAdjRep oa" $ filter ((== a) . AR.id) $ adjacencies g + ob = tr "ob" $ headTrace "splitFaceInAdjRep ob" $ filter ((== b) . AR.id) $ adjacencies g + os = tr "os" $ filter ((lift (&&) (/= a) (/= b)) . AR.id) $ adjacencies g + -- insert new adjacency between a and b + fj (Just x) = x + fj Nothing = error "splitFaceInAdjRep got Nothing" + -- need to find indices c and d! + ci = tr "ci" $ fj $ findIndex ((== c) . fst) $ adj oa + di = tr "di" $ fj $ findIndex ((== d) . fst) $ adj ob + -- insert new adjacencies to each other in a and b + na = tr "na" $ oa {adj = take ci (adj oa) ++ (b, fst e) : drop ci (adj oa)} + nb = tr "nb" $ ob {adj = take di (adj ob) ++ (a, snd e) : drop di (adj ob)} + -- find the face that is incident to both a and b + i = tr "i" $ fj $ findIndex ((== (u, v)) . incidentEdge) $ AR.faces g + fd = tr "fd" $ AR.fData $ AR.faces g !! i + ef = tr "ef" $ take i (AR.faces g) ++ drop (i + 1) (AR.faces g) + f1 = tr "f1" $ AR.Face {incidentEdge = (a, b), AR.fData = fst $ f fd} + f2 = tr "f2" $ AR.Face {incidentEdge = (b, a), AR.fData = snd $ f fd} + in tr "splitFaceInAdjRep" $ (tr "original" g) {adjacencies = sortOn AR.id $ na : nb : os, AR.faces = ef ++ [f1, f2]} + + + + + +unSplitEdgeInAdjRep + :: (Show v, Show e, Show f, Show r) + => Int -- index van vertex a + -> Int -- index van vertex b (te verwijderen) + -> Int -- index van vertex c + -> ((e, e) -> e) -- functie om edge data te mergen + -> Gr (Vtx v e r) (Face f) -- input graaf + -> Gr (Vtx v e r) (Face f) -- output graaf + +unSplitEdgeInAdjRep a b c f g = + let n = length $ adjacencies g + -- first find vertices a, b and c + oa = head $ filter ((== a) . AR.id) $ adjacencies g + ob = head $ filter ((== b) . AR.id) $ adjacencies g + oc = head $ filter ((== c) . AR.id) $ adjacencies g + os = filter ((\i -> i /= a && i /= b && i /= c) . AR.id) $ adjacencies g + -- find edge data + eab = snd $ head $ filter ((== b) . fst) $ adj oa + eba = snd $ head $ filter ((== a) . fst) $ adj ob + ebc = snd $ head $ filter ((== c) . fst) $ adj ob + ecb = snd $ head $ filter ((== b) . fst) $ adj oc + -- create new adjacencies between a and c + na = oa {adj = replace ((== b) . fst) (const (c, f (eab, ebc))) $ adj oa} + nc = oc {adj = replace ((== b) . fst) (const (a, f (ecb, eba))) $ adj oc} + nv = sortOn AR.id $ na : nc : os + -- update faces (only if incidentEdge happens to point to ab or bc) + nf = replace ((== (a, b)) . incidentEdge) (\f -> f {incidentEdge = (a, c)}) + $ replace ((== (b, a)) . incidentEdge) (\f -> f {incidentEdge = (c, a)}) + $ replace ((== (b, c)) . incidentEdge) (\f -> f {incidentEdge = (a, c)}) + $ replace ((== (c, b)) . incidentEdge) (\f -> f {incidentEdge = (c, a)}) + $ AR.faces g + -- restore consecutive numbering: replace vertex n-1 by b + ng = replaceIndex (n - 1) b $ (tr "original" g) {adjacencies = nv, AR.faces = nf} + in tr "unSplitEdgeInAdjRep" $ ng + +-- Gr +-- adjacencies :: [v] +-- faces :: [f] + +-- Vtx +-- id :: Int +-- loc :: Point 2 r +-- adj :: [(Int, e)] +-- vData :: v + +-- Face +-- incidentEdge :: (Int, Int) +-- fData :: f + +replaceIndex :: Int -> Int -> Gr (Vtx v e r) (Face f) -> Gr (Vtx v e r) (Face f) +replaceIndex i j g = g { adjacencies = map (replaceIndexAdjacency i j) $ adjacencies g + , AR.faces = map (replaceIndexFace i j) $ AR.faces g + } + +replaceIndexAdjacency :: Int -> Int -> Vtx v e r -> Vtx v e r +replaceIndexAdjacency i j v = v { AR.id = if AR.id v == i then j else AR.id v + , adj = replace ((== i) . fst) (set _1 j) $ adj v + } + +replaceIndexFace :: Int -> Int -> Face f -> Face f +replaceIndexFace i j f | fst (incidentEdge f) == i = f {incidentEdge = incidentEdge f & set _1 j} + | snd (incidentEdge f) == i = f {incidentEdge = incidentEdge f & set _2 j} + | otherwise = f + + +------------- +-- HELPERS -- +------------- + +replace :: (a -> Bool) -> (a -> a) -> [a] -> [a] +replace f g = map $ replace' f g + +replace' :: (a -> Bool) -> (a -> a) -> a -> a +replace' f g x | f x = g x + | otherwise = x + +lift :: (a -> b -> c) -> (d -> a) -> (d -> b) -> d -> c +lift f g h x = f (g x) (h x) + + + +headTrace :: String -> [a] -> a +headTrace s xs | null xs = error $ s ++ ": head of empty list" + | otherwise = head xs 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 @@ -214,35 +211,38 @@ -------------------------------------------------------------------------------- -data Test = Test -data Id a = Id a - +data Test triangle1 :: PlanarSubdivision Test () () Int Rational -triangle1 = (\pg -> fromSimplePolygon (Id Test) pg 1 0) - $ trianglePG1 +triangle1 = (\pg -> fromSimplePolygon @Test pg 1 0) + 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 +triangle2 = (\pg -> fromSimplePolygon @Test pg 2 0) + 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 +triangle4 = (\pg -> fromSimplePolygon @Test pg 1 0) + 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 +triangle3 = (\pg -> fromSimplePolygon @Test pg 3 0) + 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 @@ -39,6 +39,14 @@ instance (ToJSON ia, ToJSON a) => ToJSON (Raw s ia a) where toEncoding = genericToEncoding defaultOptions +instance FunctorWithIndex i (Raw ci i) where + imap f (Raw ci i x) = Raw ci i (f i x) +instance FoldableWithIndex i (Raw ci i) where + ifoldMap f (Raw _ i x) = f i x +instance TraversableWithIndex i (Raw ci i) where + itraverse f (Raw ci i x) = Raw ci i <$> f i x + + -- | get the dataVal of a Raw dataVal :: Lens (Raw s ia a) (Raw s ia b) a b dataVal = lens (\(Raw _ _ x) -> x) (\(Raw c i _) y -> Raw c i y) @@ -46,7 +54,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/PlanarSubdivision/TreeRep.hs b/src/Data/Geometry/PlanarSubdivision/TreeRep.hs new file mode 100644 --- /dev/null +++ b/src/Data/Geometry/PlanarSubdivision/TreeRep.hs @@ -0,0 +1,110 @@ +-------------------------------------------------------------------------------- +-- | +-- Module : Data.Geometry.PlanarSubdivision.TreeRep +-- Copyright : (C) Frank Staals +-- License : see the LICENSE file +-- Maintainer : Frank Staals +-- +-- Data types that help encode/decode a planegraph as a JSON/YAML file. +-- +-------------------------------------------------------------------------------- +module Data.Geometry.PlanarSubdivision.TreeRep( PlanarSD(..) + , Vtx(..) + , myTreeRep + ) where + +-- FIXME; uncomment myTreeRep + +import Data.Aeson +import Data.PlaneGraph.AdjRep (Vtx(..)) +import GHC.Generics (Generic) + +import Data.Geometry.Point +import Data.RealNumber.Rational + +-------------------------------------------------------------------------------- + + + +-- | Specify the planar subdivison as a tree of components +data PlanarSD v e f r = PlanarSD + { outerFace :: f -- ^ outer face + , inner :: InnerSD v e f r + } deriving (Show,Eq,Functor,Generic) + +instance (ToJSON r, ToJSON v, ToJSON e, ToJSON f) => ToJSON (PlanarSD v e f r) where + toEncoding = genericToEncoding defaultOptions +instance (FromJSON r, FromJSON v, FromJSON e, FromJSON f) => FromJSON (PlanarSD v e f r) + + +data InnerSD v e f r = InnerSD + { adjs :: [Vtx v e r] -- ^ list of vertices and edges in the + -- components incident to the outer + -- face + , faces :: [(f, [InnerSD v e f r])] -- ^ for each internal + -- face in the component described by adjs its data, + -- and possible holes + } deriving (Show,Eq,Functor,Generic) + +instance (ToJSON r, ToJSON v, ToJSON e, ToJSON f) => ToJSON (InnerSD v e r f) where + toEncoding = genericToEncoding defaultOptions +instance (FromJSON r, FromJSON v, FromJSON e, FromJSON f) => FromJSON (InnerSD v e r f) + + + +-------------------------------------------------------------------------------- + +-- | This represents the following Planar subdivision. Note that the +-- graph is undirected, the arrows are just to indicate what the +-- Positive direction of the darts is. +-- +-- ![mySubDiv](docs/Data/Geometry/PlanarSubdivision/mySubDiv.jpg) +myTreeRep :: PlanarSD Int () String (RealNumber 3) +myTreeRep = PlanarSD "f_infty" (InnerSD ads fs) + where + fs = [ ("f_1", []) + , ("f_2", [f5, f6]) + , ("f_3", []) + , ("f_4", [f7]) + ] + + f5 = InnerSD [ vtx 16 (Point2 3 8) [e 17, e 18] + , vtx 17 (Point2 0 7) [e 16, e 18] + , vtx 18 (Point2 (-1) 4) [e 16, e 17] + ] [("f_5",[])] + + f6 = InnerSD [ vtx 15 (Point2 3 3) [e 14, e 13] + , vtx 13 (Point2 6 4) [e 14, e 15] + , vtx 14 (Point2 3 6) [e 13, e 15] + ] [("f_6",[])] + + f7 = InnerSD [ vtx 19 (Point2 0 9) [e 20, e 23] + , vtx 20 (Point2 0 4) [e 19, e 21] + , vtx 21 (Point2 15 2) [e 20, e 22] + , vtx 22 (Point2 17 5) [e 21, e 23] + , vtx 23 (Point2 15 8) [e 19, e 22] + ] [("f_7",[f8])] + + f8 = InnerSD [ vtx 24 (Point2 14 6) [e 25, e 26] + , vtx 25 (Point2 13 8) [e 24, e 26] + , vtx 26 (Point2 12 5) [e 24, e 25] + ] [("f_8",[])] + + ads = [ vtx 0 (Point2 0 0) [e 1, e 4] + , vtx 1 (Point2 10 2) [e 0, e 5] + , vtx 2 (Point2 9 9) [e 1, e 7, e 3] + , vtx 3 (Point2 0 10) [e 2, e 4] + , vtx 4 (Point2 (-4) 5) [e 0, e 3] + , vtx 5 (Point2 15 3) [e 1, e 6] + , vtx 6 (Point2 20 6) [e 5, e 7] + , vtx 7 (Point2 10 14) [e 2, e 6, e 8] + , vtx 8 (Point2 4 13) [e 7, e 3] + , vtx 9 (Point2 4 (-4)) [e 10, e 11] + , vtx 10 (Point2 8 (-4)) [e 11, e 9] + , vtx 11 (Point2 11 (-2)) [e 10, e 12] + , vtx 12 (Point2 7 (-1)) [e 9, e 11] + ] + + e i = (i,()) + + vtx i p as = Vtx i p as i 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,418 +10,60 @@ -- \(d\)-dimensional points. -- -------------------------------------------------------------------------------- -module Data.Geometry.Point( Point(..) +module Data.Geometry.Point( Point(.., Point1, Point2, Point3) , origin, vector , pointFromList - - , coord , unsafeCoord - , projectPoint - , 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', cmpInDirection , squaredEuclideanDist, euclideanDist - ) where + , HasSquaredEuclideanDistance(..) -import Control.DeepSeq -import Control.Lens -import Data.Aeson -import qualified Data.CircularList as C -import qualified Data.CircularList.Util as CU -import Data.Ext -import qualified Data.Foldable as F -import Data.Geometry.Properties -import Data.Geometry.Vector -import qualified Data.Geometry.Vector as Vec -import qualified Data.List as L -import Data.Ord (comparing) -import Data.Proxy -import GHC.Generics (Generic) -import GHC.TypeLits -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) + , coord, unsafeCoord + ) where +import Data.Geometry.Point.Class +import Data.Geometry.Point.Internal hiding (coord, unsafeCoord) +import Data.Geometry.Point.Orientation.Degenerate +import Data.Geometry.Point.Quadrants +import Data.Geometry.Line.Internal +import Data.Geometry.Vector -------------------------------------------------------------------------------- --- $setup --- >>> :{ --- let myVector :: Vector 3 Int --- myVector = Vector3 1 2 3 --- myPoint = Point myVector --- :} - --------------------------------------------------------------------------------- --- * A d-dimensional Point - --- | A d-dimensional point. -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 - ] -instance (Read r, Arity d) => Read (Point d r) where - readPrec = lift readPt - 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 - -deriving instance (Eq r, Arity d) => Eq (Point d r) -deriving instance (Ord r, Arity d) => Ord (Point d r) -deriving instance Arity d => Functor (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) - -type instance NumType (Point d r) = r -type instance Dimension (Point d r) = d - -instance Arity d => Affine (Point d) where - type Diff (Point d) = Vector d - - p .-. q = toVec p ^-^ toVec q - p .+^ v = Point $ toVec p ^+^ v - -instance (FromJSON r, Arity d, KnownNat d) => FromJSON (Point d r) where - parseJSON = fmap Point . parseJSON - -instance (ToJSON r, Arity d) => ToJSON (Point d r) where - toJSON = toJSON . toVec - toEncoding = toEncoding . toVec - --- | Point representing the origin in d dimensions --- --- >>> origin :: Point 4 Int --- Point4 [0,0,0,0] -origin :: (Arity d, Num r) => Point d r -origin = Point $ pure 0 - - --- ** Accessing points - --- | 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 :: Lens' (Point d r) (Vector d r) -vector = lens toVec (const Point) - - --- | 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 => Int -> Lens' (Point d r) r -unsafeCoord i = vector . singular (ix (i-1)) - -- Points are 1 indexed, vectors are 0 indexed - --- | 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 :: forall proxy i d r. (1 <= i, i <= d, ((i - 1) + 1) ~ i - , Arity (i - 1), Arity d - ) => proxy i -> Lens' (Point d r) r -coord _ = vector . Vec.element (Proxy :: Proxy (i-1)) -{-# INLINABLE coord #-} - - --- somehow these rules don't fire --- {-# SPECIALIZE coord :: C 1 -> Lens' (Point 2 r) r#-} --- {-# SPECIALIZE coord :: C 2 -> Lens' (Point 2 r) r#-} - - --- | Constructs a point from a list of coordinates --- --- >>> pointFromList [1,2,3] :: Maybe (Point 3 Int) --- Just Point3 [1,2,3] -pointFromList :: Arity d => [r] -> Maybe (Point d r) -pointFromList = fmap Point . Vec.vectorFromList - - --- | Project a point down into a lower dimension. -projectPoint :: (Arity i, Arity d, i <= d) => Point d r -> Point i r -projectPoint = Point . prefix . toVec - --------------------------------------------------------------------------------- --- * Convenience functions to construct 2 and 3 dimensional points - - --- | We provide pattern synonyms Point2 and Point3 for 2 and 3 dimensional points. i.e. --- we can write: --- --- >>> :{ --- let --- f :: Point 2 r -> r --- f (Point2 x y) = x --- in f (Point2 1 2) --- :} --- 1 --- --- if we want. -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 -pattern Point3 :: r -> r -> r -> Point 3 r -pattern Point3 x y z = (Point (Vector3 x y z)) -{-# COMPLETE Point3 #-} - --- | Shorthand to access the first coordinate C 1 --- --- >>> Point3 1 2 3 ^. xCoord --- 1 --- >>> Point2 1 2 & xCoord .~ 10 --- Point2 [10,2] -xCoord :: (1 <= d, Arity d) => Lens' (Point d r) r -xCoord = coord (C :: C 1) -{-# INLINABLE xCoord #-} - --- | Shorthand to access the second coordinate C 2 --- --- >>> Point2 1 2 ^. yCoord --- 2 --- >>> Point3 1 2 3 & yCoord %~ (+1) --- Point3 [1,3,3] -yCoord :: (2 <= d, Arity d) => Lens' (Point d r) r -yCoord = coord (C :: C 2) -{-# INLINABLE yCoord #-} - --- | Shorthand to access the third coordinate C 3 --- --- >>> Point3 1 2 3 ^. zCoord --- 3 --- >>> Point3 1 2 3 & zCoord %~ (+1) --- Point3 [1,2,4] -zCoord :: (3 <= d, Arity d) => Lens' (Point d r) r -zCoord = coord (C :: C 3) -{-# INLINABLE zCoord #-} - - --------------------------------------------------------------------------------- --- * Point Functors - --- | Types that we can transform by mapping a function on each point in the structure -class PointFunctor g where - pmap :: (Point (Dimension (g r)) r -> Point (Dimension (g s)) s) -> g r -> g s - - -- pemap :: (d ~ Dimension (g r)) => (Point d r :+ p -> Point d s :+ p) -> g r -> g s - -- pemap = - -instance PointFunctor (Point d) where - pmap f = f - - --------------------------------------------------------------------------------- --- * Functions specific to Two Dimensional points - -data CCW = CCW | CoLinear | CW - deriving (Show,Eq) - --- | 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 -> Point 2 r -> Point 2 r -> CCW -ccw p q r = case z `compare` 0 of - LT -> CW - GT -> CCW - EQ -> CoLinear - where - Vector2 ux uy = q .-. p - Vector2 vx vy = r .-. p - z = ux * vy - uy * vx - --- | 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 --- 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] -sortAround c = L.sortBy (ccwCmpAround c <> cmpByDistanceTo c) - - --- | Quadrants of two dimensional points. in CCW order -data Quadrant = TopRight | TopLeft | BottomLeft | BottomRight - deriving (Show,Read,Eq,Ord,Enum,Bounded) - --- | Quadrants around point c; quadrants are closed on their "previous" --- boundary (i..e the boundary with the previous quadrant in the CCW order), --- open on next boundary. The origin itself is assigned the topRight quadrant -quadrantWith :: (Ord r, 1 <= d, 2 <= d, Arity d) - => Point d r :+ q -> Point d r :+ p -> Quadrant -quadrantWith (c :+ _) (p :+ _) = case ( (c^.xCoord) `compare` (p^.xCoord) - , (c^.yCoord) `compare` (p^.yCoord) ) of - (EQ, EQ) -> TopRight - (LT, EQ) -> TopRight - (LT, LT) -> TopRight - (EQ, LT) -> TopLeft - (GT, LT) -> TopLeft - (GT, EQ) -> BottomLeft - (GT, GT) -> BottomLeft - (EQ, GT) -> BottomRight - (LT, GT) -> BottomRight - --- | Quadrants with respect to the origin -quadrant :: (Ord r, Num r, 1 <= d, 2 <= d, Arity d) => Point d r :+ p -> Quadrant -quadrant = quadrantWith (ext origin) - --- | Given a center point c, and a set of points, partition the points into --- quadrants around c (based on their x and y coordinates). The quadrants are --- reported in the order topLeft, topRight, bottomLeft, bottomRight. The points --- are in the same order as they were in the original input lists. --- Points with the same x-or y coordinate as p, are "rounded" to above. -partitionIntoQuadrants :: (Ord r, 1 <= d, 2 <= d, Arity d) - => Point d r :+ q - -> [Point d r :+ p] - -> ( [Point d r :+ p], [Point d r :+ p] - , [Point d r :+ p], [Point d r :+ p] - ) -partitionIntoQuadrants c pts = (topL, topR, bottomL, bottomR) - where - (below',above') = L.partition (on yCoord) pts - (bottomL,bottomR) = L.partition (on xCoord) below' - (topL,topR) = L.partition (on xCoord) above' - - on l q = q^.core.l < c^.core.l - - - --- | 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@(Vector2 zx zy) (c :+ _) (q :+ _) (r :+ _) = - case (ccw c a q, ccw c a r) of - (CCW,CCW) -> cmp - (CCW,CW) -> LT - (CCW,CoLinear) | onZero r -> GT - | otherwise -> LT - - (CW, CCW) -> GT - (CW, CW) -> cmp - (CW, CoLinear) -> GT - - (CoLinear, CCW) | onZero q -> LT - | otherwise -> GT - - (CoLinear, CW) -> LT - (CoLinear,CoLinear) -> case (onZero q, onZero r) of - (True, True) -> EQ - (False, False) -> EQ - (True, False) -> LT - (False, True) -> GT - where - a = c .+^ z - b = c .+^ Vector2 (-zy) zx - -- b is on a perpendicular vector to z - - -- test if the point lies on the ray defined by z, starting in c - onZero d = case ccw c b d of - CCW -> False - CW -> True - CoLinear -> True -- this shouldh appen only when you ask for c itself - - cmp = case ccw c q r of - CCW -> LT - CW -> GT - CoLinear -> EQ - --- | 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) - - - --- | 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) - - --- | 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 -cwCmpAround = cwCmpAroundWith (Vector2 1 0) - - --- | 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. +-- | Compare the points with respect to the direction given by the +-- vector, i.e. by taking planes whose normal is the given vector. -- --- 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) - - --- | Squared Euclidean distance between two points -squaredEuclideanDist :: (Num r, Arity d) => Point d r -> Point d r -> r -squaredEuclideanDist = qdA - --- | Euclidean distance between two points -euclideanDist :: (Floating r, Arity d) => Point d r -> Point d r -> r -euclideanDist = distanceA +-- >>> cmpInDirection (Vector2 1 0) (Point2 5 0) (Point2 10 0) +-- LT +-- >>> cmpInDirection (Vector2 1 1) (Point2 5 0) (Point2 10 0) +-- LT +-- >>> cmpInDirection (Vector2 1 1) (Point2 5 0) (Point2 10 10) +-- LT +-- >>> cmpInDirection (Vector2 1 1) (Point2 15 15) (Point2 10 10) +-- GT +-- >>> cmpInDirection (Vector2 1 0) (Point2 15 15) (Point2 15 10) +-- EQ +cmpInDirection :: (Ord r, Num r) => Vector 2 r -> Point 2 r -> Point 2 r -> Ordering +cmpInDirection n p q = case p `onSide` perpendicularTo (Line q n) of + LeftSide -> LT + OnLine -> EQ + RightSide -> GT + -- TODO: Generalize to arbitrary dimension diff --git a/src/Data/Geometry/Point/Class.hs b/src/Data/Geometry/Point/Class.hs new file mode 100644 --- /dev/null +++ b/src/Data/Geometry/Point/Class.hs @@ -0,0 +1,85 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +module Data.Geometry.Point.Class where + +import Control.Lens +import Data.Geometry.Point.Internal (Point) +import qualified Data.Geometry.Point.Internal as Internal +import Data.Geometry.Vector +import GHC.TypeNats + +-------------------------------------------------------------------------------- + +-- $setup +-- >>> import Data.Geometry.Point.Internal (pattern Point2, pattern Point3, origin) + +class ToAPoint point d r where + toPoint :: Prism' (point d r) (Point d r) + +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 @2 +-- 2 +-- >>> Point3 1 2 3 & coord @1 .~ 10 +-- Point3 10 2 3 +-- >>> Point3 1 2 3 & coord @3 %~ (+1) +-- Point3 1 2 4 +coord :: forall i p d r. (1 <= i, i <= d, KnownNat i, Arity d, AsAPoint p) => Lens' (p d r) r +coord = 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 + +instance ToAPoint Point d r where + toPoint = prism' id Just + +instance AsAPoint Point where + asAPoint = id + + +-- | Shorthand to access the first coordinate C 1 +-- +-- >>> Point3 1 2 3 ^. xCoord +-- 1 +-- >>> Point2 1 2 & xCoord .~ 10 +-- Point2 10 2 +xCoord :: (1 <= d, Arity d, AsAPoint point) => Lens' (point d r) r +xCoord = coord @1 +{-# INLINABLE xCoord #-} + +-- | Shorthand to access the second coordinate C 2 +-- +-- >>> Point2 1 2 ^. yCoord +-- 2 +-- >>> Point3 1 2 3 & yCoord %~ (+1) +-- Point3 1 3 3 +yCoord :: (2 <= d, Arity d, AsAPoint point) => Lens' (point d r) r +yCoord = coord @2 +{-# INLINABLE yCoord #-} + +-- | Shorthand to access the third coordinate C 3 +-- +-- >>> 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 +zCoord = coord @3 +{-# INLINABLE zCoord #-} diff --git a/src/Data/Geometry/Point/Internal.hs b/src/Data/Geometry/Point/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Data/Geometry/Point/Internal.hs @@ -0,0 +1,303 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Data.Geometry.Point +-- Copyright : (C) Frank Staals +-- License : see the LICENSE file +-- Maintainer : Frank Staals +-- +-- \(d\)-dimensional points. +-- +-------------------------------------------------------------------------------- +module Data.Geometry.Point.Internal + ( Point(..) + , origin, vector + , pointFromList + + , coord , unsafeCoord + + , projectPoint + + , pattern Point1 + , pattern Point2 + , pattern Point3 + , PointFunctor(..) + + , cmpByDistanceTo + , cmpByDistanceTo' + , squaredEuclideanDist, euclideanDist + , HasSquaredEuclideanDistance(..) + ) where + +import Control.DeepSeq +import Control.Lens +import Control.Monad +import Data.Aeson +import Data.Ext +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 Data.Hashable +import Data.List (intersperse) +import Data.Ord (comparing) +import Data.Proxy +import GHC.Generics (Generic) +import GHC.TypeLits +import System.Random (Random (..)) +import Test.QuickCheck (Arbitrary, Arbitrary1) +import Text.Read (Read (..), readListPrecDefault) + + +-------------------------------------------------------------------------------- +-- $setup +-- >>> :{ +-- let myVector :: Vector 3 Int +-- myVector = Vector3 1 2 3 +-- myPoint = Point myVector +-- :} + + +-------------------------------------------------------------------------------- +-- * 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 + 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 = liftReadPrec readPrec readListPrec + readListPrec = readListPrecDefault + +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) + + +type instance NumType (Point d r) = r +type instance Dimension (Point d r) = d + +instance Arity d => Affine (Point d) where + type Diff (Point d) = Vector d + + p .-. q = toVec p ^-^ toVec q + p .+^ v = Point $ toVec p ^+^ v + +instance (FromJSON r, Arity d, KnownNat d) => FromJSON (Point d r) where + parseJSON = fmap Point . parseJSON + +instance (ToJSON r, Arity d) => ToJSON (Point d r) where + toJSON = toJSON . toVec + toEncoding = toEncoding . toVec + +-- | Point representing the origin in d dimensions +-- +-- >>> origin :: Point 4 Int +-- Point4 0 0 0 0 +origin :: (Arity d, Num r) => Point d r +origin = Point $ pure 0 + + +-- ** Accessing points + +-- | 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 :: Lens (Point d r) (Point d r') (Vector d r) (Vector d r') +vector = lens toVec (const Point) +{-# INLINABLE vector #-} + +-- | 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 => Int -> Lens' (Point d r) r +unsafeCoord i = vector . singular (ix (i-1)) + -- Points are 1 indexed, vectors are 0 indexed +{-# INLINABLE unsafeCoord #-} + +-- | Get the coordinate in a given dimension +-- +-- >>> Point3 1 2 3 ^. coord @2 +-- 2 +-- >>> Point3 1 2 3 & coord @1 .~ 10 +-- Point3 10 2 3 +-- >>> Point3 1 2 3 & coord @3 %~ (+1) +-- Point3 1 2 4 +coord :: forall i d r. (1 <= i, i <= d, Arity d, KnownNat i) + => Lens' (Point d r) r +coord = unsafeCoord $ fromIntegral (natVal $ C @i) +{-# INLINABLE coord #-} + + -- somehow these rules don't fire +-- {-# SPECIALIZE coord :: C 1 -> Lens' (Point 2 r) r#-} +-- {-# SPECIALIZE coord :: C 2 -> Lens' (Point 2 r) r#-} +-- {-# SPECIALIZE coord :: C 3 -> Lens' (Point 3 r) r#-} + + +-- | Constructs a point from a list of coordinates. The length of the +-- list has to match the dimension exactly. +-- +-- >>> pointFromList [1,2,3] :: Maybe (Point 3 Int) +-- Just (Point3 1 2 3) +-- >>> pointFromList [1] :: Maybe (Point 3 Int) +-- Nothing +-- >>> pointFromList [1,2,3,4] :: Maybe (Point 3 Int) +-- Nothing +pointFromList :: Arity d => [r] -> Maybe (Point d r) +pointFromList = fmap Point . Vec.vectorFromList + + +-- | Project a point down into a lower dimension. +projectPoint :: (Arity i, Arity d, i <= d) => Point d r -> Point i r +projectPoint = Point . prefix . toVec + +-------------------------------------------------------------------------------- +-- * Convenience functions to construct 1, 2 and 3 dimensional points + +-- | A bidirectional pattern synonym for 1 dimensional points. +pattern Point1 :: r -> Point 1 r +pattern Point1 x = Point (Vector1 x) +{-# COMPLETE Point1 #-} + + +-- | 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 #-} + +-- | 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 #-} + +-------------------------------------------------------------------------------- +-- * Point Functors + +-- | Types that we can transform by mapping a function on each point in the structure +class PointFunctor g where + pmap :: (Point (Dimension (g r)) r -> Point (Dimension (g s)) s) -> g r -> g s + + -- pemap :: (d ~ Dimension (g r)) => (Point d r :+ p -> Point d s :+ p) -> g r -> g s + -- pemap = + +instance PointFunctor (Point d) where + pmap f = f + + + +-------------------------------------------------------------------------------- + + + + +-------------------------------------------------------------------------------- +-- * Functions specific to Two Dimensional points + +-- | Compare by distance to the first argument +cmpByDistanceTo :: (Ord r, Num r, Arity d) + => 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) + + +-- | Squared Euclidean distance between two points +squaredEuclideanDist :: (Num r, Arity d) => Point d r -> Point d r -> r +squaredEuclideanDist = qdA + +-- | Euclidean distance between two points +euclideanDist :: (Floating r, Arity d) => Point d r -> Point d r -> r +euclideanDist = distanceA + + +-------------------------------------------------------------------------------- +-- * Distances + +class HasSquaredEuclideanDistance g where + -- | Given a point q and a geometry g, the squared Euclidean distance between q and g. + squaredEuclideanDistTo :: (Num (NumType g), Arity (Dimension g)) + => Point (Dimension g) (NumType g) -> g -> NumType g + squaredEuclideanDistTo q = snd . pointClosestToWithDistance q + + -- | Given q and g, computes the point p in g closest to q according + -- to the Squared Euclidean distance. + pointClosestTo :: (Num (NumType g), Arity (Dimension g)) + => Point (Dimension g) (NumType g) -> g + -> Point (Dimension g) (NumType g) + pointClosestTo q = fst . pointClosestToWithDistance q + + -- | Given q and g, computes the point p in g closest to q according + -- to the Squared Euclidean distance. Returns both the point and the + -- distance realized by this point. + pointClosestToWithDistance :: (Num (NumType g), Arity (Dimension g)) + => Point (Dimension g) (NumType g) -> g + -> (Point (Dimension g) (NumType g), NumType g) + pointClosestToWithDistance q g = let p = pointClosestTo q g + in (p, squaredEuclideanDist p q) + {-# MINIMAL pointClosestToWithDistance | pointClosestTo #-} + +instance (Num r, Arity d) => HasSquaredEuclideanDistance (Point d r) where + pointClosestTo _ p = p diff --git a/src/Data/Geometry/Point/Orientation.hs b/src/Data/Geometry/Point/Orientation.hs new file mode 100644 --- /dev/null +++ b/src/Data/Geometry/Point/Orientation.hs @@ -0,0 +1,31 @@ +module Data.Geometry.Point.Orientation where + +import Algorithms.Geometry.SoS.Orientation +import Algorithms.Geometry.SoS.Sign +import Data.Ext +import Data.Geometry.Point.Internal +import Data.Geometry.Vector + +-------------------------------------------------------------------------------- + +-------------------------------------------------------------------------------- + +newtype StrictCCW = SCCW Sign deriving Eq + +pattern CCW :: StrictCCW +pattern CCW = SCCW Negative + +pattern CW :: StrictCCW +pattern CW = SCCW Positive +{-# COMPLETE CCW, CW #-} + +instance Show StrictCCW where + show = \case + CCW -> "CCW" + CW -> "CW" + + +-- | Given three points p q and r determine the orientation when going from p to r via q. +ccw :: (Ord r, Num r, Ord i) + => Point 2 r :+ i -> Point 2 r :+ i -> Point 2 r :+ i -> StrictCCW +ccw p q r = SCCW $ sideTest r (Vector2 p q) diff --git a/src/Data/Geometry/Point/Orientation/Degenerate.hs b/src/Data/Geometry/Point/Orientation/Degenerate.hs new file mode 100644 --- /dev/null +++ b/src/Data/Geometry/Point/Orientation/Degenerate.hs @@ -0,0 +1,226 @@ +module Data.Geometry.Point.Orientation.Degenerate( + CCW(..) + , pattern CCW, pattern CW, pattern CoLinear + + , ccw, ccw' + + , isCoLinear + + , sortAround, sortAround' + + , ccwCmpAroundWith, ccwCmpAroundWith' + , cwCmpAroundWith, cwCmpAroundWith' + , ccwCmpAround, ccwCmpAround' + , cwCmpAround, cwCmpAround' + + , insertIntoCyclicOrder + ) where + +import Control.Lens +import qualified Data.CircularList as C +import qualified Data.CircularList.Util as CU +import Data.Ext +import Data.Geometry.Point.Internal +import Data.Geometry.Vector +import qualified Data.List as L + +-------------------------------------------------------------------------------- + +-- $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 #-} + +instance Show CCW where + show = \case + CCW -> "CCW" + CW -> "CW" + CoLinear -> "CoLinear" + + +-- | 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 $ (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 + -- EQ -> CoLinear + where + Vector2 ux uy = q .-. p + Vector2 vx vy = r .-. p + -- _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) + +-- | \( 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 -> [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. +-- +-- pre: the points p,q /= c +ccwCmpAroundWith :: (Ord r, Num r) + => Vector 2 r + -> Point 2 r + -> Point 2 r -> Point 2 r + -> Ordering +ccwCmpAroundWith z@(Vector2 zx zy) c q r = + case (ccw c a q, ccw c a r) of + (CCW,CCW) -> cmp + (CCW,CW) -> LT + (CCW,CoLinear) | onZero r -> GT + | otherwise -> LT + + (CW, CCW) -> GT + (CW, CW) -> cmp + (CW, CoLinear) -> GT + + (CoLinear, CCW) | onZero q -> LT + | otherwise -> GT + + (CoLinear, CW) -> LT + (CoLinear,CoLinear) -> case (onZero q, onZero r) of + (True, True) -> EQ + (False, False) -> EQ + (True, False) -> LT + (False, True) -> GT + where + a = c .+^ z + b = c .+^ Vector2 (-zy) zx + -- b is on a perpendicular vector to z + + -- test if the point lies on the ray defined by z, starting in c + onZero d = case ccw c b d of + CCW -> False + CW -> True + CoLinear -> True -- this shouldh appen only when you ask for c itself + + cmp = case ccw c q r of + CCW -> LT + CW -> GT + 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) + +-- | 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 -> 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 -> 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) + +-- | \( 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. +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) diff --git a/src/Data/Geometry/Point/Quadrants.hs b/src/Data/Geometry/Point/Quadrants.hs new file mode 100644 --- /dev/null +++ b/src/Data/Geometry/Point/Quadrants.hs @@ -0,0 +1,62 @@ +-------------------------------------------------------------------------------- +-- | +-- 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.Lens +import Data.Ext +import Data.Geometry.Point.Class +import Data.Geometry.Point.Internal +import Data.Geometry.Vector +import qualified Data.List as L +import GHC.TypeLits + +-------------------------------------------------------------------------------- + +-- | Quadrants of two dimensional points. in CCW order +data Quadrant = TopRight | TopLeft | BottomLeft | BottomRight + deriving (Show,Read,Eq,Ord,Enum,Bounded) + +-- | Quadrants around point c; quadrants are closed on their "previous" +-- boundary (i..e the boundary with the previous quadrant in the CCW order), +-- open on next boundary. The origin itself is assigned the topRight quadrant +quadrantWith :: (Ord r, 1 <= d, 2 <= d, Arity d) + => Point d r :+ q -> Point d r :+ p -> Quadrant +quadrantWith (c :+ _) (p :+ _) = case ( (c^.xCoord) `compare` (p^.xCoord) + , (c^.yCoord) `compare` (p^.yCoord) ) of + (EQ, EQ) -> TopRight + (LT, EQ) -> TopRight + (LT, LT) -> TopRight + (EQ, LT) -> TopLeft + (GT, LT) -> TopLeft + (GT, EQ) -> BottomLeft + (GT, GT) -> BottomLeft + (EQ, GT) -> BottomRight + (LT, GT) -> BottomRight + +-- | Quadrants with respect to the origin +quadrant :: (Ord r, Num r, 1 <= d, 2 <= d, Arity d) => Point d r :+ p -> Quadrant +quadrant = quadrantWith (ext origin) + +-- | Given a center point c, and a set of points, partition the points into +-- quadrants around c (based on their x and y coordinates). The quadrants are +-- reported in the order topLeft, topRight, bottomLeft, bottomRight. The points +-- are in the same order as they were in the original input lists. +-- Points with the same x-or y coordinate as p, are "rounded" to above. +partitionIntoQuadrants :: (Ord r, 1 <= d, 2 <= d, Arity d) + => Point d r :+ q + -> [Point d r :+ p] + -> ( [Point d r :+ p], [Point d r :+ p] + , [Point d r :+ p], [Point d r :+ p] + ) +partitionIntoQuadrants c pts = (topL, topR, bottomL, bottomR) + where + (below',above') = L.partition (on yCoord) pts + (bottomL,bottomR) = L.partition (on xCoord) below' + (topL,topR) = L.partition (on xCoord) above' + + on l q = q^.core.l < c^.core.l 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,176 @@ +{-# 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.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 @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,11 +1,18 @@ -{-# 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 import Data.Aeson +import Data.Bifoldable import Data.Bifunctor +import Data.Bitraversable import Data.Ext import qualified Data.Foldable as F import Data.Geometry.Box @@ -17,16 +24,28 @@ import Data.LSeq (LSeq, pattern (:<|)) import qualified Data.LSeq as LSeq import qualified Data.List.NonEmpty as NE -import GHC.Generics(Generic) +import Data.Ord (comparing) +import GHC.Generics (Generic) import GHC.TypeLits -------------------------------------------------------------------------------- + +-------------------------------------------------------------------------------- +-- $setup +-- >>> :{ +-- let myPolyLine = fromPointsUnsafe $ map ext [origin, Point2 10.0 10.0, Point2 10.0 20.0] +-- :} + +-------------------------------------------------------------------------------- -- * d-dimensional Polygonal Lines (PolyLines) -- | 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) @@ -50,25 +69,49 @@ pmap f = over points (fmap (first f)) instance Arity d => Bifunctor (PolyLine d) where - bimap f g (PolyLine pts) = PolyLine $ fmap (bimap (fmap g) f) pts + bimap = bimapDefault +instance Arity d => Bifoldable (PolyLine d) where + bifoldMap = bifoldMapDefault +instance Arity d => Bitraversable (PolyLine d) where + bitraverse f g (PolyLine pts) = PolyLine <$> traverse (bitraverse (traverse g) f) pts instance (ToJSON p, ToJSON r, Arity d) => ToJSON (PolyLine d p r) where 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 + +instance (Fractional r, Arity d, Ord r) => HasSquaredEuclideanDistance (PolyLine d p r) where + pointClosestToWithDistance q = F.minimumBy (comparing snd) + . fmap (pointClosestToWithDistance q) + . edgeSegments + + +-- | 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 @2 . LSeq.fromList + -- | pre: The input list contains at least two points -fromPoints :: [Point d r :+ p] -> PolyLine d p r -fromPoints = PolyLine . LSeq.forceLSeq (C :: C 2) . LSeq.fromList +fromPointsUnsafe :: [Point d r :+ p] -> PolyLine d p r +fromPointsUnsafe = PolyLine . LSeq.forceLSeq (C @2) . LSeq.fromList -- | pre: The input list contains at least two points. All extra vields are -- initialized with mempty. -fromPoints' :: (Monoid p) => [Point d r] -> PolyLine d p r -fromPoints' = fromPoints . map (\p -> p :+ mempty) +fromPointsUnsafe' :: (Monoid p) => [Point d r] -> PolyLine d p r +fromPointsUnsafe' = fromPointsUnsafe . map (:+ mempty) -- | We consider the line-segment as closed. fromLineSegment :: LineSegment d p r -> PolyLine d p r -fromLineSegment ~(LineSegment' p q) = fromPoints [p,q] +fromLineSegment ~(LineSegment' p q) = fromPointsUnsafe [p,q] -- | Convert to a closed line segment by taking the first two points. asLineSegment :: PolyLine d p r -> LineSegment d p r @@ -80,3 +123,23 @@ asLineSegment' (PolyLine pts) = case F.toList pts of [p,q] -> Just $ ClosedLineSegment p q _ -> Nothing + +-- | Computes the edges, as linesegments, of an LSeq +edgeSegments :: Arity d => PolyLine d p r -> LSeq 1 (LineSegment d p r) +edgeSegments pl = let vs = pl^.points + in LSeq.zipWith ClosedLineSegment (LSeq.init vs) (LSeq.tail vs) + + +-- | Linearly interpolate the polyline with a value in the range +-- \([0,n-1]\), where \(n\) is the number of vertices of the polyline. +-- +-- running time: \(O(\log n)\) +-- +-- >>> interpolatePoly 0.5 myPolyLine +-- Point2 5.0 5.0 +-- >>> interpolatePoly 1.5 myPolyLine +-- 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 + Just e -> interpolate (t-fromIntegral i) e 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,4 @@ -{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} -------------------------------------------------------------------------------- -- | -- Module : Data.Geometry.Polygon @@ -9,55 +9,92 @@ -- 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) import Control.Monad.Random.Class import Data.Ext import qualified Data.Foldable as F +import Data.Geometry.Boundary import Data.Geometry.HalfSpace (rightOf) import Data.Geometry.Line +import Data.Geometry.LineSegment import Data.Geometry.Point import Data.Geometry.Polygon.Core import Data.Geometry.Polygon.Extremes - +import Data.Geometry.Properties +import Data.Ord (comparing) +import qualified Data.Sequence as Seq -------------------------------------------------------------------------------- -- * Polygons @@ -76,3 +113,42 @@ -- 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 `HasIntersectionWith` Polygon t p r where + q `intersects` pg = q `inPolygon` pg /= Outside + +instance (Fractional r, Ord r) => Point 2 r `IsIntersectableWith` Polygon t p r where + nonEmptyIntersection = defaultNonEmptyIntersection + 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 + +instance (Fractional r, Ord r) => HasSquaredEuclideanDistance (Boundary (Polygon t p r)) where + pointClosestToWithDistance q = F.minimumBy (comparing snd) + . fmap (pointClosestToWithDistance q) + . listEdges . review _Boundary + +instance (Fractional r, Ord r) => HasSquaredEuclideanDistance (Polygon t p r) where + pointClosestToWithDistance q pg + | q `intersects` pg = (q, 0) + | otherwise = pointClosestToWithDistance q (Boundary pg) diff --git a/src/Data/Geometry/Polygon/Bezier.hs b/src/Data/Geometry/Polygon/Bezier.hs new file mode 100644 --- /dev/null +++ b/src/Data/Geometry/Polygon/Bezier.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Data.Geometry.Polygon.Bezier + ( PathJoin(..) + , fromBeziers + , approximate + , approximateSome + ) where + +import Control.Lens +import Data.Ext +import Data.Geometry.BezierSpline (BezierSpline, pattern Bezier3) +import qualified Data.Geometry.BezierSpline as Bezier +import Data.Geometry.Point +import Data.Geometry.PolyLine(points) +import Data.Geometry.Polygon +import qualified Data.Vector.Circular as CV +import qualified Data.Foldable as F + +data PathJoin r + = JoinLine + | JoinCurve (Point 2 r) (Point 2 r) + deriving (Show, Eq, Ord) + +-- | Construct a polygon from a closed set of bezier curves. Each curve must be connected to +-- its neighbours. +fromBeziers :: (Eq r, Num r) => [BezierSpline 3 2 r] -> SimplePolygon (PathJoin r) r +fromBeziers curves + | isCounterClockwise expanded = p + | otherwise = p' + where + p = unsafeFromPoints + [ a :+ JoinCurve b c + | Bezier3 a b c _d <- curves ] + p' = unsafeFromPoints + [ d :+ JoinCurve c b + | Bezier3 _a b c d <- reverse curves ] + expanded = unsafeFromPoints $ concat + [ map ext [a, b, c] + | Bezier3 a b c _d <- curves ] + +approximate :: forall t r. (Ord r, Fractional r) => r -> Polygon t (PathJoin r) r -> Polygon t () r +approximate eps p = + case p of + SimplePolygon{} -> + let vs = p^.outerBoundaryVector + in unsafeFromCircularVector $ CV.concatMap f $ CV.zip vs (CV.rotateRight 1 vs) + MultiPolygon v hs -> MultiPolygon (approximate eps v) (map (approximate eps) hs) + where + f :: (Point 2 r :+ PathJoin r, Point 2 r :+ PathJoin r) -> CV.CircularVector (Point 2 r :+ ()) + f (a :+ JoinLine, _) = CV.singleton (ext a) + f (a :+ JoinCurve b c, d :+ _) = let poly = Bezier.approximate eps (Bezier3 a b c d) + in CV.unsafeFromList . init . F.toList $ poly^.points + +approximateSome :: (Ord r, Fractional r) => r -> SomePolygon (PathJoin r) r -> SomePolygon () r +approximateSome eps (Left p) = Left $ approximate eps p +approximateSome eps (Right p) = Right $ approximate eps p 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,101 +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 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 Data.Geometry.Triangle (Triangle (..), + inTriangle) +import Data.Geometry.Vector (Additive (zero, (^+^)), + Affine ((.+^), (.-.)), + (*^), (^*), (^/)) 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.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 -let simplePoly :: SimplePolygon () Rational - simplePoly = SimplePolygon . C.fromList . map ext $ [ Point2 0 0 - , Point2 10 0 - , Point2 10 10 - , Point2 5 15 - , Point2 1 11 - ] +-- 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] :} -} --- | 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 @@ -112,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 @@ -123,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 @@ -138,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 <> ")" @@ -153,54 +236,92 @@ 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 (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 (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 (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 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 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 +-- | 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 --- * Functions on Polygons + 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 -outerBoundary :: forall t p r. Lens' (Polygon t p r) (C.CSeq (Point 2 r :+ p)) + +-- | \( 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 @@ -210,16 +331,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) @@ -228,36 +363,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 . map ext $ 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 . map ext + 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) @@ -268,20 +483,21 @@ -- -- -- >>> mapM_ print . polygonVertices $ withIncidentEdges simplePoly --- Point2 [0 % 1,0 % 1] :+ SP LineSegment (Closed (Point2 [1 % 1,11 % 1] :+ ())) (Closed (Point2 [0 % 1,0 % 1] :+ ())) LineSegment (Closed (Point2 [0 % 1,0 % 1] :+ ())) (Closed (Point2 [10 % 1,0 % 1] :+ ())) --- Point2 [10 % 1,0 % 1] :+ SP LineSegment (Closed (Point2 [0 % 1,0 % 1] :+ ())) (Closed (Point2 [10 % 1,0 % 1] :+ ())) LineSegment (Closed (Point2 [10 % 1,0 % 1] :+ ())) (Closed (Point2 [10 % 1,10 % 1] :+ ())) --- Point2 [10 % 1,10 % 1] :+ SP LineSegment (Closed (Point2 [10 % 1,0 % 1] :+ ())) (Closed (Point2 [10 % 1,10 % 1] :+ ())) LineSegment (Closed (Point2 [10 % 1,10 % 1] :+ ())) (Closed (Point2 [5 % 1,15 % 1] :+ ())) --- Point2 [5 % 1,15 % 1] :+ SP LineSegment (Closed (Point2 [10 % 1,10 % 1] :+ ())) (Closed (Point2 [5 % 1,15 % 1] :+ ())) LineSegment (Closed (Point2 [5 % 1,15 % 1] :+ ())) (Closed (Point2 [1 % 1,11 % 1] :+ ())) --- Point2 [1 % 1,11 % 1] :+ SP LineSegment (Closed (Point2 [5 % 1,15 % 1] :+ ())) (Closed (Point2 [1 % 1,11 % 1] :+ ())) LineSegment (Closed (Point2 [1 % 1,11 % 1] :+ ())) (Closed (Point2 [0 % 1,0 % 1] :+ ())) +-- 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 - f p c n = c&extra .~ SP (ClosedLineSegment p c) (ClosedLineSegment c n) + 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 @@ -289,143 +505,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) @@ -436,43 +542,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 @@ -505,59 +601,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 @@ -565,7 +650,164 @@ -- will be numbered last, in the same order. -- -- >>> numberVertices simplePoly --- SimplePolygon (CSeq [Point2 [0 % 1,0 % 1] :+ SP 0 (),Point2 [10 % 1,0 % 1] :+ SP 1 (),Point2 [10 % 1,10 % 1] :+ SP 2 (),Point2 [5 % 1,15 % 1] :+ SP 3 (),Point2 [1 % 1,11 % 1] :+ 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 @@ -26,6 +26,8 @@ import Data.Geometry.Point import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.List.NonEmpty as NonEmpty +import Data.Measured.Class () +import Data.Measured.Size import Data.Ord (comparing, Down(..)) import Data.Range import qualified Data.Set as Set @@ -39,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) @@ -95,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 new file mode 100644 --- /dev/null +++ b/src/Data/Geometry/QuadTree.hs @@ -0,0 +1,211 @@ +{-# 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 + -- , QuadTree(..) + -- , leaves + -- , withCells + -- ) + where + + +import Control.Lens (makeLenses, (^.), (.~), (&), (^?!), ix, view) +import Data.Ext +import qualified Data.Foldable as F +import Data.Geometry.Box +import Data.Geometry.Point +import Data.Geometry.QuadTree.Cell +import Data.Geometry.QuadTree.Quadrants +import Data.Geometry.QuadTree.Split +import Data.Geometry.QuadTree.Tree (Tree(..)) +import qualified Data.Geometry.QuadTree.Tree as Tree +import Data.Geometry.Vector +import Data.Intersection +import Data.List.NonEmpty (NonEmpty(..)) +import Data.Tree.Util (TreeNode(..), levels) +import GHC.Generics (Generic) +-------------------------------------------------------------------------------- + +-- | QuadTree on the starting cell +data QuadTree v p r = QuadTree { _startingCell :: !(Cell r) + , _tree :: !(Tree v p) + } + deriving (Show,Eq,Generic,Functor,Foldable,Traversable) +makeLenses ''QuadTree + +-------------------------------------------------------------------------------- +-- * Functions operating on the QuadTree (in terms of the 'Tree' type) + +withCells :: (Fractional r, Ord r) => QuadTree v p r -> QuadTree (v :+ Cell r) (p :+ Cell r) r +withCells qt = qt&tree .~ withCellsTree qt + +withCellsTree :: (Fractional r, Ord r) + => QuadTree v p r -> Tree (v :+ Cell r) (p :+ Cell r) +withCellsTree (QuadTree c t) = Tree.withCells c t + +leaves :: QuadTree v p r -> NonEmpty p +leaves = Tree.leaves . view tree + +perLevel :: QuadTree v p r -> NonEmpty (NonEmpty (TreeNode v p)) +perLevel = levels . Tree.toRoseTree . view tree + + +-------------------------------------------------------------------------------- + +-- | Given a starting cell, a Tree builder, and some input required by +-- the builder, constructs a quadTree. +buildOn :: Cell r -> (Cell r -> i -> Tree v p) -> i -> QuadTree v p r +buildOn c0 builder = QuadTree c0 . builder c0 + +-- | The Equivalent of Tree.build for constructing a QuadTree +build :: (Fractional r, Ord r) => (Cell r -> i -> Split i v p) -> Cell r -> i -> QuadTree v p r +build f c = buildOn c (Tree.build f) + +-- | Build a QuadtTree from a set of points. +-- +-- pre: the points lie inside the initial given cell. +-- +-- running time: \(O(nh)\), where \(n\) is the number of points and +-- \(h\) is the height of the resulting quadTree. +fromPointsBox :: (Fractional r, Ord r) + => Cell r -> [Point 2 r :+ p] -> QuadTree () (Maybe (Point 2 r :+ p)) r +fromPointsBox c = buildOn c Tree.fromPoints + +fromPoints :: (RealFrac r, Ord r) + => NonEmpty (Point 2 r :+ p) -> QuadTree () (Maybe (Point 2 r :+ p)) r +fromPoints pts = buildOn c Tree.fromPoints (F.toList pts) + 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 +findLeaf :: (Fractional r, Ord r) + => Point 2 r -> QuadTree v p r -> Maybe (p :+ Cell r) +findLeaf q (QuadTree c0 t) | q `intersects` c0 = Just $ findLeaf' c0 t + | otherwise = Nothing + where + -- | + -- pre: p intersects c + findLeaf' c = \case + Leaf p -> p :+ c + Node _ qs -> let quad = quadrantOf q c + in findLeaf' ((splitCell c)^?!ix quad) (qs^?!ix quad) + +-------------------------------------------------------------------------------- + + +fromZeros :: (Fractional r, Ord r, Num a, Eq a, v ~ Quadrants Sign) + => Cell r -> (Point 2 r -> a) -> QuadTree v (Either v Sign) r +fromZeros = fromZerosWith (limitWidthTo (-1)) + + +fromZerosWith :: (Fractional r, Ord r, Eq a, Num a) + => Limiter r (Corners Sign) (Corners Sign) Sign + -> Cell r + -> (Point 2 r -> a) + -> QuadTree (Quadrants Sign) (Signs Sign) r +fromZerosWith limit c0 f = fromZerosWith' limit c0 (fromSignum f) + + +type Signs sign = Either (Corners sign) sign + + +fromZerosWith' :: (Eq sign, Fractional r, Ord r) + => Limiter r (Corners sign) (Corners sign) sign + -> Cell r + -> (Point 2 r -> sign) + -> QuadTree (Quadrants sign) (Signs sign) r +fromZerosWith' limit c0 f = build (limit $ shouldSplitZeros f) c0 (f <$> cellCorners c0) + + + +-- type Sign = Ordering + +-- pattern Negative :: Sign +-- pattern Negative = LT +-- pattern Zero :: Sign +-- pattern Zero = EQ +-- pattern Positive :: Sign +-- pattern Positive = GT +-- {-# COMPLETE Negative, Zero, Positive #-} + +-- fromOrdering :: Ordering -> Sign +-- fromOrdering = id + + +data Sign = Negative | Zero | Positive deriving (Show,Eq,Ord) + + + +-- | Interpret an ordering result as a Sign +fromOrdering :: Ordering -> Sign +fromOrdering = \case + LT -> Negative + EQ -> Zero + GT -> Positive + +fromSignum :: (Num a, Eq a) => (b -> a) -> b -> Sign +fromSignum f x = case signum (f x) of + -1 -> Negative + 0 -> Zero + 1 -> Positive + _ -> error "absurd: fromSignum" + +-- | Splitter that determines if we should split a cell based on the +-- sign of the corners. +shouldSplitZeros :: forall r sign. (Fractional r, Eq sign) + => (Point 2 r -> sign) -- ^ The function we are evaluating + -> Splitter r + (Quadrants sign) -- the input are the signs of the corners + (Quadrants sign) -- at internal nodes we store signs of corners + sign +shouldSplitZeros f (Cell w' p) qs@(Quadrants nw ne se sw) | all sameSign qs = No ne + | otherwise = Yes qs qs' + where + m = fAt rr rr + n = fAt rr ww + e = fAt ww rr + s = fAt rr 0 + w = fAt 0 rr + + sameSign = (== ne) + + -- signs at the new corners + qs' = Quadrants (Quadrants nw n m w) + (Quadrants n ne e m) + (Quadrants m e se s) + (Quadrants w m s sw) + + r = w' - 1 + rr = pow r + ww = pow w' + + fAt x y = f $ p .+^ Vector2 x y + + +isZeroCell :: (Eq sign) => sign -- ^ the zero value + -> Either v sign -> Bool +isZeroCell z = \case + Left _ -> True -- if we kept splitting then we must have a sign transition + Right s -> s == z + +-------------------------------------------------------------------------------- + + + +-- | Constructs an empty/complete tree from the starting width +completeTree :: (Fractional r, Ord r) => Cell r -> QuadTree () () r +completeTree c0 = + build (\_ w -> if w == 0 then No () else Yes () (pure $ w - 1)) c0 (c0^.cellWidthIndex) + +-------------------------------------------------------------------------------- diff --git a/src/Data/Geometry/QuadTree/Cell.hs b/src/Data/Geometry/QuadTree/Cell.hs new file mode 100644 --- /dev/null +++ b/src/Data/Geometry/QuadTree/Cell.hs @@ -0,0 +1,151 @@ +{-# 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) +import Data.Ext +import Data.Geometry.Box +import Data.Geometry.Directions +import Data.Geometry.LineSegment +import Data.Geometry.Point +import Data.Geometry.Properties +import Data.Geometry.QuadTree.Quadrants +import Data.Geometry.Vector + +-------------------------------------------------------------------------------- + +-- | side lengths will be 2^i for some integer i +type WidthIndex = Int + +-- | A Cell corresponding to a node in the QuadTree +data Cell r = Cell { _cellWidthIndex :: {-# UNPACK #-} !WidthIndex + , _lowerLeft :: !(Point 2 r) + } deriving (Show,Eq,Functor,Foldable,Traversable) +makeLenses ''Cell + +-- | Computes a cell that contains the given rectangle +fitsRectangle :: (RealFrac r, Ord r) => Rectangle p r -> Cell r +fitsRectangle b = Cell w ((b^.to minPoint.core) .-^ Vector2 1 1) + where + w = lg' . ceiling . (1+) . maximum . size $ b + + -- "approximate log" that over approximates by a factor of at most two. + lg' :: Integer -> WidthIndex + lg' n = go 1 + where + go i | floor (pow i) <= n = go (i+1) -- note that the floor does not really do anything + -- since i is integral and >= 1. + | otherwise = i + +type instance Dimension (Cell r) = 2 +type instance NumType (Cell r) = r + +type instance IntersectionOf (Point 2 r) (Cell r) = '[ NoIntersection, Point 2 r] + +instance (Ord r, Fractional r) => Point 2 r `HasIntersectionWith` Cell r where + p `intersects` c = p `intersects` toBox c + +instance (Ord r, Fractional r) => Point 2 r `IsIntersectableWith` Cell r where + nonEmptyIntersection = defaultNonEmptyIntersection + p `intersect` c = p `intersect` toBox c + +pow :: Fractional r => WidthIndex -> r +pow i = case i `compare` 0 of + LT -> 1 / (2 ^ (-1*i)) + EQ -> 1 + GT -> 2 ^ i + +cellWidth :: Fractional r => Cell r -> r +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)) + +inCell :: (Fractional r, Ord r) => Point 2 r :+ p -> Cell r -> Bool +inCell (p :+ _) c = p `inBox` toBox c + +cellCorners :: Fractional r => Cell r -> Quadrants (Point 2 r) +cellCorners = fmap (^.core) . corners . toBox + +-- | Sides are open +cellSides :: Fractional r => Cell r -> Sides (LineSegment 2 () r) +cellSides = fmap (\(ClosedLineSegment p q) -> OpenLineSegment p q) . sides . toBox + +splitCell :: (Num r, Fractional r) => Cell r -> Quadrants (Cell r) +splitCell (Cell w p) = Quadrants (Cell r $ f 0 rr) + (Cell r $ f rr rr) + (Cell r $ f rr 0) + (Cell r p) + where + r = w - 1 + rr = pow r + f x y = p .+^ Vector2 x y + + +midPoint :: Fractional r => Cell r -> Point 2 r +midPoint (Cell w p) = let rr = pow (w - 1) in p .+^ Vector2 rr rr + + +-------------------------------------------------------------------------------- + +-- | Partitions the points into quadrants. See 'quadrantOf' for the +-- precise rules. +partitionPoints :: (Fractional r, Ord r) + => Cell r -> [Point 2 r :+ p] -> Quadrants [Point 2 r :+ p] +partitionPoints c = foldMap (\p -> let q = quadrantOf (p^.core) c in mempty&ix q %~ (p:)) + +-- | Computes the quadrant of the cell corresponding to the current +-- point. Note that we decide the quadrant solely based on the +-- midpoint. If the query point lies outside the cell, it is still +-- assigned a quadrant. +-- +-- - The northEast quadrants includes its bottom and left side +-- - The southEast quadrant includes its left side +-- - The northWest quadrant includes its bottom side +-- - The southWest quadrants does not include any of its sides. +-- +-- +-- >>> quadrantOf (Point2 9 9) (Cell 4 origin) +-- NorthEast +-- >>> quadrantOf (Point2 8 9) (Cell 4 origin) +-- NorthEast +-- >>> quadrantOf (Point2 8 8) (Cell 4 origin) +-- NorthEast +-- >>> quadrantOf (Point2 8 7) (Cell 4 origin) +-- SouthEast +-- >>> quadrantOf (Point2 4 7) (Cell 4 origin) +-- SouthWest +-- >>> quadrantOf (Point2 4 10) (Cell 4 origin) +-- NorthWest +-- >>> quadrantOf (Point2 4 40) (Cell 4 origin) +-- NorthEast +-- >>> quadrantOf (Point2 4 40) (Cell 4 origin) +-- NorthWest +quadrantOf :: forall r. (Fractional r, Ord r) + => Point 2 r -> Cell r -> InterCardinalDirection +quadrantOf q c = let m = midPoint c + in case (q^.xCoord < m^.xCoord, q^.yCoord < m^.yCoord) of + (False,False) -> NorthEast + (False,True) -> SouthEast + (True,False) -> NorthWest + (True,True) -> SouthWest + + + +-- | Given two cells c and me, compute on which side of `me` the cell +-- `c` is. +-- +-- pre: c and me are non-overlapping +relationTo :: (Fractional r, Ord r) + => (p :+ Cell r) -> Cell r -> Sides (Maybe (p :+ Cell r)) +c `relationTo` me = f <$> Sides b l t r <*> cellSides me + where + Sides t r b l = cellSides (c^.extra) + f e e' | e `intersects` e' = Just c + | otherwise = Nothing diff --git a/src/Data/Geometry/QuadTree/Quadrants.hs b/src/Data/Geometry/QuadTree/Quadrants.hs new file mode 100644 --- /dev/null +++ b/src/Data/Geometry/QuadTree/Quadrants.hs @@ -0,0 +1,23 @@ +-------------------------------------------------------------------------------- +-- | +-- 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 + ) where + +import Data.Geometry.Box.Corners + +-------------------------------------------------------------------------------- + +type Quadrants = Corners + +pattern Quadrants :: a -> a -> a -> a -> Corners a +pattern Quadrants a b c d = Corners a b c d +{-# COMPLETE Quadrants #-} + +-------------------------------------------------------------------------------- diff --git a/src/Data/Geometry/QuadTree/Split.hs b/src/Data/Geometry/QuadTree/Split.hs new file mode 100644 --- /dev/null +++ b/src/Data/Geometry/QuadTree/Split.hs @@ -0,0 +1,40 @@ +{-# 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,(^.)) +import Data.Geometry.QuadTree.Cell +import Data.Geometry.QuadTree.Quadrants + +-------------------------------------------------------------------------------- + +-- | Data Type to Decide if we should continue splitting the current cell +data Split i v p = No !p | Yes !v (Quadrants i) deriving (Show,Eq,Ord) +makePrisms ''Split + +-- | A splitter is a function that determines weather or not we should the given cell +-- corresponding to the given input (i). +type Splitter r i v p = Cell r -> i -> Split i v p + +-- | Transformer that limits the depth of a splitter +type Limiter r i v p = Splitter r i v p + -> Splitter r i v (Either i p) + +-- | 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) + -- 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 + -- allowed to split further (No (Left p))" diff --git a/src/Data/Geometry/QuadTree/Tree.hs b/src/Data/Geometry/QuadTree/Tree.hs new file mode 100644 --- /dev/null +++ b/src/Data/Geometry/QuadTree/Tree.hs @@ -0,0 +1,123 @@ +{-# 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 + + +import Control.Lens (makePrisms) +import Data.Bifoldable +import Data.Bifunctor +import Data.Bitraversable +import Data.Ext +import qualified Data.Foldable as F +import Data.Functor.Apply +import Data.Geometry.Point +import Data.Geometry.QuadTree.Cell +import Data.Geometry.QuadTree.Quadrants +import Data.Geometry.QuadTree.Split +import Data.List.NonEmpty (NonEmpty(..)) +import qualified Data.List.NonEmpty as NonEmpty +import Data.Semigroup.Foldable.Class +import Data.Semigroup.Traversable.Class +import qualified Data.Tree as RoseTree +import Data.Tree.Util (TreeNode(..)) + +-------------------------------------------------------------------------------- + +-- | Our cells use Rational numbers as their numeric type +-- type CellR = Cell (RealNumber 10) + +-- | The Actual Tree type representing a quadTree +data Tree v p = Leaf !p + | Node !v (Quadrants (Tree v p)) -- quadrants are stored lazily on purpose + deriving (Show,Eq) +makePrisms ''Tree + +instance Bifunctor Tree where + bimap = bimapDefault + +instance Bifoldable Tree where + bifoldMap = bifoldMapDefault + +instance Bitraversable Tree where + bitraverse f g = \case + Leaf p -> Leaf <$> g p + Node v qs -> Node <$> f v <*> traverse (bitraverse f g) qs + +instance Bifoldable1 Tree +instance Bitraversable1 Tree where + bitraverse1 f g = \case + Leaf p -> Leaf <$> g p + Node v qs -> Node <$> f v <.> traverse1 (bitraverse1 f g) qs + +-- | Fold on the Tree type. +foldTree :: (p -> b) -> (v -> Quadrants b -> b) -> Tree v p -> b +foldTree f g = go + where + go = \case + Leaf p -> f p + Node v qs -> g v (go <$> qs) + +-- | Produce a list of all leaves of a quad tree +leaves :: Tree v p -> NonEmpty p +leaves = NonEmpty.fromList . bifoldMap (const []) (:[]) + +-- | Converts into a RoseTree +toRoseTree :: Tree v p -> RoseTree.Tree (TreeNode v p) +toRoseTree = foldTree (\p -> RoseTree.Node (LeafNode p) []) + (\v qs -> RoseTree.Node (InternalNode v) (F.toList qs)) + +-- | Computes the height of the quadtree +height :: Tree v p -> Integer +height = foldTree (const 1) (\_ -> (1 +) . maximum) + + +-------------------------------------------------------------------------------- + +-------------------------------------------------------------------------------- +-- * Functions operating on the QuadTree (in temrs of the 'Tree' type) + +-- | Builds a QuadTree +build :: Fractional r + => Splitter r pts v p -> Cell r -> pts -> Tree v p +build shouldSplit = build' + where + build' cc pts = case shouldSplit cc pts of + No p -> Leaf p + Yes v qs -> Node v $ build' <$> splitCell cc <*> qs + +-- | Annotate the tree with its corresponing cells +withCells :: Fractional r => Cell r -> Tree v p -> Tree (v :+ Cell r) (p :+ Cell r) +withCells c0 = \case + Leaf p -> Leaf (p :+ c0) + Node v qs -> Node (v :+ c0) (withCells <$> splitCell c0 <*> qs) + + +-------------------------------------------------------------------------------- + + +-- | Build a QuadtTree from a set of points. +-- +-- pre: the points lie inside the initial given cell. +-- +-- running time: \(O(nh)\), where \(n\) is the number of points and +-- \(h\) is the height of the resulting quadTree. +fromPoints :: (Fractional r, Ord r) + => Cell r -> [Point 2 r :+ p] + -> Tree () (Maybe (Point 2 r :+ p)) +fromPoints = build fromPointsF + +-- | The function that can be used to build a quadTree 'fromPoints' +fromPointsF :: (Fractional r, Ord r) + => Splitter r [Point 2 r :+ p] () (Maybe (Point 2 r :+ p)) +fromPointsF c = \case + [] -> No Nothing + [p] -> No (Just p) + pts -> Yes () $ partitionPoints c pts + -- (\cell -> filter (`inCell` cell) pts) <$> splitCell c 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,8 +1,14 @@ {-# 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) -import Data.BinaryTree (Measured(..)) import Data.Ext import qualified Data.Foldable as F import Data.Geometry.Point @@ -11,10 +17,8 @@ import Data.Geometry.Vector import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.List.NonEmpty as NonEmpty -import Data.Proxy +import Data.Measured.Class import Data.Range -import Data.Semigroup.Foldable -import Data.Vector.Fixed.Cont (Peano, PeanoNum(..)) import GHC.TypeLits import Prelude hiding (last,init,head) @@ -110,7 +114,7 @@ , 1 <= d -- this one is kind of silly ) => NonEmpty (Point d r :+ p) -> RT 2 d v p r createRangeTree2 = RangeTree . GRT.createTree - . fmap (\p -> p^.core.coord (Proxy :: Proxy 2) :+ Leaf [p]) + . fmap (\p -> p^.core.coord @2 :+ Leaf [p]) -------------------------------------------------------------------------------- -- * Querying @@ -127,11 +131,11 @@ instance (1 <= d, Arity d) => Query 1 d where search' qr = map unAssoc . GRT.search' r . _unRangeTree where - r = qr^.element (Proxy :: Proxy 0) + r = qr^.element @0 instance ( 1 <= d, i <= d, Query (i-1) d, Arity d , i ~ 2 ) => Query 2 d where search' qr = concatMap (maybe [] (search' qr) . unAssoc) . GRT.search' r . _unRangeTree where - r = qr^.element (Proxy :: Proxy (i-1)) + r = qr^.element @(i-1) 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,17 +1,24 @@ +-------------------------------------------------------------------------------- +-- | +-- 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(..)) import qualified Data.List.NonEmpty as NonEmpty import Data.Range +import Data.Measured.Class +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,6 +1,13 @@ +-------------------------------------------------------------------------------- +-- | +-- 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.BinaryTree(Measured(..)) +import Data.Measured.Class import Data.Functor.Product(Product(..)) import Data.Functor.Classes @@ -45,11 +52,11 @@ instance (LabeledMeasure l, LabeledMeasure r) => LabeledMeasure (l :*: r) where labeledMeasure xs = Pair (labeledMeasure xs) (labeledMeasure xs) -instance (Semigroup (l a), Semigroup (r a)) => Semigroup ((l :*: r) a) where - (Pair l r) <> (Pair l' r') = Pair (l <> l') (r <> r') +-- instance (Semigroup (l a), Semigroup (r a)) => Semigroup ((l :*: r) a) where +-- (Pair l r) <> (Pair l' r') = Pair (l <> l') (r <> r') -instance (Monoid (l a), Monoid (r a)) => Monoid ((l :*: r) a) where - mempty = Pair mempty mempty +-- instance (Monoid (l a), Monoid (r a)) => Monoid ((l :*: r) a) where +-- mempty = Pair mempty mempty 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 @@ -34,6 +34,8 @@ import qualified Data.List as List import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as NonEmpty +import Data.Measured.Class +import Data.Measured.Size import GHC.Generics (Generic) -------------------------------------------------------------------------------- @@ -73,7 +75,7 @@ -- AtomicRange -> OpenRange MinInfinity MaxInfinity -data BuildLeaf a = LeafSingleton a | LeafRange a a deriving (Show,Eq) +data BuildLeaf a = LeafSingleton !a | LeafRange !a !a deriving (Show,Eq) -- | Given a sorted list of endpoints, without duplicates, construct a segment tree -- @@ -118,7 +120,7 @@ -> NonEmpty (Interval p r) -> SegmentTree v r fromIntervals f is = foldr (insert . f) (createTree pts mempty) is where - endPoints (toRange -> Range' a b) = [a,b] + endPoints (asRange -> Range' a b) = [a,b] pts = nub' . NonEmpty.sort . NonEmpty.fromList . concatMap endPoints $ is nub' = fmap NonEmpty.head . NonEmpty.group1 @@ -186,8 +188,8 @@ => i -> SegmentTree v r -> SegmentTree v r insert i (SegmentTree t) = SegmentTree $ insertRoot t where - ri@(Range a b) = toRange i - insertRoot t' = maybe t' (flip insert' t') $ getRange t' + ri@(Range a b) = asRange i + insertRoot t' = maybe t' (`insert'` t') $ getRange t' insert' inR lf@(Leaf nd@(LeafData rr _)) | coversAtomic ri inR rr = Leaf $ nd&leafAssoc %~ insertAssoc i @@ -209,7 +211,7 @@ => i -> SegmentTree v r -> SegmentTree v r delete i (SegmentTree t) = SegmentTree $ delete' t where - (Range _ b) = toRange i + (Range _ b) = asRange i delete' (Leaf ld) = Leaf $ ld&leafAssoc %~ deleteAssoc i delete' (Node l nd@(_splitPoint -> m) r) @@ -254,7 +256,7 @@ instance IntervalLike a => IntervalLike (I a) where - toRange = toRange . _unI + asRange = asRange . _unI fromIntervals' :: (Eq p, Ord r) 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) @@ -19,11 +26,13 @@ -------------------------------------------------------------------------------- +-- | Orthogonal directions data Orthogonal = Horizontal | Vertical deriving (Show,Eq,Read) - +-- | An strip between two parallel lines. The lines can be either +-- horizontal or vertical. newtype Slab (o :: Orthogonal) a r = Slab { _unSlab :: Interval a r } deriving (Show,Eq) makeLenses ''Slab @@ -50,66 +59,73 @@ bimap f g (Slab i) = Slab $ bimap f g i -type instance IntersectionOf (Slab o a r) (Slab o a r) = - [NoIntersection, Slab o a r] -type instance IntersectionOf (Slab Horizontal a r) (Slab Vertical a r) = - '[Rectangle (a,a) r] +type instance IntersectionOf (Slab o a r) (Slab o b r) = + [NoIntersection, Slab o (Either a b) r] +type instance IntersectionOf (Slab Horizontal a r) (Slab Vertical b r) = + '[Rectangle (a,b) r] -instance Ord r => (Slab o a r) `IsIntersectableWith` (Slab o a r) where +instance Ord r => Slab o a r `HasIntersectionWith` Slab o b r + +instance Ord r => Slab o a r `IsIntersectableWith` Slab o b 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 (Either a b) r)) :& RNil -instance (Slab Horizontal a r) `IsIntersectableWith` (Slab Vertical a r) where +instance Slab Horizontal a r `HasIntersectionWith` Slab Vertical b r where + _ `intersects` _ = True + +instance Slab Horizontal a r `IsIntersectableWith` Slab Vertical b r where nonEmptyIntersection _ _ _ = True (Slab h) `intersect` (Slab v) = coRec $ box low high where - low = Point2 (v^.start.core) (h^.start.core) :+ (v^.start.extra, h^.start.extra) - high = Point2 (v^.end.core) (h^.end.core) :+ (v^.end.extra, h^.end.extra) + low = Point2 (v^.start.core) (h^.start.core) :+ (h^.start.extra, v^.start.extra) + high = Point2 (v^.end.core) (h^.end.core) :+ (h^.end.extra, v^.end.extra) class HasBoundingLines (o :: Orthogonal) where -- | The two bounding lines of the slab, first the lower one, then the higher one: - -- boundingLines :: Num r => Slab o a r -> (Line 2 r :+ a, Line 2 r :+ a) - + -- | Test if a point lies inside a slab. inSlab :: Ord r => Point 2 r -> Slab o a r -> Bool instance HasBoundingLines Horizontal where boundingLines (Slab i) = (i^.start, i^.end)&both.core %~ horizontalLine - p `inSlab` (Slab i) = (p^.yCoord) `inInterval` i + p `inSlab` (Slab i) = (p^.yCoord) `intersectsInterval` i instance HasBoundingLines Vertical where boundingLines (Slab i) = (i^.start, i^.end)&both.core %~ verticalLine - p `inSlab` (Slab i) = (p^.xCoord) `inInterval` i + p `inSlab` (Slab i) = (p^.xCoord) `intersectsInterval` i type instance IntersectionOf (Line 2 r) (Slab o a r) = [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 `HasIntersectionWith` Slab o a r + +instance (Fractional r, Ord r, HasBoundingLines o) => + 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 +141,20 @@ [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 `HasIntersectionWith` Slab o a r +instance (Fractional r, Ord r, HasBoundingLines o) => + 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 +165,15 @@ [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 `HasIntersectionWith` Slab o a r + +instance (Fractional r, Ord r, HasBoundingLines o) => + 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,23 @@ -- SubLine; a part of a line -- -------------------------------------------------------------------------------- -module Data.Geometry.SubLine where +module Data.Geometry.SubLine + ( SubLine(..) + , line + , subRange + , fixEndPoints + , dropExtra + , onSubLine + , onSubLineUB + , onSubLine2 + , onSubLine2UB + , reorient + , getEndPointsUnBounded + , fromLine + , _unBounded + , toUnbounded + , fromUnbounded + ) where import Control.Lens import Data.Bifunctor @@ -27,8 +42,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 +49,16 @@ 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 @@ -52,12 +73,13 @@ => Arbitrary (SubLine d p s r) where arbitrary = SubLine <$> arbitrary <*> arbitrary + -- | Annotate the subRange with the actual ending points fixEndPoints :: (Num r, Arity d) => SubLine d p r r -> SubLine d (Point d r :+ p) r r 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,16 +87,8 @@ dropExtra :: SubLine d p s r -> SubLine d () s r dropExtra = over subRange (first (const ())) -_unBounded :: Prism' (SubLine d p (UnBounded r) r) (SubLine d p r r) -_unBounded = prism' toUnbounded fromUnbounded --- | Transform into an subline with a potentially unbounded interval -toUnbounded :: SubLine d p r r -> SubLine d p (UnBounded r) r -toUnbounded = over subRange (fmap Val) --- | Try to make a potentially unbounded subline into a bounded one. -fromUnbounded :: SubLine d p (UnBounded r) r -> Maybe (SubLine d p r r) -fromUnbounded (SubLine l i) = SubLine l <$> mapM unBoundedToMaybe i -- | 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 @@ -82,20 +96,13 @@ => Point d r -> SubLine d p r r -> Bool onSubLine p (SubLine l r) = case toOffset p l of Nothing -> False - Just x -> x `inInterval` r + Just x -> x `intersectsInterval` 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 -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 -- | 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 -p `onSubLine2` sl = d `inInterval` r +p `onSubLine2` sl = d `intersectsInterval` r where -- get the endpoints (a,b) of the subline SubLine _ (Interval s e) = fixEndPoints sl @@ -106,72 +113,84 @@ r = Interval (s&unEndPoint.core .~ 0) (e&unEndPoint.core .~ squaredEuclideanDist b a) --- | 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 -onSubLine2UB :: (Ord r, Fractional r) - => Point 2 r -> SubLine 2 p (UnBounded r) r -> Bool -p `onSubLine2UB` sl = p `onSubLineUB` sl +type instance IntersectionOf (SubLine 2 p s r) (SubLine 2 q s r) = + [ NoIntersection, Point 2 r, SubLine 2 (Either p q) s r] -type instance IntersectionOf (SubLine 2 p s r) (SubLine 2 q s r) = [ NoIntersection - , Point 2 r - , SubLine 2 p s r - ] + instance (Ord r, Fractional r) => - (SubLine 2 p r r) `IsIntersectableWith` (SubLine 2 p r r) where + SubLine 2 p r r `HasIntersectionWith` SubLine 2 q r r + +-- -- | Given two sublines that supposedly have the same line (but +-- -- possibly represented differently), test if they intersect. +-- intersectsSLRange :: SubLine 2 p r r -> SubLine 2 q r r -> Bool +-- intersectsSLRange = undefined + + +-- -- | Given two sublines of the s ame line (but possibly represented differently) +-- -- align the first one to the second one. +-- -- +-- -- pre: the +-- alignTo :: (Eq r, Num r, Arity d) => SubLine d p r r -> SubLine d q r r -> SubLine d p r r +-- sl `alignTo` (SubLine l@(Line p v) i2) = SubLine l i' +-- where +-- SubLine (Line q u) i = reorient sl v + + +-- i' = undefined + + + + + + + + + +-- | Given a subline with vector u, and a vector v that is parallel to +-- u (but possibly pointing in the exact opposite direction). Make the +-- subline point in direction v as well (but keep the magnitude of the +-- original vector.) +-- +-- pre: the lines are parallel. +reorient :: (Eq r,Num r, Arity d) => SubLine d p r r -> Vector d r -> SubLine d p r r +reorient sl@(SubLine (Line p u) i) v + | sameDirection u v = sl + | otherwise = SubLine (Line p ((-1) *^ u)) (flipInterval i) + + + + + +{- HLINT ignore "Redundant bracket" -} +instance (Ord r, Fractional r) => + SubLine 2 p r r `IsIntersectableWith` SubLine 2 q 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 where s' = (fixEndPoints sm)^.subRange - s'' = bimap (^.extra) id + s'' = asProperInterval . first (^.extra) $ s'&start.core .~ toOffset' (s'^.start.extra.core) l &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 - 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 - then coRec p - else coRec NoIntersection) - :& (H $ \_ -> match (r `intersect` s'') $ - (H $ \NoIntersection -> coRec NoIntersection) - :& (H $ \i -> coRec $ SubLine l i) - :& RNil - ) - :& RNil - where - -- convert to points, then convert back to 'r' values (but now w.r.t. l) - s' = getEndPointsUnBounded sm - s'' = second (fmap f) s' - f = flip toOffset' l --- | Get the endpoints of an unbounded interval -getEndPointsUnBounded :: (Num r, Arity d) => SubLine d p (UnBounded r) r - -> Interval p (UnBounded (Point d r)) -getEndPointsUnBounded sl = second (fmap f) $ sl^.subRange - where - f = flip pointAt (sl^.line) -fromLine :: Arity d => Line d r -> SubLine d () (UnBounded r) r -fromLine l = SubLine l (ClosedInterval (ext MinInfinity) (ext MaxInfinity)) - -- testL :: SubLine 2 () (UnBounded Rational) -- testL = SubLine (horizontalLine 0) (Interval (Closed (only 0)) (Open $ only 10)) @@ -185,6 +204,93 @@ -- 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 :+ ()))) + + + + +-------------------------------------------------------------------------------- +-- * Anything that deals with Unbounded intervals + +-- | 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)) + + +-- | 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 + +-- | Transform into an subline with a potentially unbounded interval +toUnbounded :: SubLine d p r r -> SubLine d p (UnBounded r) r +toUnbounded = over subRange (fmap Val) + +-- | Try to make a potentially unbounded subline into a bounded one. +fromUnbounded :: SubLine d p (UnBounded r) r -> Maybe (SubLine d p r r) +fromUnbounded (SubLine l i) = SubLine l <$> mapM unBoundedToMaybe i + + +-- | Get the endpoints of an unbounded interval +getEndPointsUnBounded :: (Num r, Arity d) => SubLine d p (UnBounded r) r + -> Interval p (UnBounded (Point d r)) +getEndPointsUnBounded sl = second (fmap f) $ sl^.subRange + where + f = flip pointAt (sl^.line) + + + + + +-- | 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 +onSubLineUB :: (Ord r, Fractional r) + => Point 2 r -> SubLine 2 p (UnBounded r) r -> Bool +p `onSubLineUB` (SubLine l r) = + p `onLine2` l && + Val (toOffset' p l) `intersectsInterval` 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) `intersectsInterval` 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 +onSubLine2UB :: (Ord r, Fractional r) + => Point 2 r -> SubLine 2 p (UnBounded r) r -> Bool +p `onSubLine2UB` sl = p `onSubLineUB` sl + + + + + + + +-------- + +instance (Ord r, Fractional r) => + SubLine 2 p (UnBounded r) r `HasIntersectionWith` SubLine 2 q (UnBounded r) r + +instance (Ord r, Fractional r) => + SubLine 2 p (UnBounded r) r `IsIntersectableWith` SubLine 2 q (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 inSubLineIntervalUB p sl && inSubLineIntervalUB p sm + then coRec p + else coRec NoIntersection) + :& H (\_ -> match (r `intersect` s'') $ + H coRec -- NoIntersection + :& H (coRec . SubLine l) + :& RNil + ) + :& RNil + where + -- convert to points, then convert back to 'r' values (but now w.r.t. l) + s' = getEndPointsUnBounded sm + s'' = second (fmap f) s' + f = flip toOffset' l 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,173 +1,59 @@ -{-# LANGUAGE UndecidableInstances #-} -module Data.Geometry.Transformation where - -import Control.Lens (lens,Lens',set) -import Unsafe.Coerce(unsafeCoerce) -import Data.Geometry.Point -import Data.Geometry.Properties -import Data.Geometry.Vector -import qualified Data.Geometry.Vector as V -import Data.Proxy -import qualified Data.Vector.Fixed as FV -import GHC.TypeLits -import Linear.Matrix ((!*),(!*!)) -import qualified Linear.Matrix as Lin - -------------------------------------------------------------------------------- --- * Matrices - --- | 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) -deriving instance (Eq r, Arity n, Arity m) => Eq (Matrix n m r) -deriving instance (Ord r, Arity n, Arity m) => Ord (Matrix n m r) -deriving instance (Arity n, Arity m) => Functor (Matrix n m) - -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 - -mult :: (Arity m, Arity n, Num r) => Matrix n m r -> Vector m r -> Vector n r -(Matrix m) `mult` v = m !* v - - -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 - -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 - -instance Fractional r => Invertible 4 r where - inverse' (Matrix m) = Matrix . unsafeCoerce . Lin.inv44 . unsafeCoerce $ m - +-- | +-- Module : Data.Geometry.Transformation +-- Copyright : (C) Frank Staals +-- License : see the LICENSE file +-- Maintainer : Frank Staals -------------------------------------------------------------------------------- --- * Transformations - --- | A type representing a Transformation for d dimensional objects -newtype Transformation d r = Transformation { _transformationMatrix :: Matrix (d + 1) (d + 1) r } - -transformationMatrix :: Lens' (Transformation d r) (Matrix (d + 1) (d + 1) r) -transformationMatrix = lens _transformationMatrix (const Transformation) - -deriving instance (Show r, Arity (d + 1)) => Show (Transformation d r) -deriving instance (Eq r, Arity (d + 1)) => Eq (Transformation d r) -deriving instance (Ord r, Arity (d + 1)) => Ord (Transformation d r) -deriving instance Arity (d + 1) => Functor (Transformation d) +module Data.Geometry.Transformation + ( Transformation(Transformation) + , transformationMatrix + , (|.|), identity, inverseOf -type instance NumType (Transformation d r) = r + , IsTransformable(..) + , transformAllBy + , transformPointFunctor + , translation, scaling, uniformScaling --- | Compose transformations (right to left) -(|.|) :: (Num r, Arity (d + 1)) => Transformation d r -> Transformation d r -> Transformation d r -(Transformation f) |.| (Transformation g) = Transformation $ f `multM` g + , translateBy, scaleBy, scaleUniformlyBy + , rotateTo --- if it exists? + , skewX, rotation, reflection, reflectionV, reflectionH --- | 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]]} -inverseOf :: (Fractional r, Invertible (d + 1) r) - => Transformation d r -> Transformation d r -inverseOf = Transformation . inverse' . _transformationMatrix + , fitToBox + , fitToBoxTransform + ) where +import Control.Lens +import Data.Ext +import Data.Geometry.Box.Internal (Rectangle, IsBoxable) +import qualified Data.Geometry.Box.Internal as Box +import Data.Geometry.Properties +import Data.Geometry.Point +import Data.Geometry.Transformation.Internal +import Data.Geometry.Vector -------------------------------------------------------------------------------- --- * Transformable geometry objects --- | A class representing types that can be transformed using a transformation -class IsTransformable g where - transformBy :: Transformation (Dimension g) (NumType g) -> g -> g - -transformAllBy :: (Functor c, IsTransformable g) - => Transformation (Dimension g) (NumType g) -> c g -> c g -transformAllBy t = fmap (transformBy t) - - -transformPointFunctor :: ( PointFunctor g, Fractional r, d ~ Dimension (g r) - , Arity d, Arity (d + 1) - ) => Transformation d r -> g r -> g r -transformPointFunctor t = pmap (transformBy t) - -instance (Fractional r, Arity d, Arity (d + 1)) - => IsTransformable (Point d r) where - transformBy t = Point . transformBy t . toVec - -instance (Fractional r, Arity d, Arity (d + 1)) - => IsTransformable (Vector d r) where - transformBy (Transformation m) v = f $ m `mult` snoc v 1 - where - f u = (/ V.last u) <$> V.init u - - --------------------------------------------------------------------------------- --- * Common transformations - -translation :: (Num r, Arity d, Arity (d + 1)) - => Vector d r -> Transformation d r -translation v = Transformation . Matrix $ V.imap transRow (snoc v 1) - - -scaling :: (Num r, Arity d, Arity (d + 1)) - => Vector d r -> Transformation d r -scaling v = Transformation . Matrix $ V.imap mkRow (snoc v 1) - -uniformScaling :: (Num r, Arity d, Arity (d + 1)) => r -> Transformation d r -uniformScaling = scaling . pure - --------------------------------------------------------------------------------- --- * Functions that execute transformations - -translateBy :: ( IsTransformable g, Num (NumType g) - , Arity (Dimension g), Arity (Dimension g + 1) - ) => Vector (Dimension g) (NumType g) -> g -> g -translateBy = transformBy . translation - -scaleBy :: ( IsTransformable g, Num (NumType g) - , Arity (Dimension g), Arity (Dimension g + 1) - ) => Vector (Dimension g) (NumType g) -> g -> g -scaleBy = transformBy . scaling - - -scaleUniformlyBy :: ( IsTransformable g, Num (NumType g) - , Arity (Dimension g), Arity (Dimension g + 1) - ) => NumType g -> g -> g -scaleUniformlyBy = transformBy . uniformScaling - - --------------------------------------------------------------------------------- --- * Helper functions to easily create matrices - --- | Creates a row with zeroes everywhere, except at position i, where the --- value is the supplied value. -mkRow :: forall d r. (Arity d, Num r) => Int -> r -> Vector d r -mkRow i x = set (FV.element i) x zero - --- | Row in a translation matrix --- transRow :: forall n r. ( Arity n, Arity (n- 1), ((n - 1) + 1) ~ n --- , Num r) => Int -> r -> Vector n r --- transRow i x = set (V.element (Proxy :: Proxy (n-1))) x $ mkRow i 1 - -transRow :: forall n r. (Arity n, Arity (n + 1), Num r) - => Int -> r -> Vector (n + 1) r -transRow i x = set (V.element (Proxy :: Proxy n)) x $ mkRow i 1 - --------------------------------------------------------------------------------- --- * 3D Rotations +-- | Given a rectangle r and a geometry g with its boundingbox, +-- transform the g to fit r. +fitToBox :: forall g r q. + ( IsTransformable g, IsBoxable g, NumType g ~ r, Dimension g ~ 2 + , Ord r, Fractional r + ) => Rectangle q r -> g -> g +fitToBox r g = transformBy (fitToBoxTransform r g) g --- | Given three new unit-length basis vectors (u,v,w) that map to (x,y,z), --- construct the appropriate rotation that does this. --- --- -rotateTo :: Num r => Vector 3 (Vector 3 r) -> Transformation 3 r -rotateTo (Vector3 u v w) = Transformation . Matrix $ Vector4 (snoc u 0) - (snoc v 0) - (snoc w 0) - (Vector4 0 0 0 1) +-- | Given a rectangle r and a geometry g with its boundingbox, +-- compute a transformation can fit g to r. +fitToBoxTransform :: forall g r q. ( IsTransformable g, IsBoxable g + , NumType g ~ r, Dimension g ~ 2 + , Ord r, Fractional r + ) => Rectangle q r -> g -> Transformation 2 r +fitToBoxTransform r g = translation v2 |.| uniformScaling lam |.| translation v1 + where + b = Box.boundingBox g + v1 :: Vector 2 r + v1 = negate <$> b^.to Box.minPoint.core.vector + v2 = r^.to Box.minPoint.core.vector + lam = minimum $ (/) <$> Box.size r <*> Box.size b diff --git a/src/Data/Geometry/Transformation/Internal.hs b/src/Data/Geometry/Transformation/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Data/Geometry/Transformation/Internal.hs @@ -0,0 +1,224 @@ +{-# LANGUAGE UndecidableInstances #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Data.Geometry.Transformation.Internal +-- Copyright : (C) Frank Staals +-- License : see the LICENSE file +-- Maintainer : Frank Staals +-------------------------------------------------------------------------------- +module Data.Geometry.Transformation.Internal where + +import Control.Lens (iso,set,Iso,imap) +import Data.Geometry.Matrix +import Data.Geometry.Matrix.Internal (mkRow) +import Data.Geometry.Point +import Data.Geometry.Properties +import Data.Geometry.Vector +import qualified Data.Geometry.Vector as V +import GHC.TypeLits + +{- $setup +>>> import Data.Geometry.LineSegment +>>> import Data.Ext +-} + +-------------------------------------------------------------------------------- +-- * Transformations + +-- | 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 + +deriving instance (Show r, Arity (d + 1)) => Show (Transformation d r) +deriving instance (Eq r, Arity (d + 1)) => Eq (Transformation d r) +deriving instance (Ord r, Arity (d + 1)) => Ord (Transformation d r) +deriving instance Arity (d + 1) => Functor (Transformation d) +deriving instance Arity (d + 1) => Foldable (Transformation d) +deriving instance Arity (d + 1) => Traversable (Transformation d) + +type instance NumType (Transformation d r) = r + +-- | Compose transformations (right to left) +(|.|) :: (Num r, Arity (d + 1)) => Transformation d r -> Transformation d r -> Transformation d r +(Transformation f) |.| (Transformation g) = Transformation $ f `multM` g + +-- | Identity transformation; i.e. the transformation which does not change anything. +identity :: (Num r, Arity (d + 1)) => Transformation d r +identity = Transformation identityMatrix + +instance (Num r, Arity (d+1)) => Semigroup (Transformation d r) where + (<>) = (|.|) +instance (Num r, Arity (d+1)) => Monoid (Transformation d r) where + mempty = identity + + +-- if it exists? + +-- | 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))} +inverseOf :: (Fractional r, Invertible (d + 1) r) + => Transformation d r -> Transformation d r +inverseOf = Transformation . inverse' . _transformationMatrix + +-------------------------------------------------------------------------------- +-- * Transformable geometry objects + +-- | A class representing types that can be transformed using a transformation +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 +transformPointFunctor t = pmap (transformBy t) + +instance (Fractional r, Arity d, Arity (d + 1)) + => IsTransformable (Point d r) where + transformBy t = Point . transformBy t . toVec + +instance (Fractional r, Arity d, Arity (d + 1)) + => IsTransformable (Vector d r) where + transformBy (Transformation m) v = f $ m `mult` snoc v 1 + where + f u = (/ V.last u) <$> V.init u + + +-------------------------------------------------------------------------------- +-- * 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 + + +-------------------------------------------------------------------------------- +-- * 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 +scaleUniformlyBy = transformBy . uniformScaling + + +-- | Row in a translation matrix +-- transRow :: forall n r. ( Arity n, Arity (n- 1), ((n - 1) + 1) ~ n +-- , Num r) => Int -> r -> Vector n r +-- transRow i x = set (V.element (Proxy :: Proxy (n-1))) x $ mkRow i 1 + +transRow :: forall n r. (Arity n, Arity (n + 1), Num r) + => Int -> r -> Vector (n + 1) r +transRow i x = set (V.element @n) x $ mkRow i 1 + +-------------------------------------------------------------------------------- +-- * 3D Rotations + +-- | Given three new unit-length basis vectors (u,v,w) that map to (x,y,z), +-- construct the appropriate rotation that does this. +-- +-- +rotateTo :: Num r => Vector 3 (Vector 3 r) -> Transformation 3 r +rotateTo (Vector3 u v w) = Transformation . Matrix $ Vector4 (snoc u 0) + (snoc v 0) + (snoc w 0) + (Vector4 0 0 0 1) + +-------------------------------------------------------------------------------- +-- * 2D Transformations + +-- | Skew transformation that keeps the y-coordinates fixed and shifts +-- the x coordinates. +skewX :: Num r => r -> Transformation 2 r +skewX lambda = Transformation . Matrix $ Vector3 (Vector3 1 lambda 0) + (Vector3 0 1 0) + (Vector3 0 0 1) + +-- | Create a matrix that corresponds to a rotation by 'a' radians counter-clockwise +-- around the origin. +rotation :: Floating r => r -> Transformation 2 r +rotation a = Transformation . Matrix $ Vector3 (Vector3 (cos a) (- sin a) 0) + (Vector3 (sin a) ( cos a) 0) + (Vector3 0 0 1) + +-- | Create a matrix that corresponds to a reflection in a line through the origin +-- which makes an angle of 'a' radians with the positive 'x'-asis, in counter-clockwise +-- orientation. +reflection :: Floating r => r -> Transformation 2 r +reflection a = rotation a |.| reflectionV |.| rotation (-a) + +-- | Vertical reflection +reflectionV :: Num r => Transformation 2 r +reflectionV = Transformation . Matrix $ Vector3 (Vector3 1 0 0) + (Vector3 0 (-1) 0) + (Vector3 0 0 1) + +-- | Horizontal reflection +reflectionH :: Num r => Transformation 2 r +reflectionH = Transformation . Matrix $ Vector3 (Vector3 (-1) 0 0) + (Vector3 0 1 0) + (Vector3 0 0 1) 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,47 +1,72 @@ {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE UndecidableInstances #-} +-- | Triangles in \(d\)-dimensional space. module Data.Geometry.Triangle where +import Control.DeepSeq (NFData) import Control.Lens -import Data.Bifunctor -import Data.Either (partitionEithers) +import Data.Bifoldable (Bifoldable (bifoldMap)) +import Data.Bifunctor (Bifunctor (first)) +import Data.Bitraversable +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.Vinyl -import Data.Vinyl.CoRec -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. -data Triangle d p r = Triangle (Point d r :+ p) - (Point d r :+ p) - (Point d r :+ p) +-- | A triangle in \(d\)-dimensional space. +data Triangle d p r = Triangle !(Point d r :+ p) + !(Point d r :+ p) + !(Point d r :+ p) + deriving (Generic) -deriving instance (Arity d, Show r, Show p) => Show (Triangle d p r) -deriving instance (Arity d, Read r, Read p) => Read (Triangle d p r) -deriving instance (Arity d, Eq r, Eq p) => Eq (Triangle d p r) +deriving instance (Arity d, Show r, Show p) => Show (Triangle d p r) +deriving instance (Arity d, Read r, Read p) => Read (Triangle d p r) +deriving instance (Arity d, Eq r, Eq p) => Eq (Triangle d p r) -instance Arity d => Functor (Triangle d p) where - fmap f (Triangle p q r) = let f' = first (fmap f) in Triangle (f' p) (f' q) (f' r) +instance (Arity d, NFData r, NFData p) => NFData (Triangle d p r) +instance Arity d => Bifunctor (Triangle d) where bimap = bimapDefault +instance Arity d => Bifoldable (Triangle d) where bifoldMap = bifoldMapDefault +instance Arity d => Bitraversable (Triangle d) where + bitraverse f g (Triangle p q r) = let tr = bitraverse (traverse g) f in + Triangle <$> tr p <*> tr q <*> tr r + +-- instance Arity d => Functor (Triangle d p) where +-- fmap f (Triangle p q r) = let f' = first (fmap f) in Triangle (f' p) (f' q) (f' r) + +instance Field1 (Triangle d p r) (Triangle d p r) (Point d r :+ p) (Point d r :+ p) where + _1 = lens (\(Triangle p _ _) -> p) (\(Triangle _ q r) p -> Triangle p q r) +instance Field2 (Triangle d p r) (Triangle d p r) (Point d r :+ p) (Point d r :+ p) where + _2 = lens (\(Triangle _ q _) -> q) (\(Triangle p _ r) q -> Triangle p q r) +instance Field3 (Triangle d p r) (Triangle d p r) (Point d r :+ p) (Point d r :+ p) where + _3 = lens (\(Triangle _ _ r) -> r) (\(Triangle p q _) r -> Triangle p q r) + 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) + instance PointFunctor (Triangle d p) where pmap f (Triangle p q r) = Triangle (p&core %~ f) (q&core %~ f) (r&core %~ f) @@ -54,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] @@ -78,9 +103,9 @@ 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) +inscribedDisk :: (Ord r, Fractional r) => Triangle 2 p r -> Maybe (Disk () r) inscribedDisk (Triangle p q r) = disk (p^.core) (q^.core) (r^.core) @@ -121,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]" @@ -142,7 +182,9 @@ 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 `HasIntersectionWith` Triangle 2 p r + +instance (Fractional r, Ord r) => Line 2 r `IsIntersectableWith` Triangle 2 p r where nonEmptyIntersection = defaultNonEmptyIntersection l `intersect` (Triangle p q r) = @@ -157,9 +199,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 @@ -167,14 +209,17 @@ 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 +instance (Fractional r, Ord r) => Line 3 r `HasIntersectionWith` Triangle 3 p r + +{- 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 @@ -187,13 +232,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 @@ -210,8 +255,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 #-} -------------------------------------------------------------------------------- -- | @@ -14,45 +14,60 @@ , module LV , C(..) , Affine(..) - , qdA, distanceA + , quadrance, qdA, distanceA , dot, norm, signorm , isScalarMultipleOf - , scalarMultiple + , scalarMultiple, sameDirection -- reexports , FV.replicate - , FV.imap , xComponent, yComponent, zComponent ) where -import Control.Applicative (liftA2) -import Control.Lens(Lens') -import qualified Data.Foldable as F +import Control.Applicative (liftA2) +import Control.Lens (Lens') +import Control.Monad.State +import qualified Data.Foldable as F import Data.Geometry.Properties import Data.Geometry.Vector.VectorFamily -import Data.Geometry.Vector.VectorFixed (C(..)) -import Data.Maybe -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) -import Linear.Vector as LV -import Test.QuickCheck +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 + random g0 = flip runState g0 $ FV.replicateM (state random) + -- | 'isScalarmultipleof u v' test if v is a scalar multiple of u. -- -- >>> Vector2 1 1 `isScalarMultipleOf` Vector2 10 10 -- True +-- >>> Vector3 1 1 2 `isScalarMultipleOf` Vector3 10 10 20 +-- True -- >>> Vector2 1 1 `isScalarMultipleOf` Vector2 10 1 -- False +-- >>> Vector2 1 1 `isScalarMultipleOf` Vector2 (-1) (-1) +-- True -- >>> Vector2 1 1 `isScalarMultipleOf` Vector2 11.1 11.1 -- True -- >>> Vector2 1 1 `isScalarMultipleOf` Vector2 11.1 11.2 @@ -63,11 +78,20 @@ -- True -- >>> Vector2 2 1 `isScalarMultipleOf` Vector2 4 0 -- False +-- >>> Vector3 2 1 0 `isScalarMultipleOf` Vector3 4 0 5 +-- False +-- >>> Vector3 0 0 0 `isScalarMultipleOf` Vector3 4 0 5 +-- True isScalarMultipleOf :: (Eq r, Fractional r, Arity d) => Vector d r -> Vector d r -> Bool -u `isScalarMultipleOf` v = isJust $ scalarMultiple u v +u `isScalarMultipleOf` v = let d = u `dot` v + num = quadrance u * quadrance v + 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 #-} +{-# SPECIALIZE + isScalarMultipleOf :: (Eq r, Fractional r) => Vector 3 r -> Vector 3 r -> Bool #-} -- | scalarMultiple u v computes the scalar labmda s.t. v = lambda * u (if it exists) scalarMultiple :: (Eq r, Fractional r, Arity d) @@ -129,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) +xComponent = element @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) +yComponent = element @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) +zComponent = element @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 @@ -1,5 +1,6 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE AllowAmbiguousTypes #-} -------------------------------------------------------------------------------- -- | -- Module : Data.Geometry.Vector.VectorFamily @@ -16,29 +17,29 @@ import Control.DeepSeq 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 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 Data.Geometry.Vector.VectorFixed (C (..)) +import Data.Hashable +import Data.Kind +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 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 Text.Read (Read (..), readListPrecDefault) -------------------------------------------------------------------------------- -- * d dimensional Vectors @@ -47,7 +48,7 @@ -- | Datatype representing d dimensional vectors. The default implementation is -- based n VectorFixed. However, for small vectors we automatically select a -- more efficient representation. -newtype Vector (d :: Nat) (r :: *) = MKVector { _unV :: VectorFamily (Peano d) r } +newtype Vector (d :: Nat) (r :: Type) = MKVector { _unV :: VectorFamily (Peano d) r } type instance V.Dim (Vector d) = Fam.FromPeano (Peano d) -- the above definition is a bit convoluted, but it allows us to make Vector an instance of @@ -55,13 +56,18 @@ 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) +-- type Arity d = (ImplicitArity (Peano d), KnownNat d) +class (ImplicitArity (Peano d), KnownNat d) => Arity d +instance (ImplicitArity (Peano d), KnownNat d) => Arity d + 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) @@ -69,6 +75,15 @@ deriving instance Arity d => Traversable (Vector d) deriving instance Arity d => Applicative (Vector d) + + +instance Arity d => FunctorWithIndex Int (Vector d) where + imap = V.imap +instance Arity d => FoldableWithIndex Int (Vector d) +instance Arity d => TraversableWithIndex Int (Vector d) where + itraverse = V.imapM + + deriving instance Arity d => Additive (Vector d) deriving instance Arity d => Metric (Vector d) instance Arity d => Affine (Vector d) where @@ -76,6 +91,8 @@ u .-. v = u ^-^ v p .+^ v = p ^+^ v +deriving instance (Arity d, Hashable r) => Hashable (Vector d r) + instance Arity d => Ixed (Vector d r) where ix = element' @@ -84,22 +101,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 @@ -110,64 +155,82 @@ -------------------------------------------------------------------------------- -- * 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) +head = view $ element @0 -------------------------------------------------------------------------------- -- * Indexing vectors -- | Lens into the i th element -element :: forall proxy i d r. (Arity d, KnownNat i, (i + 1) <= d) - => proxy i -> Lens' (Vector d r) r -element _ = singular . element' . fromInteger $ natVal (C :: C i) +element :: forall i d r. (Arity d, KnownNat i, (i + 1) <= d) + => Lens' (Vector d r) r +element = elementProxy (C @i) {-# INLINE element #-} +-- | Lens into the i th element +elementProxy :: forall proxy i d r. (Arity d, KnownNat i, (i + 1) <= d) + => proxy i -> Lens' (Vector d r) r +elementProxy _ = singular $ element' $ fromInteger . natVal $ C @i +{-# INLINE elementProxy #-} -- | 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 + -- | Add an element at the back of the vector snoc :: (Arity (d + 1), Arity d) => Vector d r -> r -> Vector (d + 1) r snoc v x = vectorFromListUnsafe . (++ [x]) $ F.toList v @@ -177,8 +240,9 @@ 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) +last = view $ element @d -- | Get a prefix of i elements of a vector prefix :: forall i d r. (Arity d, Arity i, i <= 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,15 +1,30 @@ {-# 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 import Control.Lens hiding (element) -import Data.Aeson(FromJSON(..),ToJSON(..)) +import Data.Aeson (FromJSON(..),ToJSON(..)) +import Data.Kind -- import Data.Aeson (ToJSON(..),FromJSON(..)) 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 @@ -19,6 +34,7 @@ import qualified Linear.V3 as L3 import qualified Linear.V4 as L4 import Linear.Vector +import Data.Hashable -------------------------------------------------------------------------------- -- * Natural number stuff @@ -52,11 +68,11 @@ -- | 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 :: *) = +newtype VectorFamily (d :: PeanoNum) (r :: Type) = VectorFamily { _unVF :: VectorFamilyF d r } -- | Mapping between the implementation type, and the actual implementation. -type family VectorFamilyF (d :: PeanoNum) :: * -> * where +type family VectorFamilyF (d :: PeanoNum) :: Type -> Type where VectorFamilyF Z = Const () VectorFamilyF One = Identity VectorFamilyF Two = L2.V2 @@ -77,7 +93,9 @@ unVF = lens _unVF (const VectorFamily) {-# INLINE unVF #-} -type ImplicitArity d = (ImplicitPeano d, V.Arity (FromPeano d)) +-- type ImplicitArity d = (ImplicitPeano d, V.Arity (FromPeano d)) +class (ImplicitPeano d, V.Arity (FromPeano d)) => ImplicitArity d +instance (ImplicitPeano d, V.Arity (FromPeano d)) => ImplicitArity d instance (Eq r, ImplicitArity d) => Eq (VectorFamily d r) where (VectorFamily u) == (VectorFamily v) = case (implicitPeano :: SingPeano d) of @@ -89,6 +107,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 @@ -188,6 +215,17 @@ (SS (SS (SS (SS (SS _))))) -> rnf v {-# INLINE rnf #-} + +instance (ImplicitArity d, Hashable r) => Hashable (VectorFamily d r) where + hashWithSalt = case (implicitPeano :: SingPeano d) of + SZ -> hashWithSalt + (SS SZ) -> hashWithSalt + (SS (SS SZ)) -> hashWithSalt + (SS (SS (SS SZ))) -> hashWithSalt + (SS (SS (SS (SS SZ)))) -> hashWithSalt + (SS (SS (SS (SS (SS _))))) -> hashWithSalt + + instance ImplicitArity d => Ixed (VectorFamily d r) where ix = element' @@ -202,13 +240,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 #-} @@ -273,14 +311,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,14 +1,23 @@ {-# 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 import Control.Lens hiding (element) import Data.Aeson import qualified Data.Foldable as F +import Data.Functor.Classes +import Data.Kind import Data.Proxy -import qualified Data.Vector.Fixed as V import Data.Vector.Fixed (Arity) +import qualified Data.Vector.Fixed as V import Data.Vector.Fixed.Boxed import GHC.Generics (Generic) import GHC.TypeLits @@ -28,8 +37,8 @@ -- | Datatype representing d dimensional vectors. Our implementation wraps the -- implementation provided by fixed-vector. -newtype Vector (d :: Nat) (r :: *) = Vector { _unV :: Vec d r } - deriving (Generic) +newtype Vector (d :: Nat) (r :: Type) = Vector { _unV :: Vec d r } + deriving (Generic) unV :: Lens' (Vector d r) (Vec d r) unV = lens _unV (const Vector) @@ -46,7 +55,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 +73,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 +139,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,213 @@ +{-# 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 + ) where + +import Algorithms.BinarySearch (binarySearchIn) +import Control.Lens hiding (contains, below) +import Data.Ext +import Data.Foldable (toList) +import Data.Function (on) +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.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 (ordAtX' x) + in r :+ foldr (runActionAt mid) ss (orderActs acts) + -- run deletions first + +-- | order by x coord +ordAtX' :: (Ord r, Fractional r) + => r -> LineSegment 2 p r :+ a -> LineSegment 2 p r :+ a -> Ordering +ordAtX' x = ordAtX x `on` view core + +-- | 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) + + +---------------------------------------------------------------------------------- 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 @@ -13,7 +11,8 @@ -- embedding. -- -------------------------------------------------------------------------------- -module Data.PlaneGraph( PlaneGraph(PlaneGraph), graph +module Data.PlaneGraph( -- $setup + PlaneGraph(PlaneGraph), graph , PlanarGraph , VertexData(VertexData), vData, location, vtxDataToExt , fromSimplePolygon, fromConnectedSegments @@ -33,7 +32,7 @@ , incidentEdges, incomingEdges, outgoingEdges , neighboursOf , nextIncidentEdge, prevIncidentEdge - + , nextIncidentEdgeFrom, prevIncidentEdgeFrom , leftFace, rightFace , nextEdge, prevEdge @@ -46,15 +45,93 @@ , vertexData, faceData, dartData, rawDartData , edgeSegment, edgeSegments - , rawFacePolygon, rawFaceBoundary - , rawFacePolygons + , faceBoundary, internalFacePolygon + , outerFacePolygon, outerFacePolygon' + , facePolygons, facePolygons' , VertexId(..), FaceId(..), Dart, World(..), VertexId', FaceId' - , withEdgeDistances , writePlaneGraph, readPlaneGraph ) where import Data.PlaneGraph.IO import Data.PlaneGraph.Core + + +-------------------------------------------------------------------------------- + +-- $setup +-- >>> import Data.Proxy +-- >>> import Data.PlaneGraph.AdjRep(Gr(Gr),Face(Face),Vtx(Vtx)) +-- >>> import Data.PlaneGraph.IO(fromAdjRep) +-- >>> import Data.PlanarGraph.Dart(Dart(..),Arc(..)) +-- >>> :{ +-- let dart i s = Dart (Arc i) (read s) +-- small :: Gr (Vtx Int String Int) (Face String) +-- small = Gr [ Vtx 0 (Point2 0 0) [ (2,"0->2") +-- , (1,"0->1") +-- , (3,"0->3") +-- ] 0 +-- , Vtx 1 (Point2 2 2) [ (0,"1->0") +-- , (2,"1->2") +-- , (3,"1->3") +-- ] 1 +-- , Vtx 2 (Point2 2 0) [ (0,"2->0") +-- , (1,"2->1") +-- ] 2 +-- , Vtx 3 (Point2 (-1) 4) [ (0,"3->0") +-- , (1,"3->1") +-- ] 3 +-- ] +-- [ Face (2,1) "OuterFace" +-- , Face (0,1) "A" +-- , Face (1,0) "B" +-- ] +-- smallG = fromAdjRep (Proxy :: Proxy ()) small +-- :} +-- +-- +-- This represents the following graph. Note that the graph is undirected, the +-- arrows are just to indicate what the Positive direction of the darts is. +-- +-- ![myGraph](docs/Data/PlaneGraph/small.png) +-- +-- +-- Here is also a slightly larger example graph: +-- ![myGraph](docs/Data/PlaneGraph/planegraph.png) +-- +-- >>> import Data.RealNumber.Rational +-- >>> data MyWorld +-- >>> :{ +-- let myPlaneGraph :: PlaneGraph MyWorld Int () String (RealNumber 5) +-- myPlaneGraph = fromAdjRep (Proxy @MyWorld) myPlaneGraphAdjrep +-- myPlaneGraphAdjrep :: Gr (Vtx Int () (RealNumber 5)) (Face String) +-- myPlaneGraphAdjrep = Gr [ vtx 0 (Point2 0 0 ) [e 9, e 5, e 1, e 2] +-- , vtx 1 (Point2 4 4 ) [e 0, e 5, e 12] +-- , vtx 2 (Point2 3 7 ) [e 0, e 3] +-- , vtx 3 (Point2 0 5 ) [e 4, e 2] +-- , vtx 4 (Point2 3 8 ) [e 3, e 13] +-- , vtx 5 (Point2 8 1 ) [e 0, e 6, e 8, e 1] +-- , vtx 6 (Point2 6 (-1)) [e 5, e 9] +-- , vtx 7 (Point2 9 (-1)) [e 8, e 11] +-- , vtx 8 (Point2 12 1 ) [e 7, e 12, e 5] +-- , vtx 9 (Point2 8 (-5)) [e 0, e 10, e 6] +-- , vtx 10 (Point2 12 (-3)) [e 9, e 11] +-- , vtx 11 (Point2 14 (-1)) [e 10, e 7] +-- , vtx 12 (Point2 10 4 ) [e 1, e 8, e 13, e 14] +-- , vtx 13 (Point2 9 6 ) [e 4, e 14, e 12] +-- , vtx 14 (Point2 8 5 ) [e 13, e 12] +-- ] +-- [ Face (0,9) "OuterFace" +-- , Face (0,5) "A" +-- , Face (0,1) "B" +-- , Face (0,2) "C" +-- , Face (14,13) "D" +-- , Face (1,12) "E" +-- , Face (5,8) "F" +-- ] +-- where +-- e i = (i,()) +-- vtx i p es = Vtx i p es i +-- :} diff --git a/src/Data/PlaneGraph/AdjRep.hs b/src/Data/PlaneGraph/AdjRep.hs --- a/src/Data/PlaneGraph/AdjRep.hs +++ b/src/Data/PlaneGraph/AdjRep.hs @@ -27,7 +27,7 @@ -- edge. Adjacencies are given in -- arbitrary order , vData :: v - } deriving (Generic, Functor) + } deriving (Generic, Show, Eq, Functor) instance (ToJSON r, ToJSON v, ToJSON e) => ToJSON (Vtx v e r) where toEncoding = genericToEncoding defaultOptions 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 @@ -13,7 +13,8 @@ -- embedding. -- -------------------------------------------------------------------------------- -module Data.PlaneGraph.Core( PlaneGraph(PlaneGraph), graph +module Data.PlaneGraph.Core( -- $setup + PlaneGraph(PlaneGraph), graph , PlanarGraph , VertexData(VertexData), vData, location, vtxDataToExt , fromSimplePolygon, fromConnectedSegments @@ -24,7 +25,7 @@ , vertices', vertices , edges', edges - , faces', faces, internalFaces, faces'' + , faces', internalFaces', faces, internalFaces, faces'' , darts', darts , traverseVertices, traverseDarts, traverseFaces @@ -33,6 +34,7 @@ , incidentEdges, incomingEdges, outgoingEdges , neighboursOf , nextIncidentEdge, prevIncidentEdge + , nextIncidentEdgeFrom, prevIncidentEdgeFrom , leftFace, rightFace @@ -46,12 +48,12 @@ , vertexData, faceData, dartData, rawDartData , edgeSegment, edgeSegments - , rawFacePolygon, rawFaceBoundary - , rawFacePolygons + , faceBoundary, internalFacePolygon + , outerFacePolygon, outerFacePolygon' + , facePolygons, facePolygons', internalFacePolygons , VertexId(..), FaceId(..), Dart, World(..), VertexId', FaceId' - , withEdgeDistances -- , writePlaneGraph, readPlaneGraph ) where @@ -59,7 +61,7 @@ import Control.Lens hiding (holes, holesOf, (.=)) import Data.Aeson -import qualified Data.CircularSeq as C +import Data.Bifunctor (first) import Data.Ext import qualified Data.Foldable as F import Data.Function (on) @@ -68,28 +70,25 @@ import Data.Geometry.Line (cmpSlope, supportingLine) import Data.Geometry.LineSegment hiding (endPoints) import Data.Geometry.Point +import Data.Geometry.Vector 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 Data.PlanarGraph (Arc (..), Dart (..), Direction (..), FaceId (..), + FaceId', HasDataOf (..), PlanarGraph, VertexId (..), + VertexId', World (..), dual, planarGraph, twin) import qualified Data.PlanarGraph as PG -import Data.PlanarGraph( PlanarGraph, planarGraph, dual - , Dart(..), VertexId(..), FaceId(..), Arc(..) - , Direction(..), twin - , World(..) - , FaceId', VertexId' - , HasDataOf(..) - ) import Data.Util import qualified Data.Vector as V +import Data.Vector.Circular (CircularVector) import GHC.Generics (Generic) --------------------------------------------------------------------------------- +-------------------------------------------------------------------------------- -- $setup --- >>> import Data.Proxy -- >>> import Data.PlaneGraph.AdjRep(Gr(Gr),Face(Face),Vtx(Vtx)) -- >>> import Data.PlaneGraph.IO(fromAdjRep) -- >>> import Data.PlanarGraph.Dart(Dart(..),Arc(..)) @@ -115,7 +114,7 @@ -- , Face (0,1) "A" -- , Face (1,0) "B" -- ] --- smallG = fromAdjRep (Proxy :: Proxy ()) small +-- smallG = fromAdjRep @() small -- :} -- -- @@ -123,7 +122,45 @@ -- arrows are just to indicate what the Positive direction of the darts is. -- -- ![myGraph](docs/Data/PlaneGraph/small.png) - +-- +-- +-- Here is also a slightly larger example graph: +-- ![myGraph](docs/Data/PlaneGraph/planegraph.png) +-- +-- >>> import Data.RealNumber.Rational +-- >>> data MyWorld +-- >>> :{ +-- let myPlaneGraph :: PlaneGraph MyWorld Int () String (RealNumber 5) +-- myPlaneGraph = fromAdjRep @MyWorld myPlaneGraphAdjrep +-- myPlaneGraphAdjrep :: Gr (Vtx Int () (RealNumber 5)) (Face String) +-- myPlaneGraphAdjrep = Gr [ vtx 0 (Point2 0 0 ) [e 9, e 5, e 1, e 2] +-- , vtx 1 (Point2 4 4 ) [e 0, e 5, e 12] +-- , vtx 2 (Point2 3 7 ) [e 0, e 3] +-- , vtx 3 (Point2 0 5 ) [e 4, e 2] +-- , vtx 4 (Point2 3 8 ) [e 3, e 13] +-- , vtx 5 (Point2 8 1 ) [e 0, e 6, e 8, e 1] +-- , vtx 6 (Point2 6 (-1)) [e 5, e 9] +-- , vtx 7 (Point2 9 (-1)) [e 8, e 11] +-- , vtx 8 (Point2 12 1 ) [e 7, e 12, e 5] +-- , vtx 9 (Point2 8 (-5)) [e 0, e 10, e 6] +-- , vtx 10 (Point2 12 (-3)) [e 9, e 11] +-- , vtx 11 (Point2 14 (-1)) [e 10, e 7] +-- , vtx 12 (Point2 10 4 ) [e 1, e 8, e 13, e 14] +-- , vtx 13 (Point2 9 6 ) [e 4, e 14, e 12] +-- , vtx 14 (Point2 8 5 ) [e 13, e 12] +-- ] +-- [ Face (0,9) "OuterFace" +-- , Face (0,5) "A" +-- , Face (0,1) "B" +-- , Face (0,2) "C" +-- , Face (14,13) "D" +-- , Face (1,12) "E" +-- , Face (5,8) "F" +-- ] +-- where +-- e i = (i,()) +-- vtx i p es = Vtx i p es i +-- :} -------------------------------------------------------------------------------- -- * Vertex Data @@ -135,6 +172,7 @@ ,Functor,Foldable,Traversable) makeLenses ''VertexData +-- | Convert to an Ext vtxDataToExt :: VertexData r v -> Point 2 r :+ v vtxDataToExt (VertexData p v) = p :+ v @@ -177,22 +215,23 @@ -- -- pre: the input polygon is given in counterclockwise order -- running time: \(O(n)\). -fromSimplePolygon :: proxy s - -> SimplePolygon p r +fromSimplePolygon :: forall s p r f. + SimplePolygon p r -> f -- ^ data inside -> f -- ^ data outside the polygon -> PlaneGraph s p () f r -fromSimplePolygon p (SimplePolygon vs) iD oD = PlaneGraph g' +fromSimplePolygon poly iD oD = PlaneGraph g' where - g = fromVertices p vs + vs = poly ^. outerBoundaryVector + g = fromVertices 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) - -> PlanarGraph s Primal (VertexData r p) () () -fromVertices _ vs = g&PG.vertexData .~ vData' +fromVertices :: forall s r p. + CircularVector (Point 2 r :+ p) + -> PlanarGraph s Primal (VertexData r p) () () +fromVertices vs = g&PG.vertexData .~ vData' where n = length vs g = planarGraph [ [ (Dart (Arc i) Positive, ()) @@ -206,11 +245,10 @@ -- pre: The segments form a single connected component -- -- running time: \(O(n\log n)\) -fromConnectedSegments :: (Foldable f, Ord r, Num r) - => proxy s - -> f (LineSegment 2 p r :+ e) - -> PlaneGraph s (NonEmpty.NonEmpty p) e () r -fromConnectedSegments _ ss = PlaneGraph $ planarGraph dts & PG.vertexData .~ vxData +fromConnectedSegments :: forall s p r e f. (Foldable f, Ord r, Num r) + => f (LineSegment 2 p r :+ e) + -> PlaneGraph s (NonEmpty.NonEmpty p) e () r +fromConnectedSegments ss = PlaneGraph $ planarGraph dts & PG.vertexData .~ vxData where pts = M.fromListWith (<>) . concatMap f . zipWith g [0..] . F.toList $ ss f (s :+ e) = [ ( s^.start.core @@ -223,7 +261,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 @@ -238,6 +276,8 @@ -- -- >>> numVertices smallG -- 4 +-- >>> numVertices myPlaneGraph +-- 15 numVertices :: PlaneGraph s v e f r -> Int numVertices = PG.numVertices . _graph @@ -245,6 +285,7 @@ -- -- >>> numDarts smallG -- 10 +-- numDarts :: PlaneGraph s v e f r -> Int numDarts = PG.numDarts . _graph @@ -259,6 +300,8 @@ -- -- >>> numFaces smallG -- 3 +-- >>> numFaces myPlaneGraph +-- 7 numFaces :: PlaneGraph s v e f r -> Int numFaces = PG.numFaces . _graph @@ -272,10 +315,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 @@ -284,9 +327,12 @@ darts' = PG.darts' . _graph -- | Get all darts together with their data +-- +-- darts :: PlaneGraph s v e f r -> V.Vector (Dart s, e) darts = PG.darts . _graph + -- | Enumerate all edges. We report only the Positive darts edges' :: PlaneGraph s v e f r -> V.Vector (Dart s) edges' = PG.edges' . _graph @@ -330,26 +376,40 @@ faces' :: PlaneGraph s v e f r -> V.Vector (FaceId' s) faces' = PG.faces' . _graph + +-- | face Ids of all internal faces in the plane graph +-- +-- running time: \(O(n)\) +internalFaces' :: (Ord r, Num r) => PlaneGraph s v e f r -> V.Vector (FaceId' s) +internalFaces' g = let i = outerFaceId g in V.filter (/= i) $ faces' g + -- | All faces with their face data. -- -- >>> mapM_ print $ faces smallG -- (FaceId 0,"OuterFace") -- (FaceId 1,"A") -- (FaceId 2,"B") +-- >>> mapM_ print $ faces myPlaneGraph +-- (FaceId 0,"OuterFace") +-- (FaceId 1,"A") +-- (FaceId 2,"B") +-- (FaceId 3,"C") +-- (FaceId 4,"E") +-- (FaceId 5,"F") +-- (FaceId 6,"D") faces :: PlaneGraph s v e f r -> V.Vector (FaceId' s, f) faces = PG.faces . _graph - -- | Reports the outerface and all internal faces separately. -- running time: \(O(n)\) -faces'' :: (Ord r, Fractional r) +faces'' :: (Ord r, Num r) => PlaneGraph s v e f r -> ((FaceId' s, f), V.Vector (FaceId' s, f)) faces'' g = let i = outerFaceId g in ((i,g^.dataOf i), V.filter (\(j,_) -> i /= j) $ faces g) -- | Reports all internal faces. -- running time: \(O(n)\) -internalFaces :: (Ord r, Fractional r) +internalFaces :: (Ord r, Num r) => PlaneGraph s v e f r -> V.Vector (FaceId' s, f) internalFaces = snd . faces'' @@ -387,20 +447,34 @@ -- -- >>> incidentEdges (VertexId 1) smallG -- [Dart (Arc 1) -1,Dart (Arc 4) +1,Dart (Arc 3) +1] +-- >>> mapM_ print $ incidentEdges (VertexId 5) myPlaneGraph +-- Dart (Arc 1) -1 +-- Dart (Arc 7) +1 +-- Dart (Arc 10) +1 +-- Dart (Arc 4) -1 incidentEdges :: VertexId' s -> PlaneGraph s v e f r -> V.Vector (Dart s) incidentEdges v = PG.incidentEdges v . _graph --- | All incoming edges incident to vertex v, in counterclockwise order around v. + +-- | All edges incident to vertex v in incoming direction +-- (i.e. pointing into v) in counterclockwise order around v. -- +-- running time: \(O(k)\), where \(k) is the total number of incident edges of v +-- -- >>> incomingEdges (VertexId 1) smallG --- [Dart (Arc 1) -1] +-- [Dart (Arc 1) +1,Dart (Arc 4) -1,Dart (Arc 3) -1] incomingEdges :: VertexId' s -> PlaneGraph s v e f r -> V.Vector (Dart s) incomingEdges v = PG.incomingEdges v . _graph --- | All outgoing edges incident to vertex v, in counterclockwise order around v. + + +-- | All edges incident to vertex v in outgoing direction +-- (i.e. pointing out of v) in counterclockwise order around v. -- +-- running time: \(O(k)\), where \(k) is the total number of incident edges of v +-- -- >>> outgoingEdges (VertexId 1) smallG --- [Dart (Arc 4) +1,Dart (Arc 3) +1] +-- [Dart (Arc 1) -1,Dart (Arc 4) +1,Dart (Arc 3) +1] outgoingEdges :: VertexId' s -> PlaneGraph s v e f r -> V.Vector (Dart s) outgoingEdges v = PG.outgoingEdges v . _graph @@ -411,31 +485,69 @@ -- -- >>> neighboursOf (VertexId 1) smallG -- [VertexId 0,VertexId 2,VertexId 3] +-- >>> neighboursOf (VertexId 5) myPlaneGraph +-- [VertexId 0,VertexId 6,VertexId 8,VertexId 1] neighboursOf :: VertexId' s -> PlaneGraph s v e f r -> V.Vector (VertexId' s) neighboursOf v = PG.neighboursOf v . _graph -- | Given a dart d that points into some vertex v, report the next dart in the --- cyclic order around v in clockwise direction. +-- cyclic (counterclockwise) order around v. -- -- running time: \(O(1)\) -- -- >>> nextIncidentEdge (dart 1 "+1") smallG --- Dart (Arc 2) +1 +-- Dart (Arc 4) +1 +-- >>> nextIncidentEdge (dart 1 "+1") myPlaneGraph +-- Dart (Arc 7) +1 +-- >>> nextIncidentEdge (dart 17 "-1") myPlaneGraph +-- Dart (Arc 15) -1 nextIncidentEdge :: Dart s -> PlaneGraph s v e f r -> Dart s nextIncidentEdge d = PG.nextIncidentEdge d . _graph --- | Given a dart d that points into some vertex v, report the next dart in the --- cyclic order around v (in clockwise order) +-- | Given a dart d that points into some vertex v, report the previous dart in the +-- cyclic (counterclockwise) order around v. -- -- running time: \(O(1)\) -- -- >>> prevIncidentEdge (dart 1 "+1") smallG --- Dart (Arc 0) +1 +-- Dart (Arc 3) +1 +-- >>> prevIncidentEdge (dart 1 "+1") myPlaneGraph +-- Dart (Arc 4) -1 +-- >>> prevIncidentEdge (dart 7 "-1") myPlaneGraph +-- Dart (Arc 1) -1 prevIncidentEdge :: Dart s -> PlaneGraph s v e f r -> Dart s prevIncidentEdge d = PG.prevIncidentEdge d . _graph +-- | Given a dart d that points away from some vertex v, report the +-- next dart in the cyclic (counterclockwise) order around v. +-- +-- +-- running time: \(O(1)\) +-- +-- >>> nextIncidentEdgeFrom (dart 1 "+1") smallG +-- Dart (Arc 2) +1 +-- >>> nextIncidentEdgeFrom (dart 1 "+1") myPlaneGraph +-- Dart (Arc 2) +1 +-- >>> nextIncidentEdgeFrom (dart 4 "+1") myPlaneGraph +-- Dart (Arc 15) +1 +nextIncidentEdgeFrom :: Dart s -> PlaneGraph s v e f r -> Dart s +nextIncidentEdgeFrom d = PG.nextIncidentEdgeFrom d . _graph + +-- | Given a dart d that points into away from vertex v, report the previous dart in the +-- cyclic (counterclockwise) order around v. +-- +-- running time: \(O(1)\) +-- +-- >>> prevIncidentEdgeFrom (dart 1 "+1") smallG +-- Dart (Arc 0) +1 +-- >>> prevIncidentEdgeFrom (dart 4 "+1") myPlaneGraph +-- Dart (Arc 2) -1 +prevIncidentEdgeFrom :: Dart s -> PlaneGraph s v e f r -> Dart s +prevIncidentEdgeFrom d = PG.prevIncidentEdgeFrom d . _graph + + -- | The face to the left of the dart -- -- running time: \(O(1)\). @@ -488,20 +600,34 @@ prevEdge d = PG.prevEdge d . _graph --- | The darts bounding this face, for internal faces in clockwise order, for --- the outer face in counter clockwise order. --- +-- | The darts bounding this face. The darts are reported in order +-- along the face. This means that for internal faces the darts are +-- reported in *clockwise* order along the boundary, whereas for the +-- outer face the darts are reported in counter clockwise order. -- -- running time: \(O(k)\), where \(k\) is the output size. -- +-- >>> boundary (FaceId $ VertexId 2) smallG -- around face B +-- [Dart (Arc 2) +1,Dart (Arc 3) -1,Dart (Arc 1) -1] +-- >>> boundary (FaceId $ VertexId 0) smallG -- around outer face +-- [Dart (Arc 0) +1,Dart (Arc 4) -1,Dart (Arc 3) +1,Dart (Arc 2) -1] -- boundary :: FaceId' s -> PlaneGraph s v e f r -> V.Vector (Dart s) boundary f = PG.boundary f . _graph --- | Generates the darts incident to a face, starting with the given dart. +-- | Given a dart d, generates the darts bounding the face that is to +-- the right of the given dart. The darts are reported in order along +-- the face. This means that for internal faces the darts are reported +-- in *clockwise* order along the boundary, whereas for the outer face +-- the darts are reported in counter clockwise order. -- +-- running time: \(O(k)\), where \(k\) is the number of darts reported -- --- \(O(k)\), where \(k\) is the number of darts reported +-- >>> boundary' (dart 2 "+1") smallG -- around face B +-- [Dart (Arc 2) +1,Dart (Arc 3) -1,Dart (Arc 1) -1] +-- >>> boundary' (dart 0 "+1") smallG -- around outer face +-- [Dart (Arc 0) +1,Dart (Arc 4) -1,Dart (Arc 3) +1,Dart (Arc 2) -1] +-- boundary' :: Dart s -> PlaneGraph s v e f r -> V.Vector (Dart s) boundary' d = PG.boundary' d . _graph @@ -513,8 +639,24 @@ -- | The vertices bounding this face, for internal faces in clockwise order, for -- the outer face in counter clockwise order. -- --- -- running time: \(O(k)\), where \(k\) is the output size. +-- +-- >>> boundaryVertices (FaceId $ VertexId 2) smallG -- around B +-- [VertexId 0,VertexId 3,VertexId 1] +-- >>> boundaryVertices (FaceId $ VertexId 0) smallG -- around outerface +-- [VertexId 0,VertexId 2,VertexId 1,VertexId 3] +-- >>> mapM_ print $ boundaryVertices (FaceId $ VertexId 0) myPlaneGraph +-- VertexId 0 +-- VertexId 9 +-- VertexId 10 +-- VertexId 11 +-- VertexId 7 +-- VertexId 8 +-- VertexId 12 +-- VertexId 13 +-- VertexId 4 +-- VertexId 3 +-- VertexId 2 boundaryVertices :: FaceId' s -> PlaneGraph s v e f r -> V.Vector (VertexId' s) boundaryVertices f = PG.boundaryVertices f . _graph @@ -523,9 +665,18 @@ -------------------------------------------------------------------------------- -- * Access data + +-- | Lens to access the vertex data +-- +-- Note that using the setting part of this lens may be very +-- expensive!! (O(n)) vertexDataOf :: VertexId' s -> Lens' (PlaneGraph s v e f r ) (VertexData r v) vertexDataOf v = graph.PG.dataOf v +-- | Get the location of a vertex in the plane graph +-- +-- Note that the setting part of this lens may be very expensive! +-- Moreover, use with care (as this may destroy planarity etc.) locationOf :: VertexId' s -> Lens' (PlaneGraph s v e f r ) (Point 2 r) locationOf v = vertexDataOf v.location @@ -556,7 +707,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 -- @@ -611,7 +762,7 @@ -- -- running time: \(O(n)\) -- -outerFaceId :: (Ord r, Fractional r) => PlaneGraph s v e f r -> FaceId' s +outerFaceId :: (Ord r, Num r) => PlaneGraph s v e f r -> FaceId' s outerFaceId ps = leftFace (outerFaceDart ps) ps @@ -620,19 +771,24 @@ -- -- running time: \(O(n)\) -- -outerFaceDart :: (Ord r, Fractional r) => PlaneGraph s v e f r -> Dart s -outerFaceDart ps = d +outerFaceDart :: (Ord r, Num r) => PlaneGraph s v e f r -> Dart s +outerFaceDart pg = d where - (v,_) = V.minimumBy (comparing (^._2.location)) . vertices $ ps + (v,_) = V.minimumBy (comparing (^._2.location)) . vertices $ pg -- 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) - $ incidentEdges v ps + + (_ :+ d) = V.minimumBy (cwCmpAroundWith' (Vector2 (-1) 0) (pg^.locationOf v :+ ())) + . fmap (\d' -> let u = headOf d' pg in (pg^.locationOf u) :+ d') + $ outgoingEdges v pg -- 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 -- and take the face left of that edge. This is the outerface. -- note that this requires that the edges are straight line segments + -- + -- note that rather computing slopes we just ask for the first + -- vertec cw vertex around v. First with respect to some direction + -- pointing towards the left. -------------------------------------------------------------------------------- @@ -641,11 +797,32 @@ -- | 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") +-- >>> mapM_ print $ edgeSegments myPlaneGraph +-- (Dart (Arc 0) +1,ClosedLineSegment (Point2 0 0 :+ 0) (Point2 8 (-5) :+ 9) :+ ()) +-- (Dart (Arc 1) +1,ClosedLineSegment (Point2 0 0 :+ 0) (Point2 8 1 :+ 5) :+ ()) +-- (Dart (Arc 2) +1,ClosedLineSegment (Point2 0 0 :+ 0) (Point2 4 4 :+ 1) :+ ()) +-- (Dart (Arc 3) +1,ClosedLineSegment (Point2 0 0 :+ 0) (Point2 3 7 :+ 2) :+ ()) +-- (Dart (Arc 4) +1,ClosedLineSegment (Point2 4 4 :+ 1) (Point2 8 1 :+ 5) :+ ()) +-- (Dart (Arc 15) +1,ClosedLineSegment (Point2 4 4 :+ 1) (Point2 10 4 :+ 12) :+ ()) +-- (Dart (Arc 5) +1,ClosedLineSegment (Point2 3 7 :+ 2) (Point2 0 5 :+ 3) :+ ()) +-- (Dart (Arc 6) +1,ClosedLineSegment (Point2 0 5 :+ 3) (Point2 3 8 :+ 4) :+ ()) +-- (Dart (Arc 18) +1,ClosedLineSegment (Point2 3 8 :+ 4) (Point2 9 6 :+ 13) :+ ()) +-- (Dart (Arc 7) +1,ClosedLineSegment (Point2 8 1 :+ 5) (Point2 6 (-1) :+ 6) :+ ()) +-- (Dart (Arc 10) +1,ClosedLineSegment (Point2 8 1 :+ 5) (Point2 12 1 :+ 8) :+ ()) +-- (Dart (Arc 12) +1,ClosedLineSegment (Point2 6 (-1) :+ 6) (Point2 8 (-5) :+ 9) :+ ()) +-- (Dart (Arc 8) +1,ClosedLineSegment (Point2 9 (-1) :+ 7) (Point2 12 1 :+ 8) :+ ()) +-- (Dart (Arc 14) +1,ClosedLineSegment (Point2 9 (-1) :+ 7) (Point2 14 (-1) :+ 11) :+ ()) +-- (Dart (Arc 9) +1,ClosedLineSegment (Point2 12 1 :+ 8) (Point2 10 4 :+ 12) :+ ()) +-- (Dart (Arc 11) +1,ClosedLineSegment (Point2 8 (-5) :+ 9) (Point2 12 (-3) :+ 10) :+ ()) +-- (Dart (Arc 13) +1,ClosedLineSegment (Point2 12 (-3) :+ 10) (Point2 14 (-1) :+ 11) :+ ()) +-- (Dart (Arc 16) +1,ClosedLineSegment (Point2 10 4 :+ 12) (Point2 9 6 :+ 13) :+ ()) +-- (Dart (Arc 17) +1,ClosedLineSegment (Point2 10 4 :+ 12) (Point2 8 5 :+ 14) :+ ()) +-- (Dart (Arc 19) +1,ClosedLineSegment (Point2 9 6 :+ 13) (Point2 8 5 :+ 14) :+ ()) edgeSegments :: PlaneGraph s v e f r -> V.Vector (Dart s, LineSegment 2 v r :+ e) edgeSegments ps = fmap withSegment . edges $ ps where @@ -665,31 +842,87 @@ seg = let (p,q) = bimap vtxDataToExt vtxDataToExt $ ps^.endPointsOf d in ClosedLineSegment p q --- | The polygon describing the face + +-- | The boundary of the face as a simple polygon. For internal faces +-- the polygon that is reported has its vertices stored in CCW order +-- (as expected). -- --- runningtime: \(O(k)\), where \(k\) is the size of the face. +-- pre: FaceId refers to an internal face. -- +-- For the other face this prodcuces a polygon in CW order (this may +-- lead to unexpected results.) -- -rawFaceBoundary :: FaceId' s -> PlaneGraph s v e f r - -> SimplePolygon v r :+ f -rawFaceBoundary i ps = pg :+ (ps^.dataOf i) +-- runningtime: \(O(k)\), where \(k\) is the size of the face. +faceBoundary :: FaceId' s -> PlaneGraph s v e f r -> SimplePolygon v r :+ f +faceBoundary i ps = pg :+ (ps^.dataOf i) where - pg = fromPoints . F.toList . fmap (\j -> ps^.graph.dataOf j.to vtxDataToExt) + pg = unsafeFromVector . V.reverse . fmap (\j -> ps^.graph.dataOf j.to vtxDataToExt) . boundaryVertices i $ ps + -- polygons are stored in CCW order, the boundaryVertices of + -- internal faces are reported in CW order we reverse them. --- | Alias for rawFace Boundary +-------------------------------------------------------------------------------- + +-- | The boundary of the face as a simple polygon. For internal faces +-- the polygon that is reported has its vertices stored in CCW order +-- (as expected). -- +-- pre: FaceId refers to an internal face. +-- +-- For the other face this prodcuces a polygon in CW order (this may +-- lead to unexpected results.) +-- -- runningtime: \(O(k)\), where \(k\) is the size of the face. -rawFacePolygon :: FaceId' s -> PlaneGraph s v e f r -> SimplePolygon v r :+ f -rawFacePolygon = rawFaceBoundary +internalFacePolygon :: FaceId' s -> PlaneGraph s v e f r -> SimplePolygon v r :+ f +internalFacePolygon = faceBoundary --- | Lists all faces of the plane graph. -rawFacePolygons :: PlaneGraph s v e f r - -> V.Vector (FaceId' s, SimplePolygon v r :+ f) -rawFacePolygons ps = fmap (\i -> (i,rawFacePolygon i ps)) . faces' $ ps +-- | Given the outerFaceId and the graph, construct a sufficiently +-- large rectangular multipolygon ith a hole containing the boundary +-- of the outer face. +outerFacePolygon :: (Num r, Ord r) + => FaceId' s -> PlaneGraph s v e f r -> MultiPolygon (Maybe v) r :+ f +outerFacePolygon i pg = + outerFacePolygon' i outer pg & core %~ first (either (const Nothing) Just) + where + outer = rectToPolygon . grow 1 . boundingBox $ pg + rectToPolygon = unsafeFromPoints . reverse . F.toList . corners +-- | Given the outerface id, and a sufficiently large outer boundary, +-- draw the outerface as a polygon with a hole. +outerFacePolygon' :: FaceId' s -> SimplePolygon v' r + -> PlaneGraph s v e f r -> MultiPolygon (Either v' v) r :+ f +outerFacePolygon' i outer pg = MultiPolygon (first Left outer) [hole] :+ pg^.dataOf i + where + hole = reverseOuterBoundary . first Right . view core $ faceBoundary i pg + -- if we call faceBoundary on the outerface we get a polygon in + -- the wrong orientation. So reverse it. + -------------------------------------------------------------------------------- +-- | Given the outerFace Id, construct polygons for all faces. We +-- construct a polygon with a hole for the outer face. +-- +facePolygons :: (Num r, Ord r) => FaceId' s -> PlaneGraph s v e f r + -> ( (FaceId' s, MultiPolygon (Maybe v) r :+ f) + , V.Vector (FaceId' s, SimplePolygon v r :+ f) + ) +facePolygons i ps = ((i, outerFacePolygon i ps), facePolygons' i ps) + +-- | Given the outerFace Id, lists all internal faces of the plane +-- graph with their boundaries. +facePolygons' :: FaceId' s -> PlaneGraph s v e f r + -> V.Vector (FaceId' s, SimplePolygon v r :+ f) +facePolygons' i ps = fmap (\j -> (j,internalFacePolygon j ps)) . V.filter (/= i) . faces' $ ps + + +-- | lists all internal faces of the plane graph with their +-- boundaries. +internalFacePolygons :: (Ord r, Num r) + => PlaneGraph s v e f r -> V.Vector (FaceId' s, SimplePolygon v r :+ f) +internalFacePolygons pg = facePolygons' (outerFaceId pg) pg + +-------------------------------------------------------------------------------- + -- | Labels the edges of a plane graph with their distances, as specified by -- the distance function. withEdgeDistances :: (Point 2 r -> Point 2 r -> a) @@ -697,3 +930,7 @@ withEdgeDistances f g = g&graph.PG.dartData %~ fmap (\(d,x) -> (d,len d :+ x)) where len d = uncurry f . over both (^.location) $ endPointData d g + + + +-------------------------------------------------------------------------------- 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,19 +16,22 @@ 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 import qualified Data.PlanarGraph.IO as PGIO import Data.PlaneGraph.Core -import Data.PlaneGraph.AdjRep (Face,Vtx(Vtx),Gr(Gr)) -import Data.Proxy +import Data.PlaneGraph.AdjRep import qualified Data.Vector as V import qualified Data.Vector.Mutable as MV import Data.Yaml (ParseException) import Data.Yaml.Util + +import Data.RealNumber.Rational +-- import Data.PlanarGraph.Dart +-- import Data.PlaneGraph.AdjRep + -------------------------------------------------------------------------------- -- $setup @@ -56,7 +59,7 @@ -- , Face (0,1) "A" -- , Face (1,0) "B" -- ] --- smallG = fromAdjRep (Proxy :: Proxy ()) small +-- smallG = fromAdjRep @() small -- :} -- -- @@ -69,10 +72,10 @@ -- * Reading and Writing the Plane Graph -- | Reads a plane graph from a bytestring -readPlaneGraph :: (FromJSON v, FromJSON e, FromJSON f, FromJSON r) - => proxy s -> B.ByteString - -> Either ParseException (PlaneGraph s v e f r) -readPlaneGraph _ = decodeYaml +readPlaneGraph :: forall s v e f r. (FromJSON v, FromJSON e, FromJSON f, FromJSON r) + => B.ByteString + -> Either ParseException (PlaneGraph s v e f r) +readPlaneGraph = decodeYaml -- | Writes a plane graph to a bytestring writePlaneGraph :: (ToJSON v, ToJSON e, ToJSON f, ToJSON r) @@ -87,7 +90,7 @@ instance (FromJSON v, FromJSON e, FromJSON f, FromJSON r) => FromJSON (PlaneGraph s v e f r) where - parseJSON v = fromAdjRep (Proxy :: Proxy s) <$> parseJSON v + parseJSON v = fromAdjRep @s <$> parseJSON v -------------------------------------------------------------------------------- @@ -106,9 +109,9 @@ -- should be in counter clockwise order. -- -- running time: \(O(n)\) -fromAdjRep :: proxy s -> Gr (Vtx v e r) (Face f) -> PlaneGraph s v e f r -fromAdjRep px = PlaneGraph . PGIO.fromAdjRep px - . first (\(Vtx v p aj x) -> PGA.Vtx v aj $ VertexData p x) +fromAdjRep :: forall s v e f r. Gr (Vtx v e r) (Face f) -> PlaneGraph s v e f r +fromAdjRep = PlaneGraph . PGIO.fromAdjRep + . first (\(Vtx v p aj x) -> PGA.Vtx v aj $ VertexData p x) -------------------------------------------------------------------------------- @@ -123,13 +126,81 @@ 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 -------------------------------------------------------------------------------- + +-- smallG = fromAdjRep (Proxy :: Proxy ()) small +-- where +-- small :: Gr (Vtx Int String Int) (Face String) +-- small = Gr [ Vtx 0 (Point2 0 0) [ (2,"0->2") +-- , (1,"0->1") +-- , (3,"0->3") +-- ] 0 +-- , Vtx 1 (Point2 2 2) [ (0,"1->0") +-- , (2,"1->2") +-- , (3,"1->3") +-- ] 1 +-- , Vtx 2 (Point2 2 0) [ (0,"2->0") +-- , (1,"2->1") +-- ] 2 +-- , Vtx 3 (Point2 (-1) 4) [ (0,"3->0") +-- , (1,"3->1") +-- ] 3 +-- ] +-- [ Face (2,1) "OuterFace" +-- , Face (0,1) "A" +-- , Face (1,0) "B" +-- ] + +-- dart i s = Dart (Arc i) (read s) + +data MyWorld + +-- ![myGraph](docs/Data/PlaneGraph/planegraph.png) +myPlaneGraph :: PlaneGraph MyWorld Int () String (RealNumber 5) +myPlaneGraph = fromAdjRep @MyWorld myPlaneGraphAdjrep + +myPlaneGraphAdjrep :: Gr (Vtx Int () (RealNumber 5)) (Face String) +myPlaneGraphAdjrep = Gr [ vtx 0 (Point2 0 0 ) [e 9, e 5, e 1, e 2] + , vtx 1 (Point2 4 4 ) [e 0, e 5, e 12] + , vtx 2 (Point2 3 7 ) [e 0, e 3] + , vtx 3 (Point2 0 5 ) [e 4, e 2] + , vtx 4 (Point2 3 8 ) [e 3, e 13] + , vtx 5 (Point2 8 1 ) [e 0, e 6, e 8, e 1] + , vtx 6 (Point2 6 (-1)) [e 5, e 9] + , vtx 7 (Point2 9 (-1)) [e 8, e 11] + , vtx 8 (Point2 12 1 ) [e 7, e 12, e 5] + , vtx 9 (Point2 8 (-5)) [e 0, e 10, e 6] + , vtx 10 (Point2 12 (-3)) [e 9, e 11] + , vtx 11 (Point2 14 (-1)) [e 10, e 7] + , vtx 12 (Point2 10 4 ) [e 1, e 8, e 13, e 14] + , vtx 13 (Point2 9 6 ) [e 4, e 14, e 12] + , vtx 14 (Point2 8 5 ) [e 13, e 12] + ] + [ Face (0,9) "OuterFace" + , Face (0,5) "A" + , Face (0,1) "B" + , Face (0,2) "C" + , Face (14,13) "D" + , Face (1,12) "E" + , Face (5,8) "F" + ] + where + e i = (i,()) + vtx i p es = Vtx i p es i + + + + +-- myPlaneGraph' :: IO (PlaneGraph MyWorld () () () (RealNumber 5)) +-- myPlaneGraph' = let err x = error $ show x +-- in either err id . readPlaneGraph +-- <$> B.readFile "docs/Data/PlaneGraph/myPlaneGraph.yaml" 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 @@ -22,16 +21,17 @@ ) where import Control.Lens +import Data.Geometry.Matrix import Data.Geometry.Point -import Data.Geometry.Vector import Data.Geometry.Transformation +import Data.Geometry.Vector -------------------------------------------------------------------------------- -- | 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), @@ -52,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 @@ -81,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