packages feed

hgeometry 0.10.0.0 → 0.14

raw patch · 169 files changed

Files

README.md view
@@ -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.
+ benchmark/Algorithms/Geometry/ClosestPair/Bench.hs view
@@ -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+                ]
+ benchmark/Algorithms/Geometry/ConvexHull/Bench.hs view
@@ -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+                ]
+ benchmark/Algorithms/Geometry/ConvexHull/GrahamFam.hs view
@@ -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
+ benchmark/Algorithms/Geometry/ConvexHull/GrahamFam6.hs view
@@ -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
+ benchmark/Algorithms/Geometry/ConvexHull/GrahamFixed.hs view
@@ -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
+ benchmark/Algorithms/Geometry/ConvexHull/GrahamV2.hs view
@@ -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
+ benchmark/Algorithms/Geometry/LineSegmentIntersection/Bench.hs view
@@ -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)
+ benchmark/Algorithms/Geometry/LineSegmentIntersection/BentleyOttmannNoExt.hs view
@@ -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)
+ benchmark/Algorithms/Geometry/LineSegmentIntersection/BentleyOttmannOld.hs view
@@ -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
+ benchmark/Algorithms/Geometry/LineSegmentIntersection/TypesNoExt.hs view
@@ -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
+ benchmark/Algorithms/Geometry/PolygonTriangulation/Bench.hs view
@@ -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+               ]+-}
+ benchmark/Algorithms/Geometry/PolygonTriangulation/MakeMonotoneOld.hs view
@@ -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
+ benchmark/Benchmark/Util.hs view
@@ -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]
+ benchmark/Benchmarks.hs view
@@ -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 ]
+ benchmark/Data/Geometry/IntervalTreeBench.hs view
@@ -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+--                                          ]
+ benchmark/Data/Geometry/Vector/VectorFamily6.hs view
@@ -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
+ changelog view
@@ -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.
changelog.org view
@@ -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
+ docs/Data/Geometry/PlanarSubdivision/mySubdiv.jpg view

binary file changed (absent → 378223 bytes)

+ docs/Data/PlaneGraph/planegraph.png view

binary file changed (absent → 323390 bytes)

doctests.hs view
@@ -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"   ]
hgeometry.cabal view
@@ -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
+ src/Algorithms/Geometry/ClosestPair.hs view
@@ -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
src/Algorithms/Geometry/ClosestPair/DivideAndConquer.hs view
@@ -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
+ src/Algorithms/Geometry/ConvexHull.hs view
@@ -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
src/Algorithms/Geometry/ConvexHull/DivideAndConquer.hs view
@@ -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
src/Algorithms/Geometry/ConvexHull/GrahamScan.hs view
@@ -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
+ src/Algorithms/Geometry/ConvexHull/JarvisMarch.hs view
@@ -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
+ src/Algorithms/Geometry/ConvexHull/Naive.hs view
@@ -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
src/Algorithms/Geometry/ConvexHull/QuickHull.hs view
@@ -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
src/Algorithms/Geometry/DelaunayTriangulation/DivideAndConquer.hs view
@@ -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
src/Algorithms/Geometry/DelaunayTriangulation/Naive.hs view
@@ -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
src/Algorithms/Geometry/DelaunayTriangulation/Types.hs view
@@ -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
+ src/Algorithms/Geometry/Diameter.hs view
@@ -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
+ src/Algorithms/Geometry/Diameter/ConvexHull.hs view
@@ -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
src/Algorithms/Geometry/Diameter/Naive.hs view
@@ -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
+ src/Algorithms/Geometry/EuclideanMST.hs view
@@ -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
src/Algorithms/Geometry/EuclideanMST/EuclideanMST.hs view
@@ -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
src/Algorithms/Geometry/FrechetDistance/Discrete.hs view
@@ -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
+ src/Algorithms/Geometry/InPolygon.hs view
@@ -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+--                                                   ]
src/Algorithms/Geometry/LineSegmentIntersection.hs view
@@ -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
src/Algorithms/Geometry/LineSegmentIntersection/BentleyOttmann.hs view
@@ -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]
+ src/Algorithms/Geometry/LineSegmentIntersection/BooleanSweep.hs view
@@ -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.
src/Algorithms/Geometry/LineSegmentIntersection/Naive.hs view
@@ -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)
src/Algorithms/Geometry/LineSegmentIntersection/Types.hs view
@@ -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
src/Algorithms/Geometry/LinearProgramming/LP2DRIC.hs view
@@ -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
src/Algorithms/Geometry/LinearProgramming/Types.hs view
@@ -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)
src/Algorithms/Geometry/LowerEnvelope/DualCH.hs view
@@ -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
src/Algorithms/Geometry/PolyLineSimplification/DouglasPeucker.hs view
@@ -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
+ src/Algorithms/Geometry/PolyLineSimplification/ImaiIri.hs view
@@ -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 = []}]+--            }
+ src/Algorithms/Geometry/PolygonTriangulation.hs view
@@ -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
+ src/Algorithms/Geometry/PolygonTriangulation/EarClip.hs view
@@ -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
src/Algorithms/Geometry/PolygonTriangulation/MakeMonotone.hs view
@@ -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)
src/Algorithms/Geometry/PolygonTriangulation/Triangulate.hs view
@@ -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
src/Algorithms/Geometry/PolygonTriangulation/TriangulateMonotone.hs view
@@ -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
src/Algorithms/Geometry/PolygonTriangulation/Types.hs view
@@ -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
+ src/Algorithms/Geometry/RayShooting/Naive.hs view
@@ -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))++++--------------------------------------------------------------------------------
src/Algorithms/Geometry/RedBlueSeparator/RIC.hs view
@@ -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
+ src/Algorithms/Geometry/SSSP.hs view
@@ -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
+ src/Algorithms/Geometry/SSSP/Naive.hs view
@@ -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
+ src/Algorithms/Geometry/SmallestEnclosingBall.hs view
@@ -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
src/Algorithms/Geometry/SmallestEnclosingBall/Naive.hs view
@@ -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
src/Algorithms/Geometry/SmallestEnclosingBall/RIC.hs view
@@ -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) :+ ()+--               ]
src/Algorithms/Geometry/SmallestEnclosingBall/Types.hs view
@@ -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"
+ src/Algorithms/Geometry/SoS.hs view
@@ -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)
+ src/Algorithms/Geometry/SoS/AsPoint.hs view
@@ -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
+ src/Algorithms/Geometry/SoS/Determinant.hs view
@@ -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!"
+ src/Algorithms/Geometry/SoS/Expr.hs view
@@ -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
+ src/Algorithms/Geometry/SoS/Internal.hs view
@@ -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.
+ src/Algorithms/Geometry/SoS/Orientation.hs view
@@ -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
+ src/Algorithms/Geometry/SoS/Sign.hs view
@@ -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"
+ src/Algorithms/Geometry/SoS/Symbolic.hs view
@@ -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
+ src/Algorithms/Geometry/VisibilityPolygon/Lee.hs view
@@ -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
+ src/Algorithms/Geometry/WSPD.hs view
@@ -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++--------------------------------------------------------------------------------
+ src/Algorithms/Geometry/WSPD/Types.hs view
@@ -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
src/Algorithms/Geometry/WellSeparatedPairDecomposition/Types.hs view
@@ -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
src/Algorithms/Geometry/WellSeparatedPairDecomposition/WSPD.hs view
@@ -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
src/Data/Geometry/Arrangement/Internal.hs view
@@ -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)
src/Data/Geometry/Ball.hs view
@@ -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
+ src/Data/Geometry/BezierSpline.hs view
@@ -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
src/Data/Geometry/Boundary.hs view
@@ -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
src/Data/Geometry/Box.hs view
@@ -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
+ src/Data/Geometry/Box/Corners.hs view
@@ -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
src/Data/Geometry/Box/Internal.hs view
@@ -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)
+ src/Data/Geometry/Box/Sides.hs view
@@ -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)
+ src/Data/Geometry/Directions.hs view
@@ -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
src/Data/Geometry/Duality.hs view
@@ -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
+ src/Data/Geometry/Ellipse.hs view
@@ -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)
src/Data/Geometry/HalfLine.hs view
@@ -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--
src/Data/Geometry/HalfSpace.hs view
@@ -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
src/Data/Geometry/HyperPlane.hs view
@@ -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)
src/Data/Geometry/Interval.hs view
@@ -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
src/Data/Geometry/Interval/Util.hs view
@@ -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
src/Data/Geometry/IntervalTree.hs view
@@ -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  --------------------------------------------------------------------------------
src/Data/Geometry/KDTree.hs view
@@ -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
src/Data/Geometry/Line.hs view
@@ -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
src/Data/Geometry/Line/Internal.hs view
@@ -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
src/Data/Geometry/LineSegment.hs view
@@ -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
+ src/Data/Geometry/LineSegment/Internal.hs view
@@ -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)
+ src/Data/Geometry/Matrix.hs view
@@ -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
+ src/Data/Geometry/Matrix/Internal.hs view
@@ -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
src/Data/Geometry/PlanarSubdivision.hs view
@@ -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
src/Data/Geometry/PlanarSubdivision/Basic.hs view
@@ -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
+ src/Data/Geometry/PlanarSubdivision/Dynamic.hs view
@@ -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
src/Data/Geometry/PlanarSubdivision/Merge.hs view
@@ -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
src/Data/Geometry/PlanarSubdivision/Raw.hs view
@@ -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
+ src/Data/Geometry/PlanarSubdivision/TreeRep.hs view
@@ -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
src/Data/Geometry/Point.hs view
@@ -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
+ src/Data/Geometry/Point/Class.hs view
@@ -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 #-}
+ src/Data/Geometry/Point/Internal.hs view
@@ -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
+ src/Data/Geometry/Point/Orientation.hs view
@@ -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)
+ src/Data/Geometry/Point/Orientation/Degenerate.hs view
@@ -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)
+ src/Data/Geometry/Point/Quadrants.hs view
@@ -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
+ src/Data/Geometry/PointLocation.hs view
@@ -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
+ src/Data/Geometry/PointLocation/PersistentSweep.hs view
@@ -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
src/Data/Geometry/PolyLine.hs view
@@ -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
src/Data/Geometry/Polygon.hs view
@@ -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)
+ src/Data/Geometry/Polygon/Bezier.hs view
@@ -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
src/Data/Geometry/Polygon/Convex.hs view
@@ -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: <https://en.wikipedia.org/wiki/Convex_hull_of_a_simple_polygon>+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:<r) c cb = case (isUpwards a r, isUpwards c cb, a >=. c) of+    binSearch ac@(viewl -> a:<r) c cb = case (isUpwards a (r |> 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
src/Data/Geometry/Polygon/Core.hs view
@@ -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')
src/Data/Geometry/Polygon/Extremes.hs view
@@ -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)
+ src/Data/Geometry/Polygon/Inflate.hs view
@@ -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
+ src/Data/Geometry/Polygon/Monotone.hs view
@@ -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+-- <https://en.wikipedia.org/wiki/Monotone_polygon>+--+--------------------------------------------------------------------------------+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
src/Data/Geometry/PrioritySearchTree.hs view
@@ -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)
src/Data/Geometry/Properties.hs view
@@ -1,6 +1,5 @@ {-# LANGUAGE ImpredicativeTypes #-} {-# LANGUAGE UnicodeSyntax #-}-{-# LANGUAGE DefaultSignatures #-} -------------------------------------------------------------------------------- -- | -- Module      :  Data.Geometry.Properties
+ src/Data/Geometry/QuadTree.hs view
@@ -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)++--------------------------------------------------------------------------------
+ src/Data/Geometry/QuadTree/Cell.hs view
@@ -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
+ src/Data/Geometry/QuadTree/Quadrants.hs view
@@ -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 #-}++--------------------------------------------------------------------------------
+ src/Data/Geometry/QuadTree/Split.hs view
@@ -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))"
+ src/Data/Geometry/QuadTree/Tree.hs view
@@ -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
src/Data/Geometry/RangeTree.hs view
@@ -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)
src/Data/Geometry/RangeTree/Generic.hs view
@@ -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  --------------------------------------------------------------------------------
src/Data/Geometry/RangeTree/Measure.hs view
@@ -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
src/Data/Geometry/SegmentTree.hs view
@@ -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
src/Data/Geometry/SegmentTree/Generic.hs view
@@ -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)
src/Data/Geometry/Slab.hs view
@@ -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
src/Data/Geometry/SubLine.hs view
@@ -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
src/Data/Geometry/Transformation.hs view
@@ -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
+ src/Data/Geometry/Transformation/Internal.hs view
@@ -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)
src/Data/Geometry/Triangle.hs view
@@ -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
src/Data/Geometry/Vector.hs view
@@ -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 #-}
src/Data/Geometry/Vector/VectorFamily.hs view
@@ -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)
src/Data/Geometry/Vector/VectorFamilyPeano.hs view
@@ -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
src/Data/Geometry/Vector/VectorFixed.hs view
@@ -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   --------------------------------------------------------------------------------
+ src/Data/Geometry/VerticalRayShooting.hs view
@@ -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
+ src/Data/Geometry/VerticalRayShooting/PersistentSweep.hs view
@@ -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)+++----------------------------------------------------------------------------------
src/Data/PlaneGraph.hs view
@@ -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+-- :}
src/Data/PlaneGraph/AdjRep.hs view
@@ -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
src/Data/PlaneGraph/Core.hs view
@@ -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++++--------------------------------------------------------------------------------
src/Data/PlaneGraph/IO.hs view
@@ -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"
src/Graphics/Camera.hs view
@@ -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
− test/Algorithms/Geometry/LineSegmentIntersection/manual.ipe 
@@ -1,324 +0,0 @@-<?xml version="1.0"?>-<!DOCTYPE ipe SYSTEM "ipe.dtd">-<ipe version="70107" creator="Ipe 7.2.2">-<info created="D:20160903131616" modified="D:20161022125153"/>-<ipestyle name="basic">-<symbol name="arrow/arc(spx)">-<path stroke="sym-stroke" fill="sym-stroke" pen="sym-pen">-0 0 m--1 0.333 l--1 -0.333 l-h-</path>-</symbol>-<symbol name="arrow/farc(spx)">-<path stroke="sym-stroke" fill="white" pen="sym-pen">-0 0 m--1 0.333 l--1 -0.333 l-h-</path>-</symbol>-<symbol name="arrow/ptarc(spx)">-<path stroke="sym-stroke" fill="sym-stroke" pen="sym-pen">-0 0 m--1 0.333 l--0.8 0 l--1 -0.333 l-h-</path>-</symbol>-<symbol name="arrow/fptarc(spx)">-<path stroke="sym-stroke" fill="white" pen="sym-pen">-0 0 m--1 0.333 l--0.8 0 l--1 -0.333 l-h-</path>-</symbol>-<symbol name="mark/circle(sx)" transformations="translations">-<path fill="sym-stroke">-0.6 0 0 0.6 0 0 e-0.4 0 0 0.4 0 0 e-</path>-</symbol>-<symbol name="mark/disk(sx)" transformations="translations">-<path fill="sym-stroke">-0.6 0 0 0.6 0 0 e-</path>-</symbol>-<symbol name="mark/fdisk(sfx)" transformations="translations">-<group>-<path fill="sym-fill">-0.5 0 0 0.5 0 0 e-</path>-<path fill="sym-stroke" fillrule="eofill">-0.6 0 0 0.6 0 0 e-0.4 0 0 0.4 0 0 e-</path>-</group>-</symbol>-<symbol name="mark/box(sx)" transformations="translations">-<path fill="sym-stroke" fillrule="eofill">--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-</path>-</symbol>-<symbol name="mark/square(sx)" transformations="translations">-<path fill="sym-stroke">--0.6 -0.6 m-0.6 -0.6 l-0.6 0.6 l--0.6 0.6 l-h-</path>-</symbol>-<symbol name="mark/fsquare(sfx)" transformations="translations">-<group>-<path fill="sym-fill">--0.5 -0.5 m-0.5 -0.5 l-0.5 0.5 l--0.5 0.5 l-h-</path>-<path fill="sym-stroke" fillrule="eofill">--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-</path>-</group>-</symbol>-<symbol name="mark/cross(sx)" transformations="translations">-<group>-<path fill="sym-stroke">--0.43 -0.57 m-0.57 0.43 l-0.43 0.57 l--0.57 -0.43 l-h-</path>-<path fill="sym-stroke">--0.43 0.57 m-0.57 -0.43 l-0.43 -0.57 l--0.57 0.43 l-h-</path>-</group>-</symbol>-<symbol name="arrow/fnormal(spx)">-<path stroke="sym-stroke" fill="white" pen="sym-pen">-0 0 m--1 0.333 l--1 -0.333 l-h-</path>-</symbol>-<symbol name="arrow/pointed(spx)">-<path stroke="sym-stroke" fill="sym-stroke" pen="sym-pen">-0 0 m--1 0.333 l--0.8 0 l--1 -0.333 l-h-</path>-</symbol>-<symbol name="arrow/fpointed(spx)">-<path stroke="sym-stroke" fill="white" pen="sym-pen">-0 0 m--1 0.333 l--0.8 0 l--1 -0.333 l-h-</path>-</symbol>-<symbol name="arrow/linear(spx)">-<path stroke="sym-stroke" pen="sym-pen">--1 0.333 m-0 0 l--1 -0.333 l-</path>-</symbol>-<symbol name="arrow/fdouble(spx)">-<path stroke="sym-stroke" fill="white" pen="sym-pen">-0 0 m--1 0.333 l--1 -0.333 l-h--1 0 m--2 0.333 l--2 -0.333 l-h-</path>-</symbol>-<symbol name="arrow/double(spx)">-<path stroke="sym-stroke" fill="sym-stroke" pen="sym-pen">-0 0 m--1 0.333 l--1 -0.333 l-h--1 0 m--2 0.333 l--2 -0.333 l-h-</path>-</symbol>-<pen name="heavier" value="0.8"/>-<pen name="fat" value="1.2"/>-<pen name="ultrafat" value="2"/>-<symbolsize name="large" value="5"/>-<symbolsize name="small" value="2"/>-<symbolsize name="tiny" value="1.1"/>-<arrowsize name="large" value="10"/>-<arrowsize name="small" value="5"/>-<arrowsize name="tiny" value="3"/>-<color name="red" value="1 0 0"/>-<color name="green" value="0 1 0"/>-<color name="blue" value="0 0 1"/>-<color name="yellow" value="1 1 0"/>-<color name="orange" value="1 0.647 0"/>-<color name="gold" value="1 0.843 0"/>-<color name="purple" value="0.627 0.125 0.941"/>-<color name="gray" value="0.745"/>-<color name="brown" value="0.647 0.165 0.165"/>-<color name="navy" value="0 0 0.502"/>-<color name="pink" value="1 0.753 0.796"/>-<color name="seagreen" value="0.18 0.545 0.341"/>-<color name="turquoise" value="0.251 0.878 0.816"/>-<color name="violet" value="0.933 0.51 0.933"/>-<color name="darkblue" value="0 0 0.545"/>-<color name="darkcyan" value="0 0.545 0.545"/>-<color name="darkgray" value="0.663"/>-<color name="darkgreen" value="0 0.392 0"/>-<color name="darkmagenta" value="0.545 0 0.545"/>-<color name="darkorange" value="1 0.549 0"/>-<color name="darkred" value="0.545 0 0"/>-<color name="lightblue" value="0.678 0.847 0.902"/>-<color name="lightcyan" value="0.878 1 1"/>-<color name="lightgray" value="0.827"/>-<color name="lightgreen" value="0.565 0.933 0.565"/>-<color name="lightyellow" value="1 1 0.878"/>-<dashstyle name="dashed" value="[4] 0"/>-<dashstyle name="dotted" value="[1 3] 0"/>-<dashstyle name="dash dotted" value="[4 2 1 2] 0"/>-<dashstyle name="dash dot dotted" value="[4 2 1 2 1 2] 0"/>-<textsize name="large" value="\large"/>-<textsize name="Large" value="\Large"/>-<textsize name="LARGE" value="\LARGE"/>-<textsize name="huge" value="\huge"/>-<textsize name="Huge" value="\Huge"/>-<textsize name="small" value="\small"/>-<textsize name="footnote" value="\footnotesize"/>-<textsize name="tiny" value="\tiny"/>-<textstyle name="center" begin="\begin{center}" end="\end{center}"/>-<textstyle name="itemize" begin="\begin{itemize}" end="\end{itemize}"/>-<textstyle name="item" begin="\begin{itemize}\item{}" end="\end{itemize}"/>-<gridsize name="4 pts" value="4"/>-<gridsize name="8 pts (~3 mm)" value="8"/>-<gridsize name="16 pts (~6 mm)" value="16"/>-<gridsize name="32 pts (~12 mm)" value="32"/>-<gridsize name="10 pts (~3.5 mm)" value="10"/>-<gridsize name="20 pts (~7 mm)" value="20"/>-<gridsize name="14 pts (~5 mm)" value="14"/>-<gridsize name="28 pts (~10 mm)" value="28"/>-<gridsize name="56 pts (~20 mm)" value="56"/>-<anglesize name="90 deg" value="90"/>-<anglesize name="60 deg" value="60"/>-<anglesize name="45 deg" value="45"/>-<anglesize name="30 deg" value="30"/>-<anglesize name="22.5 deg" value="22.5"/>-<opacity name="10%" value="0.1"/>-<opacity name="30%" value="0.3"/>-<opacity name="50%" value="0.5"/>-<opacity name="75%" value="0.75"/>-<tiling name="falling" angle="-60" step="4" width="1"/>-<tiling name="rising" angle="30" step="4" width="1"/>-</ipestyle>-<ipestyle name="frank">-<arrowsize name="normal" value="5"/>-<arrowsize name="large" value="8"/>-<arrowsize name="huge" value="10"/>-<arrowsize name="small" value="3"/>-<arrowsize name="tiny" value="1"/>-<dashstyle name="dashed" value="[2 2] 0"/>-<dashstyle name="dotted" value="[0.5 1] 0"/>-<dashstyle name="dash dotted" value="[4 2 1 2] 0"/>-<dashstyle name="dash dot dotted" value="[4 2 1 2 1 2] 0"/>-<gridsize name="1 pts" value="1"/>-<gridsize name="2 pts" value="2"/>-<opacity name="10%" value="0.1"/>-<opacity name="30%" value="0.3"/>-<opacity name="50%" value="0.5"/>-<opacity name="20%" value="0.2"/>-<opacity name="40%" value="0.4"/>-<opacity name="60%" value="0.6"/>-<opacity name="70%" value="0.7"/>-<opacity name="80%" value="0.8"/>-<opacity name="90%" value="0.9"/>-</ipestyle>-<page>-<layer name="alpha"/>-<view layers="alpha" active="alpha"/>-<path layer="alpha" stroke="black">-16 16 m-144 80 l-</path>-<path stroke="black">-128 32 m-256 112 l-</path>-<path stroke="black">-144 80 m-225.708 52.1085 l-</path>-<path matrix="2.39165 0 0 2.39165 -206.711 -120.784" stroke="black">-144 80 m-148.537 86.7918 l-</path>-<path stroke="black">-144 80 m-140.284 85.5945 l-</path>-<path stroke="black">-137.686 70.5482 m-173.031 38.3458 l-</path>-<path stroke="black">-89.5694 78.2992 m-186.333 44.2802 l-</path>-<path stroke="black">-75.255 80.7127 m-75.255 24.0132 l-</path>-<path stroke="black">-35.9103 40.8867 m-180.812 40.8867 l-</path>-<path stroke="black">-82.6725 35.3346 m-57.1425 25.6907 l-</path>-<path stroke="black">-40.6648 34.541 m-144.411 12.4306 l-</path>-</page>-</ipe>
− test/Algorithms/Geometry/LineSegmentIntersection/selfIntersections.ipe 
@@ -1,313 +0,0 @@-<?xml version="1.0"?>-<!DOCTYPE ipe SYSTEM "ipe.dtd">-<ipe version="70107" creator="Ipe 7.2.2">-<info created="D:20170428203409" modified="D:20170428203521"/>-<ipestyle name="basic">-<symbol name="arrow/arc(spx)">-<path stroke="sym-stroke" fill="sym-stroke" pen="sym-pen">-0 0 m--1 0.333 l--1 -0.333 l-h-</path>-</symbol>-<symbol name="arrow/farc(spx)">-<path stroke="sym-stroke" fill="white" pen="sym-pen">-0 0 m--1 0.333 l--1 -0.333 l-h-</path>-</symbol>-<symbol name="arrow/ptarc(spx)">-<path stroke="sym-stroke" fill="sym-stroke" pen="sym-pen">-0 0 m--1 0.333 l--0.8 0 l--1 -0.333 l-h-</path>-</symbol>-<symbol name="arrow/fptarc(spx)">-<path stroke="sym-stroke" fill="white" pen="sym-pen">-0 0 m--1 0.333 l--0.8 0 l--1 -0.333 l-h-</path>-</symbol>-<symbol name="mark/circle(sx)" transformations="translations">-<path fill="sym-stroke">-0.6 0 0 0.6 0 0 e-0.4 0 0 0.4 0 0 e-</path>-</symbol>-<symbol name="mark/disk(sx)" transformations="translations">-<path fill="sym-stroke">-0.6 0 0 0.6 0 0 e-</path>-</symbol>-<symbol name="mark/fdisk(sfx)" transformations="translations">-<group>-<path fill="sym-fill">-0.5 0 0 0.5 0 0 e-</path>-<path fill="sym-stroke" fillrule="eofill">-0.6 0 0 0.6 0 0 e-0.4 0 0 0.4 0 0 e-</path>-</group>-</symbol>-<symbol name="mark/box(sx)" transformations="translations">-<path fill="sym-stroke" fillrule="eofill">--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-</path>-</symbol>-<symbol name="mark/square(sx)" transformations="translations">-<path fill="sym-stroke">--0.6 -0.6 m-0.6 -0.6 l-0.6 0.6 l--0.6 0.6 l-h-</path>-</symbol>-<symbol name="mark/fsquare(sfx)" transformations="translations">-<group>-<path fill="sym-fill">--0.5 -0.5 m-0.5 -0.5 l-0.5 0.5 l--0.5 0.5 l-h-</path>-<path fill="sym-stroke" fillrule="eofill">--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-</path>-</group>-</symbol>-<symbol name="mark/cross(sx)" transformations="translations">-<group>-<path fill="sym-stroke">--0.43 -0.57 m-0.57 0.43 l-0.43 0.57 l--0.57 -0.43 l-h-</path>-<path fill="sym-stroke">--0.43 0.57 m-0.57 -0.43 l-0.43 -0.57 l--0.57 0.43 l-h-</path>-</group>-</symbol>-<symbol name="arrow/fnormal(spx)">-<path stroke="sym-stroke" fill="white" pen="sym-pen">-0 0 m--1 0.333 l--1 -0.333 l-h-</path>-</symbol>-<symbol name="arrow/pointed(spx)">-<path stroke="sym-stroke" fill="sym-stroke" pen="sym-pen">-0 0 m--1 0.333 l--0.8 0 l--1 -0.333 l-h-</path>-</symbol>-<symbol name="arrow/fpointed(spx)">-<path stroke="sym-stroke" fill="white" pen="sym-pen">-0 0 m--1 0.333 l--0.8 0 l--1 -0.333 l-h-</path>-</symbol>-<symbol name="arrow/linear(spx)">-<path stroke="sym-stroke" pen="sym-pen">--1 0.333 m-0 0 l--1 -0.333 l-</path>-</symbol>-<symbol name="arrow/fdouble(spx)">-<path stroke="sym-stroke" fill="white" pen="sym-pen">-0 0 m--1 0.333 l--1 -0.333 l-h--1 0 m--2 0.333 l--2 -0.333 l-h-</path>-</symbol>-<symbol name="arrow/double(spx)">-<path stroke="sym-stroke" fill="sym-stroke" pen="sym-pen">-0 0 m--1 0.333 l--1 -0.333 l-h--1 0 m--2 0.333 l--2 -0.333 l-h-</path>-</symbol>-<pen name="heavier" value="0.8"/>-<pen name="fat" value="1.2"/>-<pen name="ultrafat" value="2"/>-<symbolsize name="large" value="5"/>-<symbolsize name="small" value="2"/>-<symbolsize name="tiny" value="1.1"/>-<arrowsize name="large" value="10"/>-<arrowsize name="small" value="5"/>-<arrowsize name="tiny" value="3"/>-<color name="red" value="1 0 0"/>-<color name="green" value="0 1 0"/>-<color name="blue" value="0 0 1"/>-<color name="yellow" value="1 1 0"/>-<color name="orange" value="1 0.647 0"/>-<color name="gold" value="1 0.843 0"/>-<color name="purple" value="0.627 0.125 0.941"/>-<color name="gray" value="0.745"/>-<color name="brown" value="0.647 0.165 0.165"/>-<color name="navy" value="0 0 0.502"/>-<color name="pink" value="1 0.753 0.796"/>-<color name="seagreen" value="0.18 0.545 0.341"/>-<color name="turquoise" value="0.251 0.878 0.816"/>-<color name="violet" value="0.933 0.51 0.933"/>-<color name="darkblue" value="0 0 0.545"/>-<color name="darkcyan" value="0 0.545 0.545"/>-<color name="darkgray" value="0.663"/>-<color name="darkgreen" value="0 0.392 0"/>-<color name="darkmagenta" value="0.545 0 0.545"/>-<color name="darkorange" value="1 0.549 0"/>-<color name="darkred" value="0.545 0 0"/>-<color name="lightblue" value="0.678 0.847 0.902"/>-<color name="lightcyan" value="0.878 1 1"/>-<color name="lightgray" value="0.827"/>-<color name="lightgreen" value="0.565 0.933 0.565"/>-<color name="lightyellow" value="1 1 0.878"/>-<dashstyle name="dashed" value="[4] 0"/>-<dashstyle name="dotted" value="[1 3] 0"/>-<dashstyle name="dash dotted" value="[4 2 1 2] 0"/>-<dashstyle name="dash dot dotted" value="[4 2 1 2 1 2] 0"/>-<textsize name="large" value="\large"/>-<textsize name="Large" value="\Large"/>-<textsize name="LARGE" value="\LARGE"/>-<textsize name="huge" value="\huge"/>-<textsize name="Huge" value="\Huge"/>-<textsize name="small" value="\small"/>-<textsize name="footnote" value="\footnotesize"/>-<textsize name="tiny" value="\tiny"/>-<textstyle name="center" begin="\begin{center}" end="\end{center}"/>-<textstyle name="itemize" begin="\begin{itemize}" end="\end{itemize}"/>-<textstyle name="item" begin="\begin{itemize}\item{}" end="\end{itemize}"/>-<gridsize name="4 pts" value="4"/>-<gridsize name="8 pts (~3 mm)" value="8"/>-<gridsize name="16 pts (~6 mm)" value="16"/>-<gridsize name="32 pts (~12 mm)" value="32"/>-<gridsize name="10 pts (~3.5 mm)" value="10"/>-<gridsize name="20 pts (~7 mm)" value="20"/>-<gridsize name="14 pts (~5 mm)" value="14"/>-<gridsize name="28 pts (~10 mm)" value="28"/>-<gridsize name="56 pts (~20 mm)" value="56"/>-<anglesize name="90 deg" value="90"/>-<anglesize name="60 deg" value="60"/>-<anglesize name="45 deg" value="45"/>-<anglesize name="30 deg" value="30"/>-<anglesize name="22.5 deg" value="22.5"/>-<opacity name="10%" value="0.1"/>-<opacity name="30%" value="0.3"/>-<opacity name="50%" value="0.5"/>-<opacity name="75%" value="0.75"/>-<tiling name="falling" angle="-60" step="4" width="1"/>-<tiling name="rising" angle="30" step="4" width="1"/>-</ipestyle>-<ipestyle name="frank">-<arrowsize name="normal" value="5"/>-<arrowsize name="large" value="8"/>-<arrowsize name="huge" value="10"/>-<arrowsize name="small" value="3"/>-<arrowsize name="tiny" value="1"/>-<dashstyle name="dashed" value="[2 2] 0"/>-<dashstyle name="dotted" value="[0.5 1] 0"/>-<dashstyle name="dash dotted" value="[4 2 1 2] 0"/>-<dashstyle name="dash dot dotted" value="[4 2 1 2 1 2] 0"/>-<gridsize name="1 pts" value="1"/>-<gridsize name="2 pts" value="2"/>-<opacity name="10%" value="0.1"/>-<opacity name="30%" value="0.3"/>-<opacity name="50%" value="0.5"/>-<opacity name="20%" value="0.2"/>-<opacity name="40%" value="0.4"/>-<opacity name="60%" value="0.6"/>-<opacity name="70%" value="0.7"/>-<opacity name="80%" value="0.8"/>-<opacity name="90%" value="0.9"/>-</ipestyle>-<page>-<layer name="alpha"/>-<view layers="alpha" active="alpha"/>-<path layer="alpha" stroke="red">-96 704 m-192 816 l-352 656 l-208 640 l-336 784 l-h-</path>-<path stroke="red">-144 592 m-336 624 l-320 544 l-240 624 l-h-</path>-<path stroke="blue">-80 624 m-32 576 l-128 576 l-h-</path>-<path stroke="blue">-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-</path>-</page>-</ipe>
− test/Algorithms/Geometry/LinearProgramming/manual.ipe 
@@ -1,370 +0,0 @@-<?xml version="1.0"?>-<!DOCTYPE ipe SYSTEM "ipe.dtd">-<ipe version="70206" creator="Ipe 7.2.7">-<info created="D:20190310094400" modified="D:20190310110316"/>-<ipestyle name="basic">-<symbol name="arrow/arc(spx)">-<path stroke="sym-stroke" fill="sym-stroke" pen="sym-pen">-0 0 m--1 0.333 l--1 -0.333 l-h-</path>-</symbol>-<symbol name="arrow/farc(spx)">-<path stroke="sym-stroke" fill="white" pen="sym-pen">-0 0 m--1 0.333 l--1 -0.333 l-h-</path>-</symbol>-<symbol name="arrow/ptarc(spx)">-<path stroke="sym-stroke" fill="sym-stroke" pen="sym-pen">-0 0 m--1 0.333 l--0.8 0 l--1 -0.333 l-h-</path>-</symbol>-<symbol name="arrow/fptarc(spx)">-<path stroke="sym-stroke" fill="white" pen="sym-pen">-0 0 m--1 0.333 l--0.8 0 l--1 -0.333 l-h-</path>-</symbol>-<symbol name="mark/circle(sx)" transformations="translations">-<path fill="sym-stroke">-0.6 0 0 0.6 0 0 e-0.4 0 0 0.4 0 0 e-</path>-</symbol>-<symbol name="mark/disk(sx)" transformations="translations">-<path fill="sym-stroke">-0.6 0 0 0.6 0 0 e-</path>-</symbol>-<symbol name="mark/fdisk(sfx)" transformations="translations">-<group>-<path fill="sym-fill">-0.5 0 0 0.5 0 0 e-</path>-<path fill="sym-stroke" fillrule="eofill">-0.6 0 0 0.6 0 0 e-0.4 0 0 0.4 0 0 e-</path>-</group>-</symbol>-<symbol name="mark/box(sx)" transformations="translations">-<path fill="sym-stroke" fillrule="eofill">--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-</path>-</symbol>-<symbol name="mark/square(sx)" transformations="translations">-<path fill="sym-stroke">--0.6 -0.6 m-0.6 -0.6 l-0.6 0.6 l--0.6 0.6 l-h-</path>-</symbol>-<symbol name="mark/fsquare(sfx)" transformations="translations">-<group>-<path fill="sym-fill">--0.5 -0.5 m-0.5 -0.5 l-0.5 0.5 l--0.5 0.5 l-h-</path>-<path fill="sym-stroke" fillrule="eofill">--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-</path>-</group>-</symbol>-<symbol name="mark/cross(sx)" transformations="translations">-<group>-<path fill="sym-stroke">--0.43 -0.57 m-0.57 0.43 l-0.43 0.57 l--0.57 -0.43 l-h-</path>-<path fill="sym-stroke">--0.43 0.57 m-0.57 -0.43 l-0.43 -0.57 l--0.57 0.43 l-h-</path>-</group>-</symbol>-<symbol name="arrow/fnormal(spx)">-<path stroke="sym-stroke" fill="white" pen="sym-pen">-0 0 m--1 0.333 l--1 -0.333 l-h-</path>-</symbol>-<symbol name="arrow/pointed(spx)">-<path stroke="sym-stroke" fill="sym-stroke" pen="sym-pen">-0 0 m--1 0.333 l--0.8 0 l--1 -0.333 l-h-</path>-</symbol>-<symbol name="arrow/fpointed(spx)">-<path stroke="sym-stroke" fill="white" pen="sym-pen">-0 0 m--1 0.333 l--0.8 0 l--1 -0.333 l-h-</path>-</symbol>-<symbol name="arrow/linear(spx)">-<path stroke="sym-stroke" pen="sym-pen">--1 0.333 m-0 0 l--1 -0.333 l-</path>-</symbol>-<symbol name="arrow/fdouble(spx)">-<path stroke="sym-stroke" fill="white" pen="sym-pen">-0 0 m--1 0.333 l--1 -0.333 l-h--1 0 m--2 0.333 l--2 -0.333 l-h-</path>-</symbol>-<symbol name="arrow/double(spx)">-<path stroke="sym-stroke" fill="sym-stroke" pen="sym-pen">-0 0 m--1 0.333 l--1 -0.333 l-h--1 0 m--2 0.333 l--2 -0.333 l-h-</path>-</symbol>-<pen name="heavier" value="0.8"/>-<pen name="fat" value="1.2"/>-<pen name="ultrafat" value="2"/>-<symbolsize name="large" value="5"/>-<symbolsize name="small" value="2"/>-<symbolsize name="tiny" value="1.1"/>-<arrowsize name="large" value="10"/>-<arrowsize name="small" value="5"/>-<arrowsize name="tiny" value="3"/>-<color name="red" value="1 0 0"/>-<color name="green" value="0 1 0"/>-<color name="blue" value="0 0 1"/>-<color name="yellow" value="1 1 0"/>-<color name="orange" value="1 0.647 0"/>-<color name="gold" value="1 0.843 0"/>-<color name="purple" value="0.627 0.125 0.941"/>-<color name="gray" value="0.745"/>-<color name="brown" value="0.647 0.165 0.165"/>-<color name="navy" value="0 0 0.502"/>-<color name="pink" value="1 0.753 0.796"/>-<color name="seagreen" value="0.18 0.545 0.341"/>-<color name="turquoise" value="0.251 0.878 0.816"/>-<color name="violet" value="0.933 0.51 0.933"/>-<color name="darkblue" value="0 0 0.545"/>-<color name="darkcyan" value="0 0.545 0.545"/>-<color name="darkgray" value="0.663"/>-<color name="darkgreen" value="0 0.392 0"/>-<color name="darkmagenta" value="0.545 0 0.545"/>-<color name="darkorange" value="1 0.549 0"/>-<color name="darkred" value="0.545 0 0"/>-<color name="lightblue" value="0.678 0.847 0.902"/>-<color name="lightcyan" value="0.878 1 1"/>-<color name="lightgray" value="0.827"/>-<color name="lightgreen" value="0.565 0.933 0.565"/>-<color name="lightyellow" value="1 1 0.878"/>-<dashstyle name="dashed" value="[4] 0"/>-<dashstyle name="dotted" value="[1 3] 0"/>-<dashstyle name="dash dotted" value="[4 2 1 2] 0"/>-<dashstyle name="dash dot dotted" value="[4 2 1 2 1 2] 0"/>-<textsize name="large" value="\large"/>-<textsize name="Large" value="\Large"/>-<textsize name="LARGE" value="\LARGE"/>-<textsize name="huge" value="\huge"/>-<textsize name="Huge" value="\Huge"/>-<textsize name="small" value="\small"/>-<textsize name="footnote" value="\footnotesize"/>-<textsize name="tiny" value="\tiny"/>-<textstyle name="center" begin="\begin{center}" end="\end{center}"/>-<textstyle name="itemize" begin="\begin{itemize}" end="\end{itemize}"/>-<textstyle name="item" begin="\begin{itemize}\item{}" end="\end{itemize}"/>-<gridsize name="4 pts" value="4"/>-<gridsize name="8 pts (~3 mm)" value="8"/>-<gridsize name="16 pts (~6 mm)" value="16"/>-<gridsize name="32 pts (~12 mm)" value="32"/>-<gridsize name="10 pts (~3.5 mm)" value="10"/>-<gridsize name="20 pts (~7 mm)" value="20"/>-<gridsize name="14 pts (~5 mm)" value="14"/>-<gridsize name="28 pts (~10 mm)" value="28"/>-<gridsize name="56 pts (~20 mm)" value="56"/>-<anglesize name="90 deg" value="90"/>-<anglesize name="60 deg" value="60"/>-<anglesize name="45 deg" value="45"/>-<anglesize name="30 deg" value="30"/>-<anglesize name="22.5 deg" value="22.5"/>-<opacity name="10%" value="0.1"/>-<opacity name="30%" value="0.3"/>-<opacity name="50%" value="0.5"/>-<opacity name="75%" value="0.75"/>-<tiling name="falling" angle="-60" step="4" width="1"/>-<tiling name="rising" angle="30" step="4" width="1"/>-</ipestyle>-<ipestyle name="frank">-<arrowsize name="normal" value="5"/>-<arrowsize name="large" value="8"/>-<arrowsize name="huge" value="10"/>-<arrowsize name="small" value="3"/>-<arrowsize name="tiny" value="1"/>-<dashstyle name="dashed" value="[2 2] 0"/>-<dashstyle name="dotted" value="[0.5 1] 0"/>-<dashstyle name="dash dotted" value="[4 2 1 2] 0"/>-<dashstyle name="dash dot dotted" value="[4 2 1 2 1 2] 0"/>-<gridsize name="1 pts" value="1"/>-<gridsize name="2 pts" value="2"/>-<opacity name="10%" value="0.1"/>-<opacity name="30%" value="0.3"/>-<opacity name="50%" value="0.5"/>-<opacity name="20%" value="0.2"/>-<opacity name="40%" value="0.4"/>-<opacity name="60%" value="0.6"/>-<opacity name="70%" value="0.7"/>-<opacity name="80%" value="0.8"/>-<opacity name="90%" value="0.9"/>-</ipestyle>-<page>-<layer name="alpha"/>-<view layers="alpha" active="alpha"/>-<path layer="alpha" stroke="blue">-80 512 m-496 688 l-</path>-<path stroke="blue">-32 656 m-400 496 l-</path>-<path stroke="blue">-192 512 m-512 592 l-</path>-<path stroke="blue">-80 544 m-448 512 l-</path>-<path stroke="red">-48 608 m-400 768 l-</path>-<path stroke="red">-64 784 m-512 672 l-</path>-<path stroke="red">-64 720 m-560 688 l-</path>-<use name="mark/disk(sx)" pos="223.532 572.725" size="normal" stroke="black"/>-</page>-<page>-<layer name="alpha"/>-<view layers="alpha" active="alpha"/>-<path layer="alpha" matrix="2.40555 0 0 2.40555 -64.8028 -863.829" stroke="red">-46.1048 614.582 m-429.2 688.899 l-</path>-<path matrix="2.32631 0 0 2.32631 -54.964 -984.057" stroke="blue">-41.4414 741.953 m-423.596 711.062 l-</path>-<path stroke="red">-121.985 842 m-859.993 369.865 l-</path>-</page>-<page>-<layer name="alpha"/>-<view layers="alpha" active="alpha"/>-<path layer="alpha" stroke="red">-22.6642 533.532 m-595 760.836 l-</path>-<path stroke="red">-0 803.856 m-595 555.084 l-</path>-<path stroke="red">--29.9681 598.468 m-794.006 675.181 l-</path>-<path stroke="red">-411.476 809.515 m-595 311.453 l-</path>-<path stroke="red">-0 382.909 m-437.853 1024.64 l-</path>-<path stroke="blue">--16.5606 862.606 m-411.101 433.915 l-</path>-<path stroke="blue">-95.0642 522.237 m-857.65 676.395 l-</path>-<path stroke="blue">-277.375 460.704 m-642.518 950.636 l-</path>-<path stroke="blue">-450.168 450.864 m-868.112 754.196 l-</path>-<path stroke="blue">-28.6395 500.773 m-594.217 555.411 l-</path>-<use name="mark/disk(sx)" pos="284.74 560.58" size="normal" stroke="blue"/>-</page>-</ipe>
− test/Algorithms/Geometry/LowerEnvelope/manual.ipe 
@@ -1,299 +0,0 @@-<?xml version="1.0"?>-<!DOCTYPE ipe SYSTEM "ipe.dtd">-<ipe version="70107" creator="Ipe 7.2.2">-<info created="D:20170715125328" modified="D:20170715125434"/>-<ipestyle name="basic">-<symbol name="arrow/arc(spx)">-<path stroke="sym-stroke" fill="sym-stroke" pen="sym-pen">-0 0 m--1 0.333 l--1 -0.333 l-h-</path>-</symbol>-<symbol name="arrow/farc(spx)">-<path stroke="sym-stroke" fill="white" pen="sym-pen">-0 0 m--1 0.333 l--1 -0.333 l-h-</path>-</symbol>-<symbol name="arrow/ptarc(spx)">-<path stroke="sym-stroke" fill="sym-stroke" pen="sym-pen">-0 0 m--1 0.333 l--0.8 0 l--1 -0.333 l-h-</path>-</symbol>-<symbol name="arrow/fptarc(spx)">-<path stroke="sym-stroke" fill="white" pen="sym-pen">-0 0 m--1 0.333 l--0.8 0 l--1 -0.333 l-h-</path>-</symbol>-<symbol name="mark/circle(sx)" transformations="translations">-<path fill="sym-stroke">-0.6 0 0 0.6 0 0 e-0.4 0 0 0.4 0 0 e-</path>-</symbol>-<symbol name="mark/disk(sx)" transformations="translations">-<path fill="sym-stroke">-0.6 0 0 0.6 0 0 e-</path>-</symbol>-<symbol name="mark/fdisk(sfx)" transformations="translations">-<group>-<path fill="sym-fill">-0.5 0 0 0.5 0 0 e-</path>-<path fill="sym-stroke" fillrule="eofill">-0.6 0 0 0.6 0 0 e-0.4 0 0 0.4 0 0 e-</path>-</group>-</symbol>-<symbol name="mark/box(sx)" transformations="translations">-<path fill="sym-stroke" fillrule="eofill">--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-</path>-</symbol>-<symbol name="mark/square(sx)" transformations="translations">-<path fill="sym-stroke">--0.6 -0.6 m-0.6 -0.6 l-0.6 0.6 l--0.6 0.6 l-h-</path>-</symbol>-<symbol name="mark/fsquare(sfx)" transformations="translations">-<group>-<path fill="sym-fill">--0.5 -0.5 m-0.5 -0.5 l-0.5 0.5 l--0.5 0.5 l-h-</path>-<path fill="sym-stroke" fillrule="eofill">--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-</path>-</group>-</symbol>-<symbol name="mark/cross(sx)" transformations="translations">-<group>-<path fill="sym-stroke">--0.43 -0.57 m-0.57 0.43 l-0.43 0.57 l--0.57 -0.43 l-h-</path>-<path fill="sym-stroke">--0.43 0.57 m-0.57 -0.43 l-0.43 -0.57 l--0.57 0.43 l-h-</path>-</group>-</symbol>-<symbol name="arrow/fnormal(spx)">-<path stroke="sym-stroke" fill="white" pen="sym-pen">-0 0 m--1 0.333 l--1 -0.333 l-h-</path>-</symbol>-<symbol name="arrow/pointed(spx)">-<path stroke="sym-stroke" fill="sym-stroke" pen="sym-pen">-0 0 m--1 0.333 l--0.8 0 l--1 -0.333 l-h-</path>-</symbol>-<symbol name="arrow/fpointed(spx)">-<path stroke="sym-stroke" fill="white" pen="sym-pen">-0 0 m--1 0.333 l--0.8 0 l--1 -0.333 l-h-</path>-</symbol>-<symbol name="arrow/linear(spx)">-<path stroke="sym-stroke" pen="sym-pen">--1 0.333 m-0 0 l--1 -0.333 l-</path>-</symbol>-<symbol name="arrow/fdouble(spx)">-<path stroke="sym-stroke" fill="white" pen="sym-pen">-0 0 m--1 0.333 l--1 -0.333 l-h--1 0 m--2 0.333 l--2 -0.333 l-h-</path>-</symbol>-<symbol name="arrow/double(spx)">-<path stroke="sym-stroke" fill="sym-stroke" pen="sym-pen">-0 0 m--1 0.333 l--1 -0.333 l-h--1 0 m--2 0.333 l--2 -0.333 l-h-</path>-</symbol>-<pen name="heavier" value="0.8"/>-<pen name="fat" value="1.2"/>-<pen name="ultrafat" value="2"/>-<symbolsize name="large" value="5"/>-<symbolsize name="small" value="2"/>-<symbolsize name="tiny" value="1.1"/>-<arrowsize name="large" value="10"/>-<arrowsize name="small" value="5"/>-<arrowsize name="tiny" value="3"/>-<color name="red" value="1 0 0"/>-<color name="green" value="0 1 0"/>-<color name="blue" value="0 0 1"/>-<color name="yellow" value="1 1 0"/>-<color name="orange" value="1 0.647 0"/>-<color name="gold" value="1 0.843 0"/>-<color name="purple" value="0.627 0.125 0.941"/>-<color name="gray" value="0.745"/>-<color name="brown" value="0.647 0.165 0.165"/>-<color name="navy" value="0 0 0.502"/>-<color name="pink" value="1 0.753 0.796"/>-<color name="seagreen" value="0.18 0.545 0.341"/>-<color name="turquoise" value="0.251 0.878 0.816"/>-<color name="violet" value="0.933 0.51 0.933"/>-<color name="darkblue" value="0 0 0.545"/>-<color name="darkcyan" value="0 0.545 0.545"/>-<color name="darkgray" value="0.663"/>-<color name="darkgreen" value="0 0.392 0"/>-<color name="darkmagenta" value="0.545 0 0.545"/>-<color name="darkorange" value="1 0.549 0"/>-<color name="darkred" value="0.545 0 0"/>-<color name="lightblue" value="0.678 0.847 0.902"/>-<color name="lightcyan" value="0.878 1 1"/>-<color name="lightgray" value="0.827"/>-<color name="lightgreen" value="0.565 0.933 0.565"/>-<color name="lightyellow" value="1 1 0.878"/>-<dashstyle name="dashed" value="[4] 0"/>-<dashstyle name="dotted" value="[1 3] 0"/>-<dashstyle name="dash dotted" value="[4 2 1 2] 0"/>-<dashstyle name="dash dot dotted" value="[4 2 1 2 1 2] 0"/>-<textsize name="large" value="\large"/>-<textsize name="Large" value="\Large"/>-<textsize name="LARGE" value="\LARGE"/>-<textsize name="huge" value="\huge"/>-<textsize name="Huge" value="\Huge"/>-<textsize name="small" value="\small"/>-<textsize name="footnote" value="\footnotesize"/>-<textsize name="tiny" value="\tiny"/>-<textstyle name="center" begin="\begin{center}" end="\end{center}"/>-<textstyle name="itemize" begin="\begin{itemize}" end="\end{itemize}"/>-<textstyle name="item" begin="\begin{itemize}\item{}" end="\end{itemize}"/>-<gridsize name="4 pts" value="4"/>-<gridsize name="8 pts (~3 mm)" value="8"/>-<gridsize name="16 pts (~6 mm)" value="16"/>-<gridsize name="32 pts (~12 mm)" value="32"/>-<gridsize name="10 pts (~3.5 mm)" value="10"/>-<gridsize name="20 pts (~7 mm)" value="20"/>-<gridsize name="14 pts (~5 mm)" value="14"/>-<gridsize name="28 pts (~10 mm)" value="28"/>-<gridsize name="56 pts (~20 mm)" value="56"/>-<anglesize name="90 deg" value="90"/>-<anglesize name="60 deg" value="60"/>-<anglesize name="45 deg" value="45"/>-<anglesize name="30 deg" value="30"/>-<anglesize name="22.5 deg" value="22.5"/>-<opacity name="10%" value="0.1"/>-<opacity name="30%" value="0.3"/>-<opacity name="50%" value="0.5"/>-<opacity name="75%" value="0.75"/>-<tiling name="falling" angle="-60" step="4" width="1"/>-<tiling name="rising" angle="30" step="4" width="1"/>-</ipestyle>-<ipestyle name="frank">-<arrowsize name="normal" value="5"/>-<arrowsize name="large" value="8"/>-<arrowsize name="huge" value="10"/>-<arrowsize name="small" value="3"/>-<arrowsize name="tiny" value="1"/>-<dashstyle name="dashed" value="[2 2] 0"/>-<dashstyle name="dotted" value="[0.5 1] 0"/>-<dashstyle name="dash dotted" value="[4 2 1 2] 0"/>-<dashstyle name="dash dot dotted" value="[4 2 1 2 1 2] 0"/>-<gridsize name="1 pts" value="1"/>-<gridsize name="2 pts" value="2"/>-<opacity name="10%" value="0.1"/>-<opacity name="30%" value="0.3"/>-<opacity name="50%" value="0.5"/>-<opacity name="20%" value="0.2"/>-<opacity name="40%" value="0.4"/>-<opacity name="60%" value="0.6"/>-<opacity name="70%" value="0.7"/>-<opacity name="80%" value="0.8"/>-<opacity name="90%" value="0.9"/>-</ipestyle>-<page>-<layer name="alpha"/>-<view layers="alpha" active="alpha"/>-<path layer="alpha" stroke="black">-80 496 m-304 624 l-</path>-<path stroke="black">-320 512 m-176 624 l-</path>-<path stroke="black">-80 560 m-368 560 l-</path>-<path stroke="black">-80 512 m-320 608 l-</path>-<use name="mark/disk(sx)" pos="173.333 549.333" size="normal" stroke="black"/>-<use name="mark/disk(sx)" pos="200 560" size="normal" stroke="black"/>-<use name="mark/disk(sx)" pos="258.286 560" size="normal" stroke="black"/>-</page>-</ipe>
− test/Algorithms/Geometry/PolygonTriangulation/monotone.ipe 
@@ -1,364 +0,0 @@-<?xml version="1.0"?>-<!DOCTYPE ipe SYSTEM "ipe.dtd">-<ipe version="70107" creator="Ipe 7.2.2">-<info created="D:20170207224641" modified="D:20180526104709"/>-<ipestyle name="basic">-<symbol name="arrow/arc(spx)">-<path stroke="sym-stroke" fill="sym-stroke" pen="sym-pen">-0 0 m--1 0.333 l--1 -0.333 l-h-</path>-</symbol>-<symbol name="arrow/farc(spx)">-<path stroke="sym-stroke" fill="white" pen="sym-pen">-0 0 m--1 0.333 l--1 -0.333 l-h-</path>-</symbol>-<symbol name="arrow/ptarc(spx)">-<path stroke="sym-stroke" fill="sym-stroke" pen="sym-pen">-0 0 m--1 0.333 l--0.8 0 l--1 -0.333 l-h-</path>-</symbol>-<symbol name="arrow/fptarc(spx)">-<path stroke="sym-stroke" fill="white" pen="sym-pen">-0 0 m--1 0.333 l--0.8 0 l--1 -0.333 l-h-</path>-</symbol>-<symbol name="mark/circle(sx)" transformations="translations">-<path fill="sym-stroke">-0.6 0 0 0.6 0 0 e-0.4 0 0 0.4 0 0 e-</path>-</symbol>-<symbol name="mark/disk(sx)" transformations="translations">-<path fill="sym-stroke">-0.6 0 0 0.6 0 0 e-</path>-</symbol>-<symbol name="mark/fdisk(sfx)" transformations="translations">-<group>-<path fill="sym-fill">-0.5 0 0 0.5 0 0 e-</path>-<path fill="sym-stroke" fillrule="eofill">-0.6 0 0 0.6 0 0 e-0.4 0 0 0.4 0 0 e-</path>-</group>-</symbol>-<symbol name="mark/box(sx)" transformations="translations">-<path fill="sym-stroke" fillrule="eofill">--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-</path>-</symbol>-<symbol name="mark/square(sx)" transformations="translations">-<path fill="sym-stroke">--0.6 -0.6 m-0.6 -0.6 l-0.6 0.6 l--0.6 0.6 l-h-</path>-</symbol>-<symbol name="mark/fsquare(sfx)" transformations="translations">-<group>-<path fill="sym-fill">--0.5 -0.5 m-0.5 -0.5 l-0.5 0.5 l--0.5 0.5 l-h-</path>-<path fill="sym-stroke" fillrule="eofill">--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-</path>-</group>-</symbol>-<symbol name="mark/cross(sx)" transformations="translations">-<group>-<path fill="sym-stroke">--0.43 -0.57 m-0.57 0.43 l-0.43 0.57 l--0.57 -0.43 l-h-</path>-<path fill="sym-stroke">--0.43 0.57 m-0.57 -0.43 l-0.43 -0.57 l--0.57 0.43 l-h-</path>-</group>-</symbol>-<symbol name="arrow/fnormal(spx)">-<path stroke="sym-stroke" fill="white" pen="sym-pen">-0 0 m--1 0.333 l--1 -0.333 l-h-</path>-</symbol>-<symbol name="arrow/pointed(spx)">-<path stroke="sym-stroke" fill="sym-stroke" pen="sym-pen">-0 0 m--1 0.333 l--0.8 0 l--1 -0.333 l-h-</path>-</symbol>-<symbol name="arrow/fpointed(spx)">-<path stroke="sym-stroke" fill="white" pen="sym-pen">-0 0 m--1 0.333 l--0.8 0 l--1 -0.333 l-h-</path>-</symbol>-<symbol name="arrow/linear(spx)">-<path stroke="sym-stroke" pen="sym-pen">--1 0.333 m-0 0 l--1 -0.333 l-</path>-</symbol>-<symbol name="arrow/fdouble(spx)">-<path stroke="sym-stroke" fill="white" pen="sym-pen">-0 0 m--1 0.333 l--1 -0.333 l-h--1 0 m--2 0.333 l--2 -0.333 l-h-</path>-</symbol>-<symbol name="arrow/double(spx)">-<path stroke="sym-stroke" fill="sym-stroke" pen="sym-pen">-0 0 m--1 0.333 l--1 -0.333 l-h--1 0 m--2 0.333 l--2 -0.333 l-h-</path>-</symbol>-<pen name="heavier" value="0.8"/>-<pen name="fat" value="1.2"/>-<pen name="ultrafat" value="2"/>-<symbolsize name="large" value="5"/>-<symbolsize name="small" value="2"/>-<symbolsize name="tiny" value="1.1"/>-<arrowsize name="large" value="10"/>-<arrowsize name="small" value="5"/>-<arrowsize name="tiny" value="3"/>-<color name="red" value="1 0 0"/>-<color name="green" value="0 1 0"/>-<color name="blue" value="0 0 1"/>-<color name="yellow" value="1 1 0"/>-<color name="orange" value="1 0.647 0"/>-<color name="gold" value="1 0.843 0"/>-<color name="purple" value="0.627 0.125 0.941"/>-<color name="gray" value="0.745"/>-<color name="brown" value="0.647 0.165 0.165"/>-<color name="navy" value="0 0 0.502"/>-<color name="pink" value="1 0.753 0.796"/>-<color name="seagreen" value="0.18 0.545 0.341"/>-<color name="turquoise" value="0.251 0.878 0.816"/>-<color name="violet" value="0.933 0.51 0.933"/>-<color name="darkblue" value="0 0 0.545"/>-<color name="darkcyan" value="0 0.545 0.545"/>-<color name="darkgray" value="0.663"/>-<color name="darkgreen" value="0 0.392 0"/>-<color name="darkmagenta" value="0.545 0 0.545"/>-<color name="darkorange" value="1 0.549 0"/>-<color name="darkred" value="0.545 0 0"/>-<color name="lightblue" value="0.678 0.847 0.902"/>-<color name="lightcyan" value="0.878 1 1"/>-<color name="lightgray" value="0.827"/>-<color name="lightgreen" value="0.565 0.933 0.565"/>-<color name="lightyellow" value="1 1 0.878"/>-<dashstyle name="dashed" value="[4] 0"/>-<dashstyle name="dotted" value="[1 3] 0"/>-<dashstyle name="dash dotted" value="[4 2 1 2] 0"/>-<dashstyle name="dash dot dotted" value="[4 2 1 2 1 2] 0"/>-<textsize name="large" value="\large"/>-<textsize name="Large" value="\Large"/>-<textsize name="LARGE" value="\LARGE"/>-<textsize name="huge" value="\huge"/>-<textsize name="Huge" value="\Huge"/>-<textsize name="small" value="\small"/>-<textsize name="footnote" value="\footnotesize"/>-<textsize name="tiny" value="\tiny"/>-<textstyle name="center" begin="\begin{center}" end="\end{center}"/>-<textstyle name="itemize" begin="\begin{itemize}" end="\end{itemize}"/>-<textstyle name="item" begin="\begin{itemize}\item{}" end="\end{itemize}"/>-<gridsize name="4 pts" value="4"/>-<gridsize name="8 pts (~3 mm)" value="8"/>-<gridsize name="16 pts (~6 mm)" value="16"/>-<gridsize name="32 pts (~12 mm)" value="32"/>-<gridsize name="10 pts (~3.5 mm)" value="10"/>-<gridsize name="20 pts (~7 mm)" value="20"/>-<gridsize name="14 pts (~5 mm)" value="14"/>-<gridsize name="28 pts (~10 mm)" value="28"/>-<gridsize name="56 pts (~20 mm)" value="56"/>-<anglesize name="90 deg" value="90"/>-<anglesize name="60 deg" value="60"/>-<anglesize name="45 deg" value="45"/>-<anglesize name="30 deg" value="30"/>-<anglesize name="22.5 deg" value="22.5"/>-<opacity name="10%" value="0.1"/>-<opacity name="30%" value="0.3"/>-<opacity name="50%" value="0.5"/>-<opacity name="75%" value="0.75"/>-<tiling name="falling" angle="-60" step="4" width="1"/>-<tiling name="rising" angle="30" step="4" width="1"/>-</ipestyle>-<ipestyle name="frank">-<arrowsize name="normal" value="5"/>-<arrowsize name="large" value="8"/>-<arrowsize name="huge" value="10"/>-<arrowsize name="small" value="3"/>-<arrowsize name="tiny" value="1"/>-<dashstyle name="dashed" value="[2 2] 0"/>-<dashstyle name="dotted" value="[0.5 1] 0"/>-<dashstyle name="dash dotted" value="[4 2 1 2] 0"/>-<dashstyle name="dash dot dotted" value="[4 2 1 2 1 2] 0"/>-<gridsize name="1 pts" value="1"/>-<gridsize name="2 pts" value="2"/>-<opacity name="10%" value="0.1"/>-<opacity name="30%" value="0.3"/>-<opacity name="50%" value="0.5"/>-<opacity name="20%" value="0.2"/>-<opacity name="40%" value="0.4"/>-<opacity name="60%" value="0.6"/>-<opacity name="70%" value="0.7"/>-<opacity name="80%" value="0.8"/>-<opacity name="90%" value="0.9"/>-</ipestyle>-<page>-<layer name="alpha"/>-<view layers="alpha" active="alpha"/>-<path layer="alpha" stroke="black">-176 736 m-240 688 l-240 608 l-128 576 l-64 640 l-80 720 l-128 752 l-h-</path>-<path stroke="black">-240 608 m-64 640 l-</path>-<path stroke="black">-64 640 m-240 688 l-</path>-<path stroke="black">-240 688 m-80 720 l-</path>-<path stroke="black">-80 720 m-176 736 l-</path>-<path matrix="1 0 0 1 32 96" stroke="red">-160 384 m-352 384 l-128 176 l-224 320 l-48 400 l-h-</path>-<path stroke="red">-384 480 m-256 416 l-</path>-<path stroke="red">-256 416 m-192 480 l-</path>-<path matrix="1 0 0 1 208 320" stroke="green">-320 320 m-256 320 l-224 320 l-128 240 l-64 224 l-256 192 l-h-</path>-<path matrix="1 0 0 1 208 320" stroke="green">-256 320 m-128 240 l-</path>-<path matrix="1 0 0 1 208 320" stroke="green">-128 240 m-320 320 l-</path>-<path matrix="1 0 0 1 208 320" stroke="green">-256 192 m-128 240 l-</path>-<path matrix="-1 0 -0 -1 592 400" stroke="violet">-320 320 m-256 320 l-224 320 l-128 240 l-64 224 l-256 192 l-h-</path>-<path stroke="violet">-464 160 m-336 208 l-</path>-<path stroke="violet">-336 80 m-336 208 l-</path>-<path stroke="violet">-368 80 m-336 208 l-</path>-</page>-</ipe>
− test/Algorithms/Geometry/PolygonTriangulation/simplepolygon6.ipe 
@@ -1,297 +0,0 @@-<?xml version="1.0"?>-<!DOCTYPE ipe SYSTEM "ipe.dtd">-<ipe version="70107" creator="Ipe 7.2.2">-<info created="D:20180524200410" modified="D:20180524221410"/>-<ipestyle name="basic">-<symbol name="arrow/arc(spx)">-<path stroke="sym-stroke" fill="sym-stroke" pen="sym-pen">-0 0 m--1 0.333 l--1 -0.333 l-h-</path>-</symbol>-<symbol name="arrow/farc(spx)">-<path stroke="sym-stroke" fill="white" pen="sym-pen">-0 0 m--1 0.333 l--1 -0.333 l-h-</path>-</symbol>-<symbol name="arrow/ptarc(spx)">-<path stroke="sym-stroke" fill="sym-stroke" pen="sym-pen">-0 0 m--1 0.333 l--0.8 0 l--1 -0.333 l-h-</path>-</symbol>-<symbol name="arrow/fptarc(spx)">-<path stroke="sym-stroke" fill="white" pen="sym-pen">-0 0 m--1 0.333 l--0.8 0 l--1 -0.333 l-h-</path>-</symbol>-<symbol name="mark/circle(sx)" transformations="translations">-<path fill="sym-stroke">-0.6 0 0 0.6 0 0 e-0.4 0 0 0.4 0 0 e-</path>-</symbol>-<symbol name="mark/disk(sx)" transformations="translations">-<path fill="sym-stroke">-0.6 0 0 0.6 0 0 e-</path>-</symbol>-<symbol name="mark/fdisk(sfx)" transformations="translations">-<group>-<path fill="sym-fill">-0.5 0 0 0.5 0 0 e-</path>-<path fill="sym-stroke" fillrule="eofill">-0.6 0 0 0.6 0 0 e-0.4 0 0 0.4 0 0 e-</path>-</group>-</symbol>-<symbol name="mark/box(sx)" transformations="translations">-<path fill="sym-stroke" fillrule="eofill">--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-</path>-</symbol>-<symbol name="mark/square(sx)" transformations="translations">-<path fill="sym-stroke">--0.6 -0.6 m-0.6 -0.6 l-0.6 0.6 l--0.6 0.6 l-h-</path>-</symbol>-<symbol name="mark/fsquare(sfx)" transformations="translations">-<group>-<path fill="sym-fill">--0.5 -0.5 m-0.5 -0.5 l-0.5 0.5 l--0.5 0.5 l-h-</path>-<path fill="sym-stroke" fillrule="eofill">--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-</path>-</group>-</symbol>-<symbol name="mark/cross(sx)" transformations="translations">-<group>-<path fill="sym-stroke">--0.43 -0.57 m-0.57 0.43 l-0.43 0.57 l--0.57 -0.43 l-h-</path>-<path fill="sym-stroke">--0.43 0.57 m-0.57 -0.43 l-0.43 -0.57 l--0.57 0.43 l-h-</path>-</group>-</symbol>-<symbol name="arrow/fnormal(spx)">-<path stroke="sym-stroke" fill="white" pen="sym-pen">-0 0 m--1 0.333 l--1 -0.333 l-h-</path>-</symbol>-<symbol name="arrow/pointed(spx)">-<path stroke="sym-stroke" fill="sym-stroke" pen="sym-pen">-0 0 m--1 0.333 l--0.8 0 l--1 -0.333 l-h-</path>-</symbol>-<symbol name="arrow/fpointed(spx)">-<path stroke="sym-stroke" fill="white" pen="sym-pen">-0 0 m--1 0.333 l--0.8 0 l--1 -0.333 l-h-</path>-</symbol>-<symbol name="arrow/linear(spx)">-<path stroke="sym-stroke" pen="sym-pen">--1 0.333 m-0 0 l--1 -0.333 l-</path>-</symbol>-<symbol name="arrow/fdouble(spx)">-<path stroke="sym-stroke" fill="white" pen="sym-pen">-0 0 m--1 0.333 l--1 -0.333 l-h--1 0 m--2 0.333 l--2 -0.333 l-h-</path>-</symbol>-<symbol name="arrow/double(spx)">-<path stroke="sym-stroke" fill="sym-stroke" pen="sym-pen">-0 0 m--1 0.333 l--1 -0.333 l-h--1 0 m--2 0.333 l--2 -0.333 l-h-</path>-</symbol>-<pen name="heavier" value="0.8"/>-<pen name="fat" value="1.2"/>-<pen name="ultrafat" value="2"/>-<symbolsize name="large" value="5"/>-<symbolsize name="small" value="2"/>-<symbolsize name="tiny" value="1.1"/>-<arrowsize name="large" value="10"/>-<arrowsize name="small" value="5"/>-<arrowsize name="tiny" value="3"/>-<color name="red" value="1 0 0"/>-<color name="green" value="0 1 0"/>-<color name="blue" value="0 0 1"/>-<color name="yellow" value="1 1 0"/>-<color name="orange" value="1 0.647 0"/>-<color name="gold" value="1 0.843 0"/>-<color name="purple" value="0.627 0.125 0.941"/>-<color name="gray" value="0.745"/>-<color name="brown" value="0.647 0.165 0.165"/>-<color name="navy" value="0 0 0.502"/>-<color name="pink" value="1 0.753 0.796"/>-<color name="seagreen" value="0.18 0.545 0.341"/>-<color name="turquoise" value="0.251 0.878 0.816"/>-<color name="violet" value="0.933 0.51 0.933"/>-<color name="darkblue" value="0 0 0.545"/>-<color name="darkcyan" value="0 0.545 0.545"/>-<color name="darkgray" value="0.663"/>-<color name="darkgreen" value="0 0.392 0"/>-<color name="darkmagenta" value="0.545 0 0.545"/>-<color name="darkorange" value="1 0.549 0"/>-<color name="darkred" value="0.545 0 0"/>-<color name="lightblue" value="0.678 0.847 0.902"/>-<color name="lightcyan" value="0.878 1 1"/>-<color name="lightgray" value="0.827"/>-<color name="lightgreen" value="0.565 0.933 0.565"/>-<color name="lightyellow" value="1 1 0.878"/>-<dashstyle name="dashed" value="[4] 0"/>-<dashstyle name="dotted" value="[1 3] 0"/>-<dashstyle name="dash dotted" value="[4 2 1 2] 0"/>-<dashstyle name="dash dot dotted" value="[4 2 1 2 1 2] 0"/>-<textsize name="large" value="\large"/>-<textsize name="Large" value="\Large"/>-<textsize name="LARGE" value="\LARGE"/>-<textsize name="huge" value="\huge"/>-<textsize name="Huge" value="\Huge"/>-<textsize name="small" value="\small"/>-<textsize name="footnote" value="\footnotesize"/>-<textsize name="tiny" value="\tiny"/>-<textstyle name="center" begin="\begin{center}" end="\end{center}"/>-<textstyle name="itemize" begin="\begin{itemize}" end="\end{itemize}"/>-<textstyle name="item" begin="\begin{itemize}\item{}" end="\end{itemize}"/>-<gridsize name="4 pts" value="4"/>-<gridsize name="8 pts (~3 mm)" value="8"/>-<gridsize name="16 pts (~6 mm)" value="16"/>-<gridsize name="32 pts (~12 mm)" value="32"/>-<gridsize name="10 pts (~3.5 mm)" value="10"/>-<gridsize name="20 pts (~7 mm)" value="20"/>-<gridsize name="14 pts (~5 mm)" value="14"/>-<gridsize name="28 pts (~10 mm)" value="28"/>-<gridsize name="56 pts (~20 mm)" value="56"/>-<anglesize name="90 deg" value="90"/>-<anglesize name="60 deg" value="60"/>-<anglesize name="45 deg" value="45"/>-<anglesize name="30 deg" value="30"/>-<anglesize name="22.5 deg" value="22.5"/>-<opacity name="10%" value="0.1"/>-<opacity name="30%" value="0.3"/>-<opacity name="50%" value="0.5"/>-<opacity name="75%" value="0.75"/>-<tiling name="falling" angle="-60" step="4" width="1"/>-<tiling name="rising" angle="30" step="4" width="1"/>-</ipestyle>-<ipestyle name="frank">-<arrowsize name="normal" value="5"/>-<arrowsize name="large" value="8"/>-<arrowsize name="huge" value="10"/>-<arrowsize name="small" value="3"/>-<arrowsize name="tiny" value="1"/>-<dashstyle name="dashed" value="[2 2] 0"/>-<dashstyle name="dotted" value="[0.5 1] 0"/>-<dashstyle name="dash dotted" value="[4 2 1 2] 0"/>-<dashstyle name="dash dot dotted" value="[4 2 1 2 1 2] 0"/>-<gridsize name="1 pts" value="1"/>-<gridsize name="2 pts" value="2"/>-<opacity name="10%" value="0.1"/>-<opacity name="30%" value="0.3"/>-<opacity name="50%" value="0.5"/>-<opacity name="20%" value="0.2"/>-<opacity name="40%" value="0.4"/>-<opacity name="60%" value="0.6"/>-<opacity name="70%" value="0.7"/>-<opacity name="80%" value="0.8"/>-<opacity name="90%" value="0.9"/>-</ipestyle>-<page>-<layer name="alpha"/>-<layer name="beta"/>-<view layers="alpha beta" active="beta"/>-<path layer="alpha" stroke="black">-80 544 m-320 527 l-208 496 l-48 432 l-16 560 l-h-</path>-<path stroke="black">-80 544 m-208 496 l-</path>-<path layer="beta" stroke="black">-208 496 m-16 560 l-</path>-</page>-</ipe>
− test/Algorithms/Geometry/RedBlueSeparator/manual.ipe 
@@ -1,355 +0,0 @@-<?xml version="1.0"?>-<!DOCTYPE ipe SYSTEM "ipe.dtd">-<ipe version="70206" creator="Ipe 7.2.7">-<info created="D:20190316210045" modified="D:20190316234250"/>-<ipestyle name="basic">-<symbol name="arrow/arc(spx)">-<path stroke="sym-stroke" fill="sym-stroke" pen="sym-pen">-0 0 m--1 0.333 l--1 -0.333 l-h-</path>-</symbol>-<symbol name="arrow/farc(spx)">-<path stroke="sym-stroke" fill="white" pen="sym-pen">-0 0 m--1 0.333 l--1 -0.333 l-h-</path>-</symbol>-<symbol name="arrow/ptarc(spx)">-<path stroke="sym-stroke" fill="sym-stroke" pen="sym-pen">-0 0 m--1 0.333 l--0.8 0 l--1 -0.333 l-h-</path>-</symbol>-<symbol name="arrow/fptarc(spx)">-<path stroke="sym-stroke" fill="white" pen="sym-pen">-0 0 m--1 0.333 l--0.8 0 l--1 -0.333 l-h-</path>-</symbol>-<symbol name="mark/circle(sx)" transformations="translations">-<path fill="sym-stroke">-0.6 0 0 0.6 0 0 e-0.4 0 0 0.4 0 0 e-</path>-</symbol>-<symbol name="mark/disk(sx)" transformations="translations">-<path fill="sym-stroke">-0.6 0 0 0.6 0 0 e-</path>-</symbol>-<symbol name="mark/fdisk(sfx)" transformations="translations">-<group>-<path fill="sym-fill">-0.5 0 0 0.5 0 0 e-</path>-<path fill="sym-stroke" fillrule="eofill">-0.6 0 0 0.6 0 0 e-0.4 0 0 0.4 0 0 e-</path>-</group>-</symbol>-<symbol name="mark/box(sx)" transformations="translations">-<path fill="sym-stroke" fillrule="eofill">--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-</path>-</symbol>-<symbol name="mark/square(sx)" transformations="translations">-<path fill="sym-stroke">--0.6 -0.6 m-0.6 -0.6 l-0.6 0.6 l--0.6 0.6 l-h-</path>-</symbol>-<symbol name="mark/fsquare(sfx)" transformations="translations">-<group>-<path fill="sym-fill">--0.5 -0.5 m-0.5 -0.5 l-0.5 0.5 l--0.5 0.5 l-h-</path>-<path fill="sym-stroke" fillrule="eofill">--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-</path>-</group>-</symbol>-<symbol name="mark/cross(sx)" transformations="translations">-<group>-<path fill="sym-stroke">--0.43 -0.57 m-0.57 0.43 l-0.43 0.57 l--0.57 -0.43 l-h-</path>-<path fill="sym-stroke">--0.43 0.57 m-0.57 -0.43 l-0.43 -0.57 l--0.57 0.43 l-h-</path>-</group>-</symbol>-<symbol name="arrow/fnormal(spx)">-<path stroke="sym-stroke" fill="white" pen="sym-pen">-0 0 m--1 0.333 l--1 -0.333 l-h-</path>-</symbol>-<symbol name="arrow/pointed(spx)">-<path stroke="sym-stroke" fill="sym-stroke" pen="sym-pen">-0 0 m--1 0.333 l--0.8 0 l--1 -0.333 l-h-</path>-</symbol>-<symbol name="arrow/fpointed(spx)">-<path stroke="sym-stroke" fill="white" pen="sym-pen">-0 0 m--1 0.333 l--0.8 0 l--1 -0.333 l-h-</path>-</symbol>-<symbol name="arrow/linear(spx)">-<path stroke="sym-stroke" pen="sym-pen">--1 0.333 m-0 0 l--1 -0.333 l-</path>-</symbol>-<symbol name="arrow/fdouble(spx)">-<path stroke="sym-stroke" fill="white" pen="sym-pen">-0 0 m--1 0.333 l--1 -0.333 l-h--1 0 m--2 0.333 l--2 -0.333 l-h-</path>-</symbol>-<symbol name="arrow/double(spx)">-<path stroke="sym-stroke" fill="sym-stroke" pen="sym-pen">-0 0 m--1 0.333 l--1 -0.333 l-h--1 0 m--2 0.333 l--2 -0.333 l-h-</path>-</symbol>-<pen name="heavier" value="0.8"/>-<pen name="fat" value="1.2"/>-<pen name="ultrafat" value="2"/>-<symbolsize name="large" value="5"/>-<symbolsize name="small" value="2"/>-<symbolsize name="tiny" value="1.1"/>-<arrowsize name="large" value="10"/>-<arrowsize name="small" value="5"/>-<arrowsize name="tiny" value="3"/>-<color name="red" value="1 0 0"/>-<color name="green" value="0 1 0"/>-<color name="blue" value="0 0 1"/>-<color name="yellow" value="1 1 0"/>-<color name="orange" value="1 0.647 0"/>-<color name="gold" value="1 0.843 0"/>-<color name="purple" value="0.627 0.125 0.941"/>-<color name="gray" value="0.745"/>-<color name="brown" value="0.647 0.165 0.165"/>-<color name="navy" value="0 0 0.502"/>-<color name="pink" value="1 0.753 0.796"/>-<color name="seagreen" value="0.18 0.545 0.341"/>-<color name="turquoise" value="0.251 0.878 0.816"/>-<color name="violet" value="0.933 0.51 0.933"/>-<color name="darkblue" value="0 0 0.545"/>-<color name="darkcyan" value="0 0.545 0.545"/>-<color name="darkgray" value="0.663"/>-<color name="darkgreen" value="0 0.392 0"/>-<color name="darkmagenta" value="0.545 0 0.545"/>-<color name="darkorange" value="1 0.549 0"/>-<color name="darkred" value="0.545 0 0"/>-<color name="lightblue" value="0.678 0.847 0.902"/>-<color name="lightcyan" value="0.878 1 1"/>-<color name="lightgray" value="0.827"/>-<color name="lightgreen" value="0.565 0.933 0.565"/>-<color name="lightyellow" value="1 1 0.878"/>-<dashstyle name="dashed" value="[4] 0"/>-<dashstyle name="dotted" value="[1 3] 0"/>-<dashstyle name="dash dotted" value="[4 2 1 2] 0"/>-<dashstyle name="dash dot dotted" value="[4 2 1 2 1 2] 0"/>-<textsize name="large" value="\large"/>-<textsize name="Large" value="\Large"/>-<textsize name="LARGE" value="\LARGE"/>-<textsize name="huge" value="\huge"/>-<textsize name="Huge" value="\Huge"/>-<textsize name="small" value="\small"/>-<textsize name="footnote" value="\footnotesize"/>-<textsize name="tiny" value="\tiny"/>-<textstyle name="center" begin="\begin{center}" end="\end{center}"/>-<textstyle name="itemize" begin="\begin{itemize}" end="\end{itemize}"/>-<textstyle name="item" begin="\begin{itemize}\item{}" end="\end{itemize}"/>-<gridsize name="4 pts" value="4"/>-<gridsize name="8 pts (~3 mm)" value="8"/>-<gridsize name="16 pts (~6 mm)" value="16"/>-<gridsize name="32 pts (~12 mm)" value="32"/>-<gridsize name="10 pts (~3.5 mm)" value="10"/>-<gridsize name="20 pts (~7 mm)" value="20"/>-<gridsize name="14 pts (~5 mm)" value="14"/>-<gridsize name="28 pts (~10 mm)" value="28"/>-<gridsize name="56 pts (~20 mm)" value="56"/>-<anglesize name="90 deg" value="90"/>-<anglesize name="60 deg" value="60"/>-<anglesize name="45 deg" value="45"/>-<anglesize name="30 deg" value="30"/>-<anglesize name="22.5 deg" value="22.5"/>-<opacity name="10%" value="0.1"/>-<opacity name="30%" value="0.3"/>-<opacity name="50%" value="0.5"/>-<opacity name="75%" value="0.75"/>-<tiling name="falling" angle="-60" step="4" width="1"/>-<tiling name="rising" angle="30" step="4" width="1"/>-</ipestyle>-<ipestyle name="frank">-<arrowsize name="normal" value="5"/>-<arrowsize name="large" value="8"/>-<arrowsize name="huge" value="10"/>-<arrowsize name="small" value="3"/>-<arrowsize name="tiny" value="1"/>-<dashstyle name="dashed" value="[2 2] 0"/>-<dashstyle name="dotted" value="[0.5 1] 0"/>-<dashstyle name="dash dotted" value="[4 2 1 2] 0"/>-<dashstyle name="dash dot dotted" value="[4 2 1 2 1 2] 0"/>-<gridsize name="1 pts" value="1"/>-<gridsize name="2 pts" value="2"/>-<opacity name="10%" value="0.1"/>-<opacity name="30%" value="0.3"/>-<opacity name="50%" value="0.5"/>-<opacity name="20%" value="0.2"/>-<opacity name="40%" value="0.4"/>-<opacity name="60%" value="0.6"/>-<opacity name="70%" value="0.7"/>-<opacity name="80%" value="0.8"/>-<opacity name="90%" value="0.9"/>-</ipestyle>-<page>-<layer name="alpha"/>-<view layers="alpha" active="alpha"/>-<use layer="alpha" name="mark/disk(sx)" pos="176 688" size="normal" stroke="blue"/>-<use name="mark/disk(sx)" pos="224 672" size="normal" stroke="blue"/>-<use name="mark/disk(sx)" pos="160 656" size="normal" stroke="blue"/>-<use name="mark/disk(sx)" pos="208 624" size="normal" stroke="blue"/>-<use name="mark/disk(sx)" pos="400 688" size="normal" stroke="red"/>-<use name="mark/disk(sx)" pos="448 640" size="normal" stroke="red"/>-<use matrix="1 0 0 1 -43.6079 16.3284" name="mark/disk(sx)" pos="400 640" size="normal" stroke="red"/>-</page>-<page>-<layer name="alpha"/>-<view layers="alpha" active="alpha"/>-<use layer="alpha" name="mark/disk(sx)" pos="208 608" size="normal" stroke="red"/>-<use name="mark/disk(sx)" pos="224 640" size="normal" stroke="red"/>-<use matrix="1 0 0 1 0 1.54293" name="mark/disk(sx)" pos="288 608" size="normal" stroke="red"/>-<use matrix="1 0 0 1 21.7014 -12.8726" name="mark/disk(sx)" pos="224 608" size="normal" stroke="red"/>-<use name="mark/disk(sx)" pos="336 640" size="normal" stroke="red"/>-<use name="mark/disk(sx)" pos="320 688" size="normal" stroke="red"/>-<use name="mark/disk(sx)" pos="64 704" size="normal" stroke="blue"/>-<use name="mark/disk(sx)" pos="160 656" size="normal" stroke="blue"/>-<use name="mark/disk(sx)" pos="160 752" size="normal" stroke="blue"/>-<use name="mark/disk(sx)" pos="112 672" size="normal" stroke="blue"/>-<use name="mark/disk(sx)" pos="112 592" size="normal" stroke="blue"/>-<use name="mark/disk(sx)" pos="288 736" size="normal" stroke="blue"/>-</page>-<page>-<layer name="alpha"/>-<view layers="alpha" active="alpha"/>-<use layer="alpha" name="mark/cross(sx)" pos="137.831 733.813" size="normal" stroke="blue"/>-<use name="mark/cross(sx)" pos="230.904 721.563" size="normal" stroke="blue"/>-<use name="mark/cross(sx)" pos="150.255 624.633" size="normal" stroke="blue"/>-<use name="mark/cross(sx)" pos="85.1135 709.576" size="normal" stroke="blue"/>-<use name="mark/cross(sx)" pos="160.209 702.601" size="normal" stroke="blue"/>-<use name="mark/cross(sx)" pos="160.209 702.601" size="normal" stroke="blue"/>-<use name="mark/cross(sx)" pos="170.678 688.287" size="normal" stroke="blue"/>-<use name="mark/cross(sx)" pos="251.915 645.615" size="normal" stroke="blue"/>-<use name="mark/cross(sx)" pos="55.337 684.816" size="normal" stroke="blue"/>-<use name="mark/cross(sx)" pos="129.955 678.571" size="normal" stroke="blue"/>-<use name="mark/cross(sx)" pos="130.15 631.793" size="normal" stroke="blue"/>-<use name="mark/cross(sx)" pos="249.435 558.192" size="normal" stroke="blue"/>-<use name="mark/cross(sx)" pos="324.114 668.358" size="normal" stroke="blue"/>-<use name="mark/cross(sx)" pos="324.114 668.358" size="normal" stroke="blue"/>-<use name="mark/cross(sx)" pos="361.354 661.106" size="normal" stroke="blue"/>-<use name="mark/cross(sx)" pos="189.131 599.845" size="normal" stroke="blue"/>-<use name="mark/cross(sx)" pos="143.375 537.289" size="normal" stroke="blue"/>-<use name="mark/cross(sx)" pos="359.679 584.286" size="normal" stroke="red"/>-<use name="mark/cross(sx)" pos="396.828 627.4" size="normal" stroke="red"/>-<use name="mark/cross(sx)" pos="417.481 668.711" size="normal" stroke="red"/>-<use name="mark/cross(sx)" pos="467.45 598.096" size="normal" stroke="red"/>-<use matrix="1 0 0 1 -93.524 0.18083" name="mark/cross(sx)" pos="326.916 608.601" size="normal" stroke="red"/>-<use name="mark/cross(sx)" pos="338.842 545.777" size="normal" stroke="red"/>-<use name="mark/cross(sx)" pos="432.668 573.584" size="normal" stroke="red"/>-<use name="mark/cross(sx)" pos="357.521 629.624" size="normal" stroke="red"/>-<use name="mark/cross(sx)" pos="309.927 526.735" size="normal" stroke="red"/>-<use name="mark/cross(sx)" pos="417.855 527.98" size="normal" stroke="red"/>-<use name="mark/cross(sx)" pos="425.293 604.935" size="normal" stroke="red"/>-<use name="mark/cross(sx)" pos="482.54 641.657" size="normal" stroke="red"/>-</page>-<page>-<layer name="alpha"/>-<view layers="alpha" active="alpha"/>-<use layer="alpha" name="mark/disk(sx)" pos="71.295 646.994" size="normal" stroke="red"/>-<use name="mark/disk(sx)" pos="124.003 669.524" size="normal" stroke="red"/>-<use name="mark/disk(sx)" pos="158.117 593.965" size="normal" stroke="red"/>-<use name="mark/disk(sx)" pos="106.985 602.699" size="normal" stroke="red"/>-<use name="mark/disk(sx)" pos="130.801 646.957" size="normal" stroke="red"/>-<use name="mark/disk(sx)" pos="183.976 638.614" size="normal" stroke="red"/>-<use name="mark/disk(sx)" pos="268.842 528.238" size="normal" stroke="blue"/>-<use name="mark/disk(sx)" pos="303.35 581.718" size="normal" stroke="blue"/>-<use name="mark/disk(sx)" pos="353.58 636.762" size="normal" stroke="blue"/>-<use name="mark/disk(sx)" pos="288.989 633.613" size="normal" stroke="blue"/>-<use name="mark/disk(sx)" pos="325.76 613.53" size="normal" stroke="blue"/>-<use name="mark/disk(sx)" pos="337.81 597.8" size="normal" stroke="blue"/>-<use name="mark/disk(sx)" pos="245.135 580.319" size="normal" stroke="blue"/>-<use name="mark/disk(sx)" pos="168.779 515.317" size="normal" stroke="blue"/>-<use name="mark/disk(sx)" pos="116.706 526.039" size="normal" stroke="blue"/>-</page>-</ipe>
− test/Algorithms/Geometry/SmallestEnclosingDisk/manual.ipe 
@@ -1,369 +0,0 @@-<?xml version="1.0"?>-<!DOCTYPE ipe SYSTEM "ipe.dtd">-<ipe version="70107" creator="Ipe 7.1.7">-<info created="D:20151023214323" modified="D:20160123195914"/>-<ipestyle name="basic">-<symbol name="arrow/arc(spx)">-<path stroke="sym-stroke" fill="sym-stroke" pen="sym-pen">-0 0 m--1 0.333 l--1 -0.333 l-h-</path>-</symbol>-<symbol name="arrow/farc(spx)">-<path stroke="sym-stroke" fill="white" pen="sym-pen">-0 0 m--1 0.333 l--1 -0.333 l-h-</path>-</symbol>-<symbol name="arrow/ptarc(spx)">-<path stroke="sym-stroke" fill="sym-stroke" pen="sym-pen">-0 0 m--1 0.333 l--0.8 0 l--1 -0.333 l-h-</path>-</symbol>-<symbol name="arrow/fptarc(spx)">-<path stroke="sym-stroke" fill="white" pen="sym-pen">-0 0 m--1 0.333 l--0.8 0 l--1 -0.333 l-h-</path>-</symbol>-<symbol name="mark/circle(sx)" transformations="translations">-<path fill="sym-stroke">-0.6 0 0 0.6 0 0 e-0.4 0 0 0.4 0 0 e-</path>-</symbol>-<symbol name="mark/disk(sx)" transformations="translations">-<path fill="sym-stroke">-0.6 0 0 0.6 0 0 e-</path>-</symbol>-<symbol name="mark/fdisk(sfx)" transformations="translations">-<group>-<path fill="sym-fill">-0.5 0 0 0.5 0 0 e-</path>-<path fill="sym-stroke" fillrule="eofill">-0.6 0 0 0.6 0 0 e-0.4 0 0 0.4 0 0 e-</path>-</group>-</symbol>-<symbol name="mark/box(sx)" transformations="translations">-<path fill="sym-stroke" fillrule="eofill">--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-</path>-</symbol>-<symbol name="mark/square(sx)" transformations="translations">-<path fill="sym-stroke">--0.6 -0.6 m-0.6 -0.6 l-0.6 0.6 l--0.6 0.6 l-h-</path>-</symbol>-<symbol name="mark/fsquare(sfx)" transformations="translations">-<group>-<path fill="sym-fill">--0.5 -0.5 m-0.5 -0.5 l-0.5 0.5 l--0.5 0.5 l-h-</path>-<path fill="sym-stroke" fillrule="eofill">--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-</path>-</group>-</symbol>-<symbol name="mark/cross(sx)" transformations="translations">-<group>-<path fill="sym-stroke">--0.43 -0.57 m-0.57 0.43 l-0.43 0.57 l--0.57 -0.43 l-h-</path>-<path fill="sym-stroke">--0.43 0.57 m-0.57 -0.43 l-0.43 -0.57 l--0.57 0.43 l-h-</path>-</group>-</symbol>-<symbol name="arrow/fnormal(spx)">-<path stroke="sym-stroke" fill="white" pen="sym-pen">-0 0 m--1 0.333 l--1 -0.333 l-h-</path>-</symbol>-<symbol name="arrow/pointed(spx)">-<path stroke="sym-stroke" fill="sym-stroke" pen="sym-pen">-0 0 m--1 0.333 l--0.8 0 l--1 -0.333 l-h-</path>-</symbol>-<symbol name="arrow/fpointed(spx)">-<path stroke="sym-stroke" fill="white" pen="sym-pen">-0 0 m--1 0.333 l--0.8 0 l--1 -0.333 l-h-</path>-</symbol>-<symbol name="arrow/linear(spx)">-<path stroke="sym-stroke" pen="sym-pen">--1 0.333 m-0 0 l--1 -0.333 l-</path>-</symbol>-<symbol name="arrow/fdouble(spx)">-<path stroke="sym-stroke" fill="white" pen="sym-pen">-0 0 m--1 0.333 l--1 -0.333 l-h--1 0 m--2 0.333 l--2 -0.333 l-h-</path>-</symbol>-<symbol name="arrow/double(spx)">-<path stroke="sym-stroke" fill="sym-stroke" pen="sym-pen">-0 0 m--1 0.333 l--1 -0.333 l-h--1 0 m--2 0.333 l--2 -0.333 l-h-</path>-</symbol>-<pen name="heavier" value="0.8"/>-<pen name="fat" value="1.2"/>-<pen name="ultrafat" value="2"/>-<symbolsize name="large" value="5"/>-<symbolsize name="small" value="2"/>-<symbolsize name="tiny" value="1.1"/>-<arrowsize name="large" value="10"/>-<arrowsize name="small" value="5"/>-<arrowsize name="tiny" value="3"/>-<color name="red" value="1 0 0"/>-<color name="green" value="0 1 0"/>-<color name="blue" value="0 0 1"/>-<color name="yellow" value="1 1 0"/>-<color name="orange" value="1 0.647 0"/>-<color name="gold" value="1 0.843 0"/>-<color name="purple" value="0.627 0.125 0.941"/>-<color name="gray" value="0.745"/>-<color name="brown" value="0.647 0.165 0.165"/>-<color name="navy" value="0 0 0.502"/>-<color name="pink" value="1 0.753 0.796"/>-<color name="seagreen" value="0.18 0.545 0.341"/>-<color name="turquoise" value="0.251 0.878 0.816"/>-<color name="violet" value="0.933 0.51 0.933"/>-<color name="darkblue" value="0 0 0.545"/>-<color name="darkcyan" value="0 0.545 0.545"/>-<color name="darkgray" value="0.663"/>-<color name="darkgreen" value="0 0.392 0"/>-<color name="darkmagenta" value="0.545 0 0.545"/>-<color name="darkorange" value="1 0.549 0"/>-<color name="darkred" value="0.545 0 0"/>-<color name="lightblue" value="0.678 0.847 0.902"/>-<color name="lightcyan" value="0.878 1 1"/>-<color name="lightgray" value="0.827"/>-<color name="lightgreen" value="0.565 0.933 0.565"/>-<color name="lightyellow" value="1 1 0.878"/>-<dashstyle name="dashed" value="[4] 0"/>-<dashstyle name="dotted" value="[1 3] 0"/>-<dashstyle name="dash dotted" value="[4 2 1 2] 0"/>-<dashstyle name="dash dot dotted" value="[4 2 1 2 1 2] 0"/>-<textsize name="large" value="\large"/>-<textsize name="small" value="\small"/>-<textsize name="tiny" value="\tiny"/>-<textsize name="Large" value="\Large"/>-<textsize name="LARGE" value="\LARGE"/>-<textsize name="huge" value="\huge"/>-<textsize name="Huge" value="\Huge"/>-<textsize name="footnote" value="\footnotesize"/>-<textstyle name="center" begin="\begin{center}" end="\end{center}"/>-<textstyle name="itemize" begin="\begin{itemize}" end="\end{itemize}"/>-<textstyle name="item" begin="\begin{itemize}\item{}" end="\end{itemize}"/>-<gridsize name="4 pts" value="4"/>-<gridsize name="8 pts (~3 mm)" value="8"/>-<gridsize name="16 pts (~6 mm)" value="16"/>-<gridsize name="32 pts (~12 mm)" value="32"/>-<gridsize name="10 pts (~3.5 mm)" value="10"/>-<gridsize name="20 pts (~7 mm)" value="20"/>-<gridsize name="14 pts (~5 mm)" value="14"/>-<gridsize name="28 pts (~10 mm)" value="28"/>-<gridsize name="56 pts (~20 mm)" value="56"/>-<anglesize name="90 deg" value="90"/>-<anglesize name="60 deg" value="60"/>-<anglesize name="45 deg" value="45"/>-<anglesize name="30 deg" value="30"/>-<anglesize name="22.5 deg" value="22.5"/>-<tiling name="falling" angle="-60" step="4" width="1"/>-<tiling name="rising" angle="30" step="4" width="1"/>-</ipestyle>-<ipestyle name="frank">-<arrowsize name="normal" value="5"/>-<arrowsize name="large" value="8"/>-<arrowsize name="small" value="3"/>-<arrowsize name="tiny" value="1"/>-<arrowsize name="huge" value="10"/>-<dashstyle name="dashed" value="[2 2] 0"/>-<dashstyle name="dotted" value="[0.5 1] 0"/>-<dashstyle name="dash dotted" value="[4 2 1 2] 0"/>-<dashstyle name="dash dot dotted" value="[4 2 1 2 1 2] 0"/>-<gridsize name="1 pts" value="1"/>-<gridsize name="2 pts" value="2"/>-<opacity name="10%" value="0.1"/>-<opacity name="20%" value="0.2"/>-<opacity name="30%" value="0.3"/>-<opacity name="40%" value="0.4"/>-<opacity name="50%" value="0.5"/>-<opacity name="60%" value="0.6"/>-<opacity name="70%" value="0.7"/>-<opacity name="80%" value="0.8"/>-<opacity name="90%" value="0.9"/>-</ipestyle>-<page>-<layer name="alpha"/>-<layer name="beta"/>-<layer name="gamma"/>-<layer name="delta"/>-<view layers="alpha beta gamma delta" active="delta"/>-<use layer="alpha" name="mark/cross(sx)" pos="112 736" size="normal" stroke="black"/>-<use name="mark/cross(sx)" pos="336 640" size="normal" stroke="black"/>-<use name="mark/cross(sx)" pos="336 816" size="normal" stroke="black"/>-<use matrix="1 0 0 1 6.13784 -3.9059" name="mark/disk(sx)" pos="304 784" size="normal" stroke="black"/>-<use matrix="1 0 0 1 4.44908 -4.21815" name="mark/disk(sx)" pos="320 736" size="normal" stroke="black"/>-<use matrix="1 0 0 1 0.586099 6.64103" name="mark/disk(sx)" pos="352 736" size="normal" stroke="black"/>-<path stroke="black">-129.39 0 0 129.39 241.143 728 e-</path>-<use name="mark/disk(sx)" pos="264.671 689.288" size="normal" stroke="black"/>-<use name="mark/disk(sx)" pos="222.264 731.137" size="normal" stroke="black"/>-<use name="mark/disk(sx)" pos="289.78 722.767" size="normal" stroke="black"/>-<use name="mark/disk(sx)" pos="215.01 683.15" size="normal" stroke="black"/>-<use name="mark/disk(sx)" pos="197.154 741.181" size="normal" stroke="black"/>-<use name="mark/disk(sx)" pos="194.365 766.848" size="normal" stroke="black"/>-<use name="mark/disk(sx)" pos="230.076 767.406" size="normal" stroke="black"/>-<use name="mark/disk(sx)" pos="155.864 708.26" size="normal" stroke="black"/>-<use name="mark/disk(sx)" pos="238.445 743.413" size="normal" stroke="black"/>-<use name="mark/disk(sx)" pos="280.294 767.964" size="normal" stroke="black"/>-<use name="mark/disk(sx)" pos="274.715 659.157" size="normal" stroke="black"/>-<use name="mark/disk(sx)" pos="221.148 609.496" size="normal" stroke="black"/>-<use name="mark/disk(sx)" pos="310.984 638.512" size="normal" stroke="black"/>-<use name="mark/disk(sx)" pos="223.38 649.671" size="normal" stroke="black"/>-<use name="mark/disk(sx)" pos="169.813 689.846" size="normal" stroke="black"/>-<use name="mark/disk(sx)" pos="201.618 709.934" size="normal" stroke="black"/>-<use layer="beta" name="mark/disk(sx)" pos="368 608" size="normal" stroke="red"/>-<use matrix="1 0 0 1 2.78993 -9.48576" name="mark/disk(sx)" pos="336 608" size="normal" stroke="red"/>-<use name="mark/disk(sx)" pos="352 592" size="normal" stroke="red"/>-<use matrix="1 0 0 1 10.0437 -7.8118" name="mark/disk(sx)" pos="368 576" size="normal" stroke="red"/>-<use matrix="1 0 0 1 2.78993 1.11597" name="mark/disk(sx)" pos="320 576" size="normal" stroke="red"/>-<use matrix="1 0 0 1 -8.36979 -11.1597" name="mark/disk(sx)" pos="352 576" size="normal" stroke="red"/>-<use matrix="1 0 0 1 30.6892 -15.0656" name="mark/disk(sx)" pos="400 608" size="normal" stroke="red"/>-<use name="mark/disk(sx)" pos="400 576" size="normal" stroke="red"/>-<use name="mark/disk(sx)" pos="304 560" size="normal" stroke="red"/>-<use name="mark/disk(sx)" pos="368 544" size="normal" stroke="red"/>-<use name="mark/cross(sx)" pos="288.737 510.098" size="normal" stroke="red"/>-<use name="mark/disk(sx)" pos="379.689 503.96" size="normal" stroke="red"/>-<use name="mark/disk(sx)" pos="409.82 541.903" size="normal" stroke="red"/>-<use name="mark/disk(sx)" pos="363.507 541.345" size="normal" stroke="red"/>-<use name="mark/disk(sx)" pos="437.719 527.954" size="normal" stroke="red"/>-<use name="mark/cross(sx)" pos="476.778 591.564" size="normal" stroke="red"/>-<use name="mark/disk(sx)" pos="403.682 564.223" size="normal" stroke="red"/>-<use name="mark/disk(sx)" pos="409.82 562.549" size="normal" stroke="red"/>-<use name="mark/disk(sx)" pos="414.284 563.107" size="normal" stroke="red"/>-<use name="mark/disk(sx)" pos="462.271 545.809" size="normal" stroke="red"/>-<use name="mark/disk(sx)" pos="450.553 567.013" size="normal" stroke="red"/>-<use name="mark/disk(sx)" pos="343.978 524.606" size="normal" stroke="red"/>-<path stroke="red">-102.465 0 0 102.465 382.758 550.831 e-</path>-<use layer="gamma" matrix="1 0 0 1 6.60054 4.12708" name="mark/disk(sx)" pos="368 608" size="normal" stroke="blue"/>-<use matrix="1 0 0 1 9.39047 -5.35868" name="mark/disk(sx)" pos="336 608" size="normal" stroke="blue"/>-<use matrix="1 0 0 1 6.60054 4.12708" name="mark/disk(sx)" pos="352 592" size="normal" stroke="blue"/>-<use matrix="1 0 0 1 16.6443 -3.68472" name="mark/disk(sx)" pos="368 576" size="normal" stroke="blue"/>-<use matrix="1 0 0 1 9.39047 5.24305" name="mark/disk(sx)" pos="320 576" size="normal" stroke="blue"/>-<use matrix="1 0 0 1 -1.76925 -7.03264" name="mark/disk(sx)" pos="352 576" size="normal" stroke="blue"/>-<use matrix="1 0 0 1 37.2898 -10.9385" name="mark/disk(sx)" pos="400 608" size="normal" stroke="blue"/>-<use matrix="1 0 0 1 6.60054 4.12708" name="mark/disk(sx)" pos="400 576" size="normal" stroke="blue"/>-<use matrix="1 0 0 1 6.60054 4.12708" name="mark/disk(sx)" pos="304 560" size="normal" stroke="blue"/>-<use matrix="1 0 0 1 6.60054 4.12708" name="mark/disk(sx)" pos="368 544" size="normal" stroke="blue"/>-<use matrix="1 0 0 1 6.60054 4.12708" name="mark/disk(sx)" pos="379.689 503.96" size="normal" stroke="blue"/>-<use matrix="1 0 0 1 6.60054 4.12708" name="mark/disk(sx)" pos="409.82 541.903" size="normal" stroke="blue"/>-<use matrix="1 0 0 1 6.60054 4.12708" name="mark/disk(sx)" pos="363.507 541.345" size="normal" stroke="blue"/>-<use matrix="1 0 0 1 6.60054 4.12708" name="mark/disk(sx)" pos="437.719 527.954" size="normal" stroke="blue"/>-<use matrix="1 0 0 1 6.60054 4.12708" name="mark/disk(sx)" pos="403.682 564.223" size="normal" stroke="blue"/>-<use matrix="1 0 0 1 6.60054 4.12708" name="mark/disk(sx)" pos="409.82 562.549" size="normal" stroke="blue"/>-<use matrix="1 0 0 1 6.60054 4.12708" name="mark/disk(sx)" pos="414.284 563.107" size="normal" stroke="blue"/>-<use matrix="1 0 0 1 6.60054 4.12708" name="mark/disk(sx)" pos="462.271 545.809" size="normal" stroke="blue"/>-<use matrix="1 0 0 1 6.60054 4.12708" name="mark/disk(sx)" pos="450.553 567.013" size="normal" stroke="blue"/>-<use matrix="1 0 0 1 6.60054 4.12708" name="mark/disk(sx)" pos="343.978 524.606" size="normal" stroke="blue"/>-<use layer="delta" name="mark/disk(sx)" pos="71.4684 472.509" size="normal" stroke="blue"/>-<use name="mark/disk(sx)" pos="90.3283 458.001" size="normal" stroke="blue"/>-<use name="mark/disk(sx)" pos="75.0953 453.649" size="normal" stroke="blue"/>-<use name="mark/disk(sx)" pos="101.209 426.084" size="normal" stroke="blue"/>-<use name="mark/disk(sx)" pos="45.3547 421.732" size="normal" stroke="blue"/>-<use name="mark/disk(sx)" pos="76.5461 421.007" size="normal" stroke="blue"/>-<use name="mark/disk(sx)" pos="56.9608 430.437" size="normal" stroke="blue"/>-<use name="mark/disk(sx)" pos="85.2506 433.338" size="normal" stroke="blue"/>-<use name="mark/disk(sx)" pos="113.541 435.514" size="normal" stroke="blue"/>-<use name="mark/disk(sx)" pos="75.0953 453.649" size="normal" stroke="blue"/>-<use name="mark/disk(sx)" pos="46.8054 454.374" size="normal" stroke="blue"/>-<use matrix="1 0 0 1 39.896 -3.62691" name="mark/disk(sx)" pos="75.0953 453.649" size="normal" stroke="blue"/>-<use name="mark/disk(sx)" pos="105.561 473.96" size="normal" stroke="blue"/>-<use name="mark/disk(sx)" pos="107.012 458.727" size="normal" stroke="blue"/>-<use name="mark/disk(sx)" pos="135.302 418.105" size="normal" stroke="blue"/>-<use matrix="1 0 0 1 4.52803 -3.42357" name="mark/disk(sx)" pos="101.209 426.084" size="normal" stroke="blue"/>-<use name="mark/disk(sx)" pos="90.2821 422.711" size="normal" stroke="blue"/>-<use name="mark/disk(sx)" pos="118.434 461.101" size="normal" stroke="blue"/>-<use matrix="1 0 0 1 5.59154 0.698943" name="mark/disk(sx)" pos="57.5231 446.257" size="normal" stroke="blue"/>-<use name="mark/disk(sx)" pos="68.9116 432.574" size="normal" stroke="blue"/>-</page>-</ipe>
− test/Data/Geometry/Polygon/Convex/convexTests.ipe 
@@ -1,308 +0,0 @@-<?xml version="1.0"?>-<!DOCTYPE ipe SYSTEM "ipe.dtd">-<ipe version="70107" creator="Ipe 7.2.2">-<info created="D:20160608222645" modified="D:20160611094216"/>-<ipestyle name="basic">-<symbol name="arrow/arc(spx)">-<path stroke="sym-stroke" fill="sym-stroke" pen="sym-pen">-0 0 m--1 0.333 l--1 -0.333 l-h-</path>-</symbol>-<symbol name="arrow/farc(spx)">-<path stroke="sym-stroke" fill="white" pen="sym-pen">-0 0 m--1 0.333 l--1 -0.333 l-h-</path>-</symbol>-<symbol name="arrow/ptarc(spx)">-<path stroke="sym-stroke" fill="sym-stroke" pen="sym-pen">-0 0 m--1 0.333 l--0.8 0 l--1 -0.333 l-h-</path>-</symbol>-<symbol name="arrow/fptarc(spx)">-<path stroke="sym-stroke" fill="white" pen="sym-pen">-0 0 m--1 0.333 l--0.8 0 l--1 -0.333 l-h-</path>-</symbol>-<symbol name="mark/circle(sx)" transformations="translations">-<path fill="sym-stroke">-0.6 0 0 0.6 0 0 e-0.4 0 0 0.4 0 0 e-</path>-</symbol>-<symbol name="mark/disk(sx)" transformations="translations">-<path fill="sym-stroke">-0.6 0 0 0.6 0 0 e-</path>-</symbol>-<symbol name="mark/fdisk(sfx)" transformations="translations">-<group>-<path fill="sym-fill">-0.5 0 0 0.5 0 0 e-</path>-<path fill="sym-stroke" fillrule="eofill">-0.6 0 0 0.6 0 0 e-0.4 0 0 0.4 0 0 e-</path>-</group>-</symbol>-<symbol name="mark/box(sx)" transformations="translations">-<path fill="sym-stroke" fillrule="eofill">--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-</path>-</symbol>-<symbol name="mark/square(sx)" transformations="translations">-<path fill="sym-stroke">--0.6 -0.6 m-0.6 -0.6 l-0.6 0.6 l--0.6 0.6 l-h-</path>-</symbol>-<symbol name="mark/fsquare(sfx)" transformations="translations">-<group>-<path fill="sym-fill">--0.5 -0.5 m-0.5 -0.5 l-0.5 0.5 l--0.5 0.5 l-h-</path>-<path fill="sym-stroke" fillrule="eofill">--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-</path>-</group>-</symbol>-<symbol name="mark/cross(sx)" transformations="translations">-<group>-<path fill="sym-stroke">--0.43 -0.57 m-0.57 0.43 l-0.43 0.57 l--0.57 -0.43 l-h-</path>-<path fill="sym-stroke">--0.43 0.57 m-0.57 -0.43 l-0.43 -0.57 l--0.57 0.43 l-h-</path>-</group>-</symbol>-<symbol name="arrow/fnormal(spx)">-<path stroke="sym-stroke" fill="white" pen="sym-pen">-0 0 m--1 0.333 l--1 -0.333 l-h-</path>-</symbol>-<symbol name="arrow/pointed(spx)">-<path stroke="sym-stroke" fill="sym-stroke" pen="sym-pen">-0 0 m--1 0.333 l--0.8 0 l--1 -0.333 l-h-</path>-</symbol>-<symbol name="arrow/fpointed(spx)">-<path stroke="sym-stroke" fill="white" pen="sym-pen">-0 0 m--1 0.333 l--0.8 0 l--1 -0.333 l-h-</path>-</symbol>-<symbol name="arrow/linear(spx)">-<path stroke="sym-stroke" pen="sym-pen">--1 0.333 m-0 0 l--1 -0.333 l-</path>-</symbol>-<symbol name="arrow/fdouble(spx)">-<path stroke="sym-stroke" fill="white" pen="sym-pen">-0 0 m--1 0.333 l--1 -0.333 l-h--1 0 m--2 0.333 l--2 -0.333 l-h-</path>-</symbol>-<symbol name="arrow/double(spx)">-<path stroke="sym-stroke" fill="sym-stroke" pen="sym-pen">-0 0 m--1 0.333 l--1 -0.333 l-h--1 0 m--2 0.333 l--2 -0.333 l-h-</path>-</symbol>-<pen name="heavier" value="0.8"/>-<pen name="fat" value="1.2"/>-<pen name="ultrafat" value="2"/>-<symbolsize name="large" value="5"/>-<symbolsize name="small" value="2"/>-<symbolsize name="tiny" value="1.1"/>-<arrowsize name="large" value="10"/>-<arrowsize name="small" value="5"/>-<arrowsize name="tiny" value="3"/>-<color name="red" value="1 0 0"/>-<color name="green" value="0 1 0"/>-<color name="blue" value="0 0 1"/>-<color name="yellow" value="1 1 0"/>-<color name="orange" value="1 0.647 0"/>-<color name="gold" value="1 0.843 0"/>-<color name="purple" value="0.627 0.125 0.941"/>-<color name="gray" value="0.745"/>-<color name="brown" value="0.647 0.165 0.165"/>-<color name="navy" value="0 0 0.502"/>-<color name="pink" value="1 0.753 0.796"/>-<color name="seagreen" value="0.18 0.545 0.341"/>-<color name="turquoise" value="0.251 0.878 0.816"/>-<color name="violet" value="0.933 0.51 0.933"/>-<color name="darkblue" value="0 0 0.545"/>-<color name="darkcyan" value="0 0.545 0.545"/>-<color name="darkgray" value="0.663"/>-<color name="darkgreen" value="0 0.392 0"/>-<color name="darkmagenta" value="0.545 0 0.545"/>-<color name="darkorange" value="1 0.549 0"/>-<color name="darkred" value="0.545 0 0"/>-<color name="lightblue" value="0.678 0.847 0.902"/>-<color name="lightcyan" value="0.878 1 1"/>-<color name="lightgray" value="0.827"/>-<color name="lightgreen" value="0.565 0.933 0.565"/>-<color name="lightyellow" value="1 1 0.878"/>-<dashstyle name="dashed" value="[4] 0"/>-<dashstyle name="dotted" value="[1 3] 0"/>-<dashstyle name="dash dotted" value="[4 2 1 2] 0"/>-<dashstyle name="dash dot dotted" value="[4 2 1 2 1 2] 0"/>-<textsize name="large" value="\large"/>-<textsize name="Large" value="\Large"/>-<textsize name="LARGE" value="\LARGE"/>-<textsize name="huge" value="\huge"/>-<textsize name="Huge" value="\Huge"/>-<textsize name="small" value="\small"/>-<textsize name="footnote" value="\footnotesize"/>-<textsize name="tiny" value="\tiny"/>-<textstyle name="center" begin="\begin{center}" end="\end{center}"/>-<textstyle name="itemize" begin="\begin{itemize}" end="\end{itemize}"/>-<textstyle name="item" begin="\begin{itemize}\item{}" end="\end{itemize}"/>-<gridsize name="4 pts" value="4"/>-<gridsize name="8 pts (~3 mm)" value="8"/>-<gridsize name="16 pts (~6 mm)" value="16"/>-<gridsize name="32 pts (~12 mm)" value="32"/>-<gridsize name="10 pts (~3.5 mm)" value="10"/>-<gridsize name="20 pts (~7 mm)" value="20"/>-<gridsize name="14 pts (~5 mm)" value="14"/>-<gridsize name="28 pts (~10 mm)" value="28"/>-<gridsize name="56 pts (~20 mm)" value="56"/>-<anglesize name="90 deg" value="90"/>-<anglesize name="60 deg" value="60"/>-<anglesize name="45 deg" value="45"/>-<anglesize name="30 deg" value="30"/>-<anglesize name="22.5 deg" value="22.5"/>-<opacity name="10%" value="0.1"/>-<opacity name="30%" value="0.3"/>-<opacity name="50%" value="0.5"/>-<opacity name="75%" value="0.75"/>-<tiling name="falling" angle="-60" step="4" width="1"/>-<tiling name="rising" angle="30" step="4" width="1"/>-</ipestyle>-<ipestyle name="frank">-<arrowsize name="normal" value="5"/>-<arrowsize name="large" value="8"/>-<arrowsize name="huge" value="10"/>-<arrowsize name="small" value="3"/>-<arrowsize name="tiny" value="1"/>-<dashstyle name="dashed" value="[2 2] 0"/>-<dashstyle name="dotted" value="[0.5 1] 0"/>-<dashstyle name="dash dotted" value="[4 2 1 2] 0"/>-<dashstyle name="dash dot dotted" value="[4 2 1 2 1 2] 0"/>-<gridsize name="1 pts" value="1"/>-<gridsize name="2 pts" value="2"/>-<opacity name="10%" value="0.1"/>-<opacity name="30%" value="0.3"/>-<opacity name="50%" value="0.5"/>-<opacity name="20%" value="0.2"/>-<opacity name="40%" value="0.4"/>-<opacity name="60%" value="0.6"/>-<opacity name="70%" value="0.7"/>-<opacity name="80%" value="0.8"/>-<opacity name="90%" value="0.9"/>-</ipestyle>-<page>-<layer name="alpha"/>-<layer name="beta"/>-<view layers="alpha beta" active="beta"/>-<path layer="alpha" stroke="black">-144 720 m-224 768 l-368 672 l-320 592 l-240 544 l-112 528 l-96 640 l-h-</path>-<path stroke="black">-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-</path>-</page>-</ipe>
− test/Data/Geometry/Polygon/star_shaped.ipe 
@@ -1,339 +0,0 @@-<?xml version="1.0"?>-<!DOCTYPE ipe SYSTEM "ipe.dtd">-<ipe version="70206" creator="Ipe 7.2.7">-<info created="D:20190310121058" modified="D:20190310122053"/>-<ipestyle name="basic">-<symbol name="arrow/arc(spx)">-<path stroke="sym-stroke" fill="sym-stroke" pen="sym-pen">-0 0 m--1 0.333 l--1 -0.333 l-h-</path>-</symbol>-<symbol name="arrow/farc(spx)">-<path stroke="sym-stroke" fill="white" pen="sym-pen">-0 0 m--1 0.333 l--1 -0.333 l-h-</path>-</symbol>-<symbol name="arrow/ptarc(spx)">-<path stroke="sym-stroke" fill="sym-stroke" pen="sym-pen">-0 0 m--1 0.333 l--0.8 0 l--1 -0.333 l-h-</path>-</symbol>-<symbol name="arrow/fptarc(spx)">-<path stroke="sym-stroke" fill="white" pen="sym-pen">-0 0 m--1 0.333 l--0.8 0 l--1 -0.333 l-h-</path>-</symbol>-<symbol name="mark/circle(sx)" transformations="translations">-<path fill="sym-stroke">-0.6 0 0 0.6 0 0 e-0.4 0 0 0.4 0 0 e-</path>-</symbol>-<symbol name="mark/disk(sx)" transformations="translations">-<path fill="sym-stroke">-0.6 0 0 0.6 0 0 e-</path>-</symbol>-<symbol name="mark/fdisk(sfx)" transformations="translations">-<group>-<path fill="sym-fill">-0.5 0 0 0.5 0 0 e-</path>-<path fill="sym-stroke" fillrule="eofill">-0.6 0 0 0.6 0 0 e-0.4 0 0 0.4 0 0 e-</path>-</group>-</symbol>-<symbol name="mark/box(sx)" transformations="translations">-<path fill="sym-stroke" fillrule="eofill">--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-</path>-</symbol>-<symbol name="mark/square(sx)" transformations="translations">-<path fill="sym-stroke">--0.6 -0.6 m-0.6 -0.6 l-0.6 0.6 l--0.6 0.6 l-h-</path>-</symbol>-<symbol name="mark/fsquare(sfx)" transformations="translations">-<group>-<path fill="sym-fill">--0.5 -0.5 m-0.5 -0.5 l-0.5 0.5 l--0.5 0.5 l-h-</path>-<path fill="sym-stroke" fillrule="eofill">--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-</path>-</group>-</symbol>-<symbol name="mark/cross(sx)" transformations="translations">-<group>-<path fill="sym-stroke">--0.43 -0.57 m-0.57 0.43 l-0.43 0.57 l--0.57 -0.43 l-h-</path>-<path fill="sym-stroke">--0.43 0.57 m-0.57 -0.43 l-0.43 -0.57 l--0.57 0.43 l-h-</path>-</group>-</symbol>-<symbol name="arrow/fnormal(spx)">-<path stroke="sym-stroke" fill="white" pen="sym-pen">-0 0 m--1 0.333 l--1 -0.333 l-h-</path>-</symbol>-<symbol name="arrow/pointed(spx)">-<path stroke="sym-stroke" fill="sym-stroke" pen="sym-pen">-0 0 m--1 0.333 l--0.8 0 l--1 -0.333 l-h-</path>-</symbol>-<symbol name="arrow/fpointed(spx)">-<path stroke="sym-stroke" fill="white" pen="sym-pen">-0 0 m--1 0.333 l--0.8 0 l--1 -0.333 l-h-</path>-</symbol>-<symbol name="arrow/linear(spx)">-<path stroke="sym-stroke" pen="sym-pen">--1 0.333 m-0 0 l--1 -0.333 l-</path>-</symbol>-<symbol name="arrow/fdouble(spx)">-<path stroke="sym-stroke" fill="white" pen="sym-pen">-0 0 m--1 0.333 l--1 -0.333 l-h--1 0 m--2 0.333 l--2 -0.333 l-h-</path>-</symbol>-<symbol name="arrow/double(spx)">-<path stroke="sym-stroke" fill="sym-stroke" pen="sym-pen">-0 0 m--1 0.333 l--1 -0.333 l-h--1 0 m--2 0.333 l--2 -0.333 l-h-</path>-</symbol>-<pen name="heavier" value="0.8"/>-<pen name="fat" value="1.2"/>-<pen name="ultrafat" value="2"/>-<symbolsize name="large" value="5"/>-<symbolsize name="small" value="2"/>-<symbolsize name="tiny" value="1.1"/>-<arrowsize name="large" value="10"/>-<arrowsize name="small" value="5"/>-<arrowsize name="tiny" value="3"/>-<color name="red" value="1 0 0"/>-<color name="green" value="0 1 0"/>-<color name="blue" value="0 0 1"/>-<color name="yellow" value="1 1 0"/>-<color name="orange" value="1 0.647 0"/>-<color name="gold" value="1 0.843 0"/>-<color name="purple" value="0.627 0.125 0.941"/>-<color name="gray" value="0.745"/>-<color name="brown" value="0.647 0.165 0.165"/>-<color name="navy" value="0 0 0.502"/>-<color name="pink" value="1 0.753 0.796"/>-<color name="seagreen" value="0.18 0.545 0.341"/>-<color name="turquoise" value="0.251 0.878 0.816"/>-<color name="violet" value="0.933 0.51 0.933"/>-<color name="darkblue" value="0 0 0.545"/>-<color name="darkcyan" value="0 0.545 0.545"/>-<color name="darkgray" value="0.663"/>-<color name="darkgreen" value="0 0.392 0"/>-<color name="darkmagenta" value="0.545 0 0.545"/>-<color name="darkorange" value="1 0.549 0"/>-<color name="darkred" value="0.545 0 0"/>-<color name="lightblue" value="0.678 0.847 0.902"/>-<color name="lightcyan" value="0.878 1 1"/>-<color name="lightgray" value="0.827"/>-<color name="lightgreen" value="0.565 0.933 0.565"/>-<color name="lightyellow" value="1 1 0.878"/>-<dashstyle name="dashed" value="[4] 0"/>-<dashstyle name="dotted" value="[1 3] 0"/>-<dashstyle name="dash dotted" value="[4 2 1 2] 0"/>-<dashstyle name="dash dot dotted" value="[4 2 1 2 1 2] 0"/>-<textsize name="large" value="\large"/>-<textsize name="Large" value="\Large"/>-<textsize name="LARGE" value="\LARGE"/>-<textsize name="huge" value="\huge"/>-<textsize name="Huge" value="\Huge"/>-<textsize name="small" value="\small"/>-<textsize name="footnote" value="\footnotesize"/>-<textsize name="tiny" value="\tiny"/>-<textstyle name="center" begin="\begin{center}" end="\end{center}"/>-<textstyle name="itemize" begin="\begin{itemize}" end="\end{itemize}"/>-<textstyle name="item" begin="\begin{itemize}\item{}" end="\end{itemize}"/>-<gridsize name="4 pts" value="4"/>-<gridsize name="8 pts (~3 mm)" value="8"/>-<gridsize name="16 pts (~6 mm)" value="16"/>-<gridsize name="32 pts (~12 mm)" value="32"/>-<gridsize name="10 pts (~3.5 mm)" value="10"/>-<gridsize name="20 pts (~7 mm)" value="20"/>-<gridsize name="14 pts (~5 mm)" value="14"/>-<gridsize name="28 pts (~10 mm)" value="28"/>-<gridsize name="56 pts (~20 mm)" value="56"/>-<anglesize name="90 deg" value="90"/>-<anglesize name="60 deg" value="60"/>-<anglesize name="45 deg" value="45"/>-<anglesize name="30 deg" value="30"/>-<anglesize name="22.5 deg" value="22.5"/>-<opacity name="10%" value="0.1"/>-<opacity name="30%" value="0.3"/>-<opacity name="50%" value="0.5"/>-<opacity name="75%" value="0.75"/>-<tiling name="falling" angle="-60" step="4" width="1"/>-<tiling name="rising" angle="30" step="4" width="1"/>-</ipestyle>-<ipestyle name="frank">-<arrowsize name="normal" value="5"/>-<arrowsize name="large" value="8"/>-<arrowsize name="huge" value="10"/>-<arrowsize name="small" value="3"/>-<arrowsize name="tiny" value="1"/>-<dashstyle name="dashed" value="[2 2] 0"/>-<dashstyle name="dotted" value="[0.5 1] 0"/>-<dashstyle name="dash dotted" value="[4 2 1 2] 0"/>-<dashstyle name="dash dot dotted" value="[4 2 1 2 1 2] 0"/>-<gridsize name="1 pts" value="1"/>-<gridsize name="2 pts" value="2"/>-<opacity name="10%" value="0.1"/>-<opacity name="30%" value="0.3"/>-<opacity name="50%" value="0.5"/>-<opacity name="20%" value="0.2"/>-<opacity name="40%" value="0.4"/>-<opacity name="60%" value="0.6"/>-<opacity name="70%" value="0.7"/>-<opacity name="80%" value="0.8"/>-<opacity name="90%" value="0.9"/>-</ipestyle>-<page>-<layer name="alpha"/>-<view layers="alpha" active="alpha"/>-<path layer="alpha" stroke="blue">-176 752 m-208 688 l-160 624 l-288 672 l-304 752 l-256 736 l-h-</path>-<path stroke="red">-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-</path>-<path stroke="red">-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-</path>-<path stroke="blue">-176 272 m-144 80 l-400 176 l-h-</path>-<path stroke="blue">-432 272 m-480 144 l-528 192 l-496 192 l-512 240 l-480 224 l-h-</path>-<path stroke="blue">-64 656 m-32 592 l-80 640 l-144 640 l-80 656 l-96 704 l-80 672 l-h-</path>-</page>-</ipe>
− test/Data/Geometry/arrangement.ipe 
@@ -1,296 +0,0 @@-<?xml version="1.0"?>-<!DOCTYPE ipe SYSTEM "ipe.dtd">-<ipe version="70107" creator="Ipe 7.2.2">-<info created="D:20180731094955" modified="D:20180731094955"/>-<ipestyle name="basic">-<symbol name="arrow/arc(spx)">-<path stroke="sym-stroke" fill="sym-stroke" pen="sym-pen">-0 0 m--1 0.333 l--1 -0.333 l-h-</path>-</symbol>-<symbol name="arrow/farc(spx)">-<path stroke="sym-stroke" fill="white" pen="sym-pen">-0 0 m--1 0.333 l--1 -0.333 l-h-</path>-</symbol>-<symbol name="arrow/ptarc(spx)">-<path stroke="sym-stroke" fill="sym-stroke" pen="sym-pen">-0 0 m--1 0.333 l--0.8 0 l--1 -0.333 l-h-</path>-</symbol>-<symbol name="arrow/fptarc(spx)">-<path stroke="sym-stroke" fill="white" pen="sym-pen">-0 0 m--1 0.333 l--0.8 0 l--1 -0.333 l-h-</path>-</symbol>-<symbol name="mark/circle(sx)" transformations="translations">-<path fill="sym-stroke">-0.6 0 0 0.6 0 0 e-0.4 0 0 0.4 0 0 e-</path>-</symbol>-<symbol name="mark/disk(sx)" transformations="translations">-<path fill="sym-stroke">-0.6 0 0 0.6 0 0 e-</path>-</symbol>-<symbol name="mark/fdisk(sfx)" transformations="translations">-<group>-<path fill="sym-fill">-0.5 0 0 0.5 0 0 e-</path>-<path fill="sym-stroke" fillrule="eofill">-0.6 0 0 0.6 0 0 e-0.4 0 0 0.4 0 0 e-</path>-</group>-</symbol>-<symbol name="mark/box(sx)" transformations="translations">-<path fill="sym-stroke" fillrule="eofill">--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-</path>-</symbol>-<symbol name="mark/square(sx)" transformations="translations">-<path fill="sym-stroke">--0.6 -0.6 m-0.6 -0.6 l-0.6 0.6 l--0.6 0.6 l-h-</path>-</symbol>-<symbol name="mark/fsquare(sfx)" transformations="translations">-<group>-<path fill="sym-fill">--0.5 -0.5 m-0.5 -0.5 l-0.5 0.5 l--0.5 0.5 l-h-</path>-<path fill="sym-stroke" fillrule="eofill">--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-</path>-</group>-</symbol>-<symbol name="mark/cross(sx)" transformations="translations">-<group>-<path fill="sym-stroke">--0.43 -0.57 m-0.57 0.43 l-0.43 0.57 l--0.57 -0.43 l-h-</path>-<path fill="sym-stroke">--0.43 0.57 m-0.57 -0.43 l-0.43 -0.57 l--0.57 0.43 l-h-</path>-</group>-</symbol>-<symbol name="arrow/fnormal(spx)">-<path stroke="sym-stroke" fill="white" pen="sym-pen">-0 0 m--1 0.333 l--1 -0.333 l-h-</path>-</symbol>-<symbol name="arrow/pointed(spx)">-<path stroke="sym-stroke" fill="sym-stroke" pen="sym-pen">-0 0 m--1 0.333 l--0.8 0 l--1 -0.333 l-h-</path>-</symbol>-<symbol name="arrow/fpointed(spx)">-<path stroke="sym-stroke" fill="white" pen="sym-pen">-0 0 m--1 0.333 l--0.8 0 l--1 -0.333 l-h-</path>-</symbol>-<symbol name="arrow/linear(spx)">-<path stroke="sym-stroke" pen="sym-pen">--1 0.333 m-0 0 l--1 -0.333 l-</path>-</symbol>-<symbol name="arrow/fdouble(spx)">-<path stroke="sym-stroke" fill="white" pen="sym-pen">-0 0 m--1 0.333 l--1 -0.333 l-h--1 0 m--2 0.333 l--2 -0.333 l-h-</path>-</symbol>-<symbol name="arrow/double(spx)">-<path stroke="sym-stroke" fill="sym-stroke" pen="sym-pen">-0 0 m--1 0.333 l--1 -0.333 l-h--1 0 m--2 0.333 l--2 -0.333 l-h-</path>-</symbol>-<pen name="heavier" value="0.8"/>-<pen name="fat" value="1.2"/>-<pen name="ultrafat" value="2"/>-<symbolsize name="large" value="5"/>-<symbolsize name="small" value="2"/>-<symbolsize name="tiny" value="1.1"/>-<arrowsize name="large" value="10"/>-<arrowsize name="small" value="5"/>-<arrowsize name="tiny" value="3"/>-<color name="red" value="1 0 0"/>-<color name="green" value="0 1 0"/>-<color name="blue" value="0 0 1"/>-<color name="yellow" value="1 1 0"/>-<color name="orange" value="1 0.647 0"/>-<color name="gold" value="1 0.843 0"/>-<color name="purple" value="0.627 0.125 0.941"/>-<color name="gray" value="0.745"/>-<color name="brown" value="0.647 0.165 0.165"/>-<color name="navy" value="0 0 0.502"/>-<color name="pink" value="1 0.753 0.796"/>-<color name="seagreen" value="0.18 0.545 0.341"/>-<color name="turquoise" value="0.251 0.878 0.816"/>-<color name="violet" value="0.933 0.51 0.933"/>-<color name="darkblue" value="0 0 0.545"/>-<color name="darkcyan" value="0 0.545 0.545"/>-<color name="darkgray" value="0.663"/>-<color name="darkgreen" value="0 0.392 0"/>-<color name="darkmagenta" value="0.545 0 0.545"/>-<color name="darkorange" value="1 0.549 0"/>-<color name="darkred" value="0.545 0 0"/>-<color name="lightblue" value="0.678 0.847 0.902"/>-<color name="lightcyan" value="0.878 1 1"/>-<color name="lightgray" value="0.827"/>-<color name="lightgreen" value="0.565 0.933 0.565"/>-<color name="lightyellow" value="1 1 0.878"/>-<dashstyle name="dashed" value="[4] 0"/>-<dashstyle name="dotted" value="[1 3] 0"/>-<dashstyle name="dash dotted" value="[4 2 1 2] 0"/>-<dashstyle name="dash dot dotted" value="[4 2 1 2 1 2] 0"/>-<textsize name="large" value="\large"/>-<textsize name="Large" value="\Large"/>-<textsize name="LARGE" value="\LARGE"/>-<textsize name="huge" value="\huge"/>-<textsize name="Huge" value="\Huge"/>-<textsize name="small" value="\small"/>-<textsize name="footnote" value="\footnotesize"/>-<textsize name="tiny" value="\tiny"/>-<textstyle name="center" begin="\begin{center}" end="\end{center}"/>-<textstyle name="itemize" begin="\begin{itemize}" end="\end{itemize}"/>-<textstyle name="item" begin="\begin{itemize}\item{}" end="\end{itemize}"/>-<gridsize name="4 pts" value="4"/>-<gridsize name="8 pts (~3 mm)" value="8"/>-<gridsize name="16 pts (~6 mm)" value="16"/>-<gridsize name="32 pts (~12 mm)" value="32"/>-<gridsize name="10 pts (~3.5 mm)" value="10"/>-<gridsize name="20 pts (~7 mm)" value="20"/>-<gridsize name="14 pts (~5 mm)" value="14"/>-<gridsize name="28 pts (~10 mm)" value="28"/>-<gridsize name="56 pts (~20 mm)" value="56"/>-<anglesize name="90 deg" value="90"/>-<anglesize name="60 deg" value="60"/>-<anglesize name="45 deg" value="45"/>-<anglesize name="30 deg" value="30"/>-<anglesize name="22.5 deg" value="22.5"/>-<opacity name="10%" value="0.1"/>-<opacity name="30%" value="0.3"/>-<opacity name="50%" value="0.5"/>-<opacity name="75%" value="0.75"/>-<tiling name="falling" angle="-60" step="4" width="1"/>-<tiling name="rising" angle="30" step="4" width="1"/>-</ipestyle>-<ipestyle name="frank">-<arrowsize name="normal" value="5"/>-<arrowsize name="large" value="8"/>-<arrowsize name="huge" value="10"/>-<arrowsize name="small" value="3"/>-<arrowsize name="tiny" value="1"/>-<dashstyle name="dashed" value="[2 2] 0"/>-<dashstyle name="dotted" value="[0.5 1] 0"/>-<dashstyle name="dash dotted" value="[4 2 1 2] 0"/>-<dashstyle name="dash dot dotted" value="[4 2 1 2 1 2] 0"/>-<gridsize name="1 pts" value="1"/>-<gridsize name="2 pts" value="2"/>-<opacity name="10%" value="0.1"/>-<opacity name="30%" value="0.3"/>-<opacity name="50%" value="0.5"/>-<opacity name="20%" value="0.2"/>-<opacity name="40%" value="0.4"/>-<opacity name="60%" value="0.6"/>-<opacity name="70%" value="0.7"/>-<opacity name="80%" value="0.8"/>-<opacity name="90%" value="0.9"/>-</ipestyle>-<page>-<layer name="alpha"/>-<view layers="alpha" active="alpha"/>-<path layer="alpha" stroke="black">-80 560 m-368 800 l-</path>-<path stroke="black">-160 768 m-416 608 l-</path>-<path stroke="black">-80 624 m-400 672 l-</path>-<path matrix="0.857143 0 0 1.3 32 -172.8" stroke="black">-224 576 m-336 736 l-</path>-</page>-</ipe>
− test/Data/Geometry/arrangement.ipe.out.ipe 
@@ -1,247 +0,0 @@-<?xml version="1.0" encoding="UTF-8"?>-<ipe version="70005" creator="HGeometry"><ipestyle name="basic">-<color name="red" value="1 0 0"/>-<color name="green" value="0 1 0"/>-<color name="blue" value="0 0 1"/>-<color name="yellow" value="1 1 0"/>-<color name="orange" value="1 0.647 0"/>-<color name="gold" value="1 0.843 0"/>-<color name="purple" value="0.627 0.125 0.941"/>-<color name="gray" value="0.745 0.745 0.745"/>-<color name="brown" value="0.647 0.165 0.165"/>-<color name="navy" value="0 0 0.502"/>-<color name="pink" value="1 0.753 0.796"/>-<color name="seagreen" value="0.18 0.545 0.341"/>-<color name="turquoise" value="0.251 0.878 0.816"/>-<color name="violet" value="0.933 0.51 0.933"/>-<color name="darkblue" value="0 0 0.545"/>-<color name="darkcyan" value="0 0.545 0.545"/>-<color name="darkgray" value="0.663 0.663 0.663"/>-<color name="darkgreen" value="0 0.392 0"/>-<color name="darkmagenta" value="0.545 0 0.545"/>-<color name="darkorange" value="1 0.549 0"/>-<color name="darkred" value="0.545 0 0"/>-<color name="lightblue" value="0.678 0.847 0.902"/>-<color name="lightcyan" value="0.878 1 1"/>-<color name="lightgray" value="0.827 0.827 0.827"/>-<color name="lightgreen" value="0.565 0.933 0.565"/>-<color name="lightyellow" value="1 1 0.878"/>-<dashstyle name="dashed" value="[4] 0"/>-<dashstyle name="dotted" value="[1 3] 0"/>-<dashstyle name="dash dotted" value="[4 2 1 2] 0"/>-<dashstyle name="dash dot dotted" value="[4 2 1 2 1 2] 0"/>-<pen name="heavier" value="0.8"/>-<pen name="fat" value="1.2"/>-<pen name="ultrafat" value="2"/>-<textsize name="large" value="\large"/>-<textsize name="Large" value="\Large"/>-<textsize name="LARGE" value="\LARGE"/>-<textsize name="huge" value="\huge"/>-<textsize name="Huge" value="\Huge"/>-<textsize name="small" value="\small"/>-<textsize name="footnote" value="\footnotesize"/>-<textsize name="tiny" value="\tiny"/>-<symbolsize name="small" value="2"/>-<symbolsize name="tiny" value="1.1"/>-<symbolsize name="large" value="5"/>-<arrowsize name="small" value="5"/>-<arrowsize name="tiny" value="3"/>-<arrowsize name="large" value="10"/>-<gridsize name="4 pts" value="4"/>-<gridsize name="8 pts (~3 mm)" value="8"/>-<gridsize name="16 pts (~6 mm)" value="16"/>-<gridsize name="32 pts (~12 mm)" value="32"/>-<gridsize name="10 pts (~3.5 mm)" value="10"/>-<gridsize name="20 pts (~7 mm)" value="20"/>-<gridsize name="14 pts (~5 mm)" value="14"/>-<gridsize name="28 pts (~10 mm)" value="28"/>-<gridsize name="56 pts (~20 mm)" value="56"/>-<anglesize name="90 deg" value="90"/>-<anglesize name="60 deg" value="60"/>-<anglesize name="45 deg" value="45"/>-<anglesize name="30 deg" value="30"/>-<anglesize name="22.5 deg" value="22.5"/>-<symbol name="mark/circle(sx)" transformations="translations">-<path fill="sym-stroke">-0.6 0 0 0.6 0 0 e 0.4 0 0 0.4 0 0 e-</path></symbol>-<symbol name="mark/disk(sx)" transformations="translations">-<path fill="sym-stroke">-0.6 0 0 0.6 0 0 e-</path></symbol>-<symbol name="mark/fdisk(sfx)" transformations="translations">-<group><path fill="sym-fill">-0.5 0 0 0.5 0 0 e-</path><path fill="sym-stroke" fillrule="eofill">-0.6 0 0 0.6 0 0 e 0.4 0 0 0.4 0 0 e-</path></group></symbol>-<symbol name="mark/box(sx)" transformations="translations">-<path fill="sym-stroke" fillrule="eofill">--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</path></symbol>-<symbol name="mark/square(sx)" transformations="translations">-<path fill="sym-stroke">--0.6 -0.6 m 0.6 -0.6 l 0.6 0.6 l -0.6 0.6 l h</path></symbol>-<symbol name="mark/fsquare(sfx)" transformations="translations">-<group><path fill="sym-fill">--0.5 -0.5 m 0.5 -0.5 l 0.5 0.5 l -0.5 0.5 l h</path>-<path fill="sym-stroke" fillrule="eofill">--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</path></group></symbol>-<symbol name="mark/cross(sx)" transformations="translations">-<group><path fill="sym-stroke">--0.43 -0.57 m 0.57 0.43 l 0.43 0.57 l -0.57 -0.43 l h</path>-<path fill="sym-stroke">--0.43 0.57 m 0.57 -0.43 l 0.43 -0.57 l -0.57 0.43 l h</path>-</group></symbol>-<symbol name="arrow/arc(spx)">-<path pen="sym-pen" stroke="sym-stroke" fill="sym-stroke">-0 0 m -1.0 0.333 l -1.0 -0.333 l h</path></symbol>-<symbol name="arrow/farc(spx)">-<path pen="sym-pen" stroke="sym-stroke" fill="white">-0 0 m -1.0 0.333 l -1.0 -0.333 l h</path></symbol>-<symbol name="arrow/ptarc(spx)">-<path pen="sym-pen" stroke="sym-stroke" fill="sym-stroke">-0 0 m -1.0 0.333 l -0.8 0 l -1.0 -0.333 l h</path></symbol>-<symbol name="arrow/fptarc(spx)">-<path pen="sym-pen" stroke="sym-stroke" fill="white">-0 0 m -1.0 0.333 l -0.8 0 l -1.0 -0.333 l h</path></symbol>-<symbol name="arrow/fnormal(spx)">-<path pen="sym-pen" stroke="sym-stroke" fill="white">-0 0 m -1.0 0.333 l -1.0 -0.333 l h</path></symbol>-<symbol name="arrow/pointed(spx)">-<path pen="sym-pen" stroke="sym-stroke" fill="sym-stroke">-0 0 m -1.0 0.333 l -0.8 0 l -1.0 -0.333 l h</path></symbol>-<symbol name="arrow/fpointed(spx)">-<path pen="sym-pen" stroke="sym-stroke" fill="white">-0 0 m -1.0 0.333 l -0.8 0 l -1.0 -0.333 l h</path></symbol>-<symbol name="arrow/linear(spx)">-<path pen="sym-pen" stroke="sym-stroke">--1.0 0.333 m 0 0 l -1.0 -0.333 l</path></symbol>-<symbol name="arrow/fdouble(spx)">-<path pen="sym-pen" stroke="sym-stroke" fill="white">-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-</path></symbol>-<symbol name="arrow/double(spx)">-<path pen="sym-pen" stroke="sym-stroke" fill="sym-stroke">-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-</path></symbol>-<tiling name="falling" angle="-60" width="1" step="4"/>-<tiling name="rising" angle="30" width="1" step="4"/>-<textstyle name="center" begin="\begin{center}" end="\end{center}"/>-<textstyle name="itemize" begin="\begin{itemize}" end="\end{itemize}"/>-<textstyle name="item" begin="\begin{itemize}\item{}" end="\end{itemize}"/>-</ipestyle><page><group><use pos="172.658536585365 637.048780487804" name="mark/disk(sx)"/><use pos="172.658536585365 637.215447154471" name="mark/disk(sx)"/><use pos="172.658536585365 637.898780487804" name="mark/disk(sx)"/><use pos="172.658536585365 746.000060937506" name="mark/disk(sx)"/><use pos="173.658536585365 638.048780487804" name="mark/disk(sx)"/><use pos="195.199902499989 746.000060937506" name="mark/disk(sx)"/><use pos="252.176396921200 637.048780487804" name="mark/disk(sx)"/><use pos="256.914285714285 707.428571428571" name="mark/disk(sx)"/><use pos="258.512437254286 650.776865588142" name="mark/disk(sx)"/><use pos="278.447793072843 693.970129329472" name="mark/disk(sx)"/><use pos="302.000073125007 745.000060937506" name="mark/disk(sx)"/><use pos="302.461611663469 746.000060937506" name="mark/disk(sx)"/><use pos="303.200073125007 746.000060937506" name="mark/disk(sx)"/><use pos="330.322580645161 661.548387096774" name="mark/disk(sx)"/><use pos="331.322580645161 637.048780487804" name="mark/disk(sx)"/><use pos="331.322580645161 660.923387096774" name="mark/disk(sx)"/><use pos="331.322580645161 661.698387096774" name="mark/disk(sx)"/><use pos="331.322580645161 746.000060937506" name="mark/disk(sx)"/><path>172.658536585365 637.215447154471 m-173.658536585365 638.048780487804 l-</path><path>173.658536585365 638.048780487804 m-256.914285714285 707.428571428571 l-</path><path>256.914285714285 707.428571428571 m-302.000073125007 745.000060937506 l-</path><path>302.000073125007 745.000060937506 m-303.200073125007 746.000060937506 l-</path><path>195.199902499989 746.000060937506 m-256.914285714285 707.428571428571 l-</path><path>256.914285714285 707.428571428571 m-278.447793072843 693.970129329472 l-</path><path>278.447793072843 693.970129329472 m-330.322580645161 661.548387096774 l-</path><path>330.322580645161 661.548387096774 m-331.322580645161 660.923387096774 l-</path><path>172.658536585365 637.898780487804 m-173.658536585365 638.048780487804 l-</path><path>173.658536585365 638.048780487804 m-258.512437254286 650.776865588142 l-</path><path>258.512437254286 650.776865588142 m-330.322580645161 661.548387096774 l-</path><path>330.322580645161 661.548387096774 m-331.322580645161 661.698387096774 l-</path><path>252.176396921200 637.048780487804 m-258.512437254286 650.776865588142 l-</path><path>258.512437254286 650.776865588142 m-278.447793072843 693.970129329472 l-</path><path>278.447793072843 693.970129329472 m-302.000073125007 745.000060937506 l-</path><path>302.000073125007 745.000060937506 m-302.461611663469 746.000060937506 l-</path><path>172.658536585365 746.000060937506 m-195.199902499989 746.000060937506 l-</path><path>195.199902499989 746.000060937506 m-302.461611663469 746.000060937506 l-</path><path>302.461611663469 746.000060937506 m-303.200073125007 746.000060937506 l-</path><path>303.200073125007 746.000060937506 m-331.322580645161 746.000060937506 l-</path><path>331.322580645161 746.000060937506 m-331.322580645161 661.698387096774 l-</path><path>331.322580645161 661.698387096774 m-331.322580645161 660.923387096774 l-</path><path>331.322580645161 660.923387096774 m-331.322580645161 637.048780487804 l-</path><path>331.322580645161 637.048780487804 m-252.176396921200 637.048780487804 l-</path><path>252.176396921200 637.048780487804 m-172.658536585365 637.048780487804 l-</path><path>172.658536585365 637.048780487804 m-172.658536585365 637.215447154471 l-</path><path>172.658536585365 637.215447154471 m-172.658536585365 637.898780487804 l-</path><path>172.658536585365 637.898780487804 m-172.658536585365 746.000060937506 l-</path><path>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-</path><path>172.658536585365 637.898780487804 m-173.658536585365 638.048780487804 l-172.658536585365 637.215447154471 l-h-</path><path>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-</path><path>256.914285714285 707.428571428571 m-278.447793072843 693.970129329472 l-258.512437254286 650.776865588142 l-173.658536585365 638.048780487804 l-h-</path><path>302.461611663469 746.000060937506 m-302.000073125007 745.000060937506 l-256.914285714285 707.428571428571 l-195.199902499989 746.000060937506 l-h-</path><path>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-</path><path>302.000073125007 745.000060937506 m-278.447793072843 693.970129329472 l-256.914285714285 707.428571428571 l-h-</path><path>278.447793072843 693.970129329472 m-330.322580645161 661.548387096774 l-258.512437254286 650.776865588142 l-h-</path><path>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-</path><path>302.461611663469 746.000060937506 m-303.200073125007 746.000060937506 l-302.000073125007 745.000060937506 l-h-</path><path>331.322580645161 661.698387096774 m-331.322580645161 660.923387096774 l-330.322580645161 661.548387096774 l-h-</path></group></page></ipe>
− test/Data/Geometry/pointInPolygon.ipe 
@@ -1,311 +0,0 @@-<?xml version="1.0"?>-<!DOCTYPE ipe SYSTEM "ipe.dtd">-<ipe version="70107" creator="Ipe 7.1.7">-<info created="D:20150923215046" modified="D:20150924223742"/>-<ipestyle name="basic">-<symbol name="arrow/arc(spx)">-<path stroke="sym-stroke" fill="sym-stroke" pen="sym-pen">-0 0 m--1 0.333 l--1 -0.333 l-h-</path>-</symbol>-<symbol name="arrow/farc(spx)">-<path stroke="sym-stroke" fill="white" pen="sym-pen">-0 0 m--1 0.333 l--1 -0.333 l-h-</path>-</symbol>-<symbol name="arrow/ptarc(spx)">-<path stroke="sym-stroke" fill="sym-stroke" pen="sym-pen">-0 0 m--1 0.333 l--0.8 0 l--1 -0.333 l-h-</path>-</symbol>-<symbol name="arrow/fptarc(spx)">-<path stroke="sym-stroke" fill="white" pen="sym-pen">-0 0 m--1 0.333 l--0.8 0 l--1 -0.333 l-h-</path>-</symbol>-<symbol name="mark/circle(sx)" transformations="translations">-<path fill="sym-stroke">-0.6 0 0 0.6 0 0 e-0.4 0 0 0.4 0 0 e-</path>-</symbol>-<symbol name="mark/disk(sx)" transformations="translations">-<path fill="sym-stroke">-0.6 0 0 0.6 0 0 e-</path>-</symbol>-<symbol name="mark/fdisk(sfx)" transformations="translations">-<group>-<path fill="sym-fill">-0.5 0 0 0.5 0 0 e-</path>-<path fill="sym-stroke" fillrule="eofill">-0.6 0 0 0.6 0 0 e-0.4 0 0 0.4 0 0 e-</path>-</group>-</symbol>-<symbol name="mark/box(sx)" transformations="translations">-<path fill="sym-stroke" fillrule="eofill">--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-</path>-</symbol>-<symbol name="mark/square(sx)" transformations="translations">-<path fill="sym-stroke">--0.6 -0.6 m-0.6 -0.6 l-0.6 0.6 l--0.6 0.6 l-h-</path>-</symbol>-<symbol name="mark/fsquare(sfx)" transformations="translations">-<group>-<path fill="sym-fill">--0.5 -0.5 m-0.5 -0.5 l-0.5 0.5 l--0.5 0.5 l-h-</path>-<path fill="sym-stroke" fillrule="eofill">--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-</path>-</group>-</symbol>-<symbol name="mark/cross(sx)" transformations="translations">-<group>-<path fill="sym-stroke">--0.43 -0.57 m-0.57 0.43 l-0.43 0.57 l--0.57 -0.43 l-h-</path>-<path fill="sym-stroke">--0.43 0.57 m-0.57 -0.43 l-0.43 -0.57 l--0.57 0.43 l-h-</path>-</group>-</symbol>-<symbol name="arrow/fnormal(spx)">-<path stroke="sym-stroke" fill="white" pen="sym-pen">-0 0 m--1 0.333 l--1 -0.333 l-h-</path>-</symbol>-<symbol name="arrow/pointed(spx)">-<path stroke="sym-stroke" fill="sym-stroke" pen="sym-pen">-0 0 m--1 0.333 l--0.8 0 l--1 -0.333 l-h-</path>-</symbol>-<symbol name="arrow/fpointed(spx)">-<path stroke="sym-stroke" fill="white" pen="sym-pen">-0 0 m--1 0.333 l--0.8 0 l--1 -0.333 l-h-</path>-</symbol>-<symbol name="arrow/linear(spx)">-<path stroke="sym-stroke" pen="sym-pen">--1 0.333 m-0 0 l--1 -0.333 l-</path>-</symbol>-<symbol name="arrow/fdouble(spx)">-<path stroke="sym-stroke" fill="white" pen="sym-pen">-0 0 m--1 0.333 l--1 -0.333 l-h--1 0 m--2 0.333 l--2 -0.333 l-h-</path>-</symbol>-<symbol name="arrow/double(spx)">-<path stroke="sym-stroke" fill="sym-stroke" pen="sym-pen">-0 0 m--1 0.333 l--1 -0.333 l-h--1 0 m--2 0.333 l--2 -0.333 l-h-</path>-</symbol>-<pen name="heavier" value="0.8"/>-<pen name="fat" value="1.2"/>-<pen name="ultrafat" value="2"/>-<symbolsize name="large" value="5"/>-<symbolsize name="small" value="2"/>-<symbolsize name="tiny" value="1.1"/>-<arrowsize name="large" value="10"/>-<arrowsize name="small" value="5"/>-<arrowsize name="tiny" value="3"/>-<color name="red" value="1 0 0"/>-<color name="green" value="0 1 0"/>-<color name="blue" value="0 0 1"/>-<color name="yellow" value="1 1 0"/>-<color name="orange" value="1 0.647 0"/>-<color name="gold" value="1 0.843 0"/>-<color name="purple" value="0.627 0.125 0.941"/>-<color name="gray" value="0.745"/>-<color name="brown" value="0.647 0.165 0.165"/>-<color name="navy" value="0 0 0.502"/>-<color name="pink" value="1 0.753 0.796"/>-<color name="seagreen" value="0.18 0.545 0.341"/>-<color name="turquoise" value="0.251 0.878 0.816"/>-<color name="violet" value="0.933 0.51 0.933"/>-<color name="darkblue" value="0 0 0.545"/>-<color name="darkcyan" value="0 0.545 0.545"/>-<color name="darkgray" value="0.663"/>-<color name="darkgreen" value="0 0.392 0"/>-<color name="darkmagenta" value="0.545 0 0.545"/>-<color name="darkorange" value="1 0.549 0"/>-<color name="darkred" value="0.545 0 0"/>-<color name="lightblue" value="0.678 0.847 0.902"/>-<color name="lightcyan" value="0.878 1 1"/>-<color name="lightgray" value="0.827"/>-<color name="lightgreen" value="0.565 0.933 0.565"/>-<color name="lightyellow" value="1 1 0.878"/>-<dashstyle name="dashed" value="[4] 0"/>-<dashstyle name="dotted" value="[1 3] 0"/>-<dashstyle name="dash dotted" value="[4 2 1 2] 0"/>-<dashstyle name="dash dot dotted" value="[4 2 1 2 1 2] 0"/>-<textsize name="large" value="\large"/>-<textsize name="Large" value="\Large"/>-<textsize name="LARGE" value="\LARGE"/>-<textsize name="huge" value="\huge"/>-<textsize name="Huge" value="\Huge"/>-<textsize name="small" value="\small"/>-<textsize name="footnote" value="\footnotesize"/>-<textsize name="tiny" value="\tiny"/>-<textstyle name="center" begin="\begin{center}" end="\end{center}"/>-<textstyle name="itemize" begin="\begin{itemize}" end="\end{itemize}"/>-<textstyle name="item" begin="\begin{itemize}\item{}" end="\end{itemize}"/>-<gridsize name="4 pts" value="4"/>-<gridsize name="8 pts (~3 mm)" value="8"/>-<gridsize name="16 pts (~6 mm)" value="16"/>-<gridsize name="32 pts (~12 mm)" value="32"/>-<gridsize name="10 pts (~3.5 mm)" value="10"/>-<gridsize name="20 pts (~7 mm)" value="20"/>-<gridsize name="14 pts (~5 mm)" value="14"/>-<gridsize name="28 pts (~10 mm)" value="28"/>-<gridsize name="56 pts (~20 mm)" value="56"/>-<anglesize name="90 deg" value="90"/>-<anglesize name="60 deg" value="60"/>-<anglesize name="45 deg" value="45"/>-<anglesize name="30 deg" value="30"/>-<anglesize name="22.5 deg" value="22.5"/>-<tiling name="falling" angle="-60" step="4" width="1"/>-<tiling name="rising" angle="30" step="4" width="1"/>-</ipestyle>-<ipestyle name="frank">-<arrowsize name="normal" value="5"/>-<arrowsize name="large" value="8"/>-<arrowsize name="huge" value="10"/>-<arrowsize name="small" value="3"/>-<arrowsize name="tiny" value="1"/>-<dashstyle name="dashed" value="[2 2] 0"/>-<dashstyle name="dotted" value="[0.5 1] 0"/>-<dashstyle name="dash dotted" value="[4 2 1 2] 0"/>-<dashstyle name="dash dot dotted" value="[4 2 1 2 1 2] 0"/>-<gridsize name="1 pts" value="1"/>-<gridsize name="2 pts" value="2"/>-<opacity name="10%" value="0.1"/>-<opacity name="20%" value="0.2"/>-<opacity name="30%" value="0.3"/>-<opacity name="40%" value="0.4"/>-<opacity name="50%" value="0.5"/>-<opacity name="60%" value="0.6"/>-<opacity name="70%" value="0.7"/>-<opacity name="80%" value="0.8"/>-<opacity name="90%" value="0.9"/>-</ipestyle>-<page>-<layer name="alpha"/>-<view layers="alpha" active="alpha"/>-<path layer="alpha" stroke="darkblue">-208 752 m-304 688 l-224 592 l-48 736 l-h-</path>-<use name="mark/disk(sx)" pos="128 704" size="normal" stroke="darkblue"/>-<use name="mark/disk(sx)" pos="192 672" size="normal" stroke="darkblue"/>-<use name="mark/disk(sx)" pos="192 720" size="normal" stroke="darkblue"/>-<use name="mark/box(sx)" pos="304 688" size="normal" stroke="black"/>-<use name="mark/cross(sx)" pos="352 736" size="normal" stroke="darkblue"/>-<use name="mark/cross(sx)" pos="352 704" size="normal" stroke="darkblue"/>-<path stroke="orange">-496 736 m-432 624 l-512 608 l-h-</path>-<use name="mark/box(sx)" pos="432 624" size="normal" stroke="orange"/>-<use name="mark/box(sx)" pos="512 608" size="normal" stroke="orange"/>-<use name="mark/box(sx)" pos="496 736" size="normal" stroke="orange"/>-<use name="mark/disk(sx)" pos="496 656" size="normal" stroke="orange"/>-<use name="mark/disk(sx)" pos="480 640" size="normal" stroke="orange"/>-<use name="mark/disk(sx)" pos="464 656" size="normal" stroke="orange"/>-<use name="mark/cross(sx)" pos="368 608" size="normal" stroke="orange"/>-<use name="mark/cross(sx)" pos="384 592" size="normal" stroke="orange"/>-<use name="mark/cross(sx)" pos="336 576" size="normal" stroke="orange"/>-<use name="mark/disk(sx)" pos="496 624" size="normal" stroke="orange"/>-<use name="mark/cross(sx)" pos="528 624" size="normal" stroke="orange"/>-<use name="mark/cross(sx)" pos="384 624" size="normal" stroke="orange"/>-<use name="mark/cross(sx)" pos="368 640" size="normal" stroke="orange"/>-<use name="mark/cross(sx)" pos="336 688" size="normal" stroke="darkblue"/>-<use name="mark/disk(sx)" pos="256 688" size="normal" stroke="darkblue"/>-<use name="mark/disk(sx)" pos="224 688" size="normal" stroke="darkblue"/>-</page>-</ipe>
− test/Data/Geometry/pointInTriangle.ipe 
@@ -1,310 +0,0 @@-<?xml version="1.0"?>-<!DOCTYPE ipe SYSTEM "ipe.dtd">-<ipe version="70107" creator="Ipe 7.2.2">-<info created="D:20150923215046" modified="D:20180808120020"/>-<ipestyle name="basic">-<symbol name="arrow/arc(spx)">-<path stroke="sym-stroke" fill="sym-stroke" pen="sym-pen">-0 0 m--1 0.333 l--1 -0.333 l-h-</path>-</symbol>-<symbol name="arrow/farc(spx)">-<path stroke="sym-stroke" fill="white" pen="sym-pen">-0 0 m--1 0.333 l--1 -0.333 l-h-</path>-</symbol>-<symbol name="arrow/ptarc(spx)">-<path stroke="sym-stroke" fill="sym-stroke" pen="sym-pen">-0 0 m--1 0.333 l--0.8 0 l--1 -0.333 l-h-</path>-</symbol>-<symbol name="arrow/fptarc(spx)">-<path stroke="sym-stroke" fill="white" pen="sym-pen">-0 0 m--1 0.333 l--0.8 0 l--1 -0.333 l-h-</path>-</symbol>-<symbol name="mark/circle(sx)" transformations="translations">-<path fill="sym-stroke">-0.6 0 0 0.6 0 0 e-0.4 0 0 0.4 0 0 e-</path>-</symbol>-<symbol name="mark/disk(sx)" transformations="translations">-<path fill="sym-stroke">-0.6 0 0 0.6 0 0 e-</path>-</symbol>-<symbol name="mark/fdisk(sfx)" transformations="translations">-<group>-<path fill="sym-fill">-0.5 0 0 0.5 0 0 e-</path>-<path fill="sym-stroke" fillrule="eofill">-0.6 0 0 0.6 0 0 e-0.4 0 0 0.4 0 0 e-</path>-</group>-</symbol>-<symbol name="mark/box(sx)" transformations="translations">-<path fill="sym-stroke" fillrule="eofill">--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-</path>-</symbol>-<symbol name="mark/square(sx)" transformations="translations">-<path fill="sym-stroke">--0.6 -0.6 m-0.6 -0.6 l-0.6 0.6 l--0.6 0.6 l-h-</path>-</symbol>-<symbol name="mark/fsquare(sfx)" transformations="translations">-<group>-<path fill="sym-fill">--0.5 -0.5 m-0.5 -0.5 l-0.5 0.5 l--0.5 0.5 l-h-</path>-<path fill="sym-stroke" fillrule="eofill">--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-</path>-</group>-</symbol>-<symbol name="mark/cross(sx)" transformations="translations">-<group>-<path fill="sym-stroke">--0.43 -0.57 m-0.57 0.43 l-0.43 0.57 l--0.57 -0.43 l-h-</path>-<path fill="sym-stroke">--0.43 0.57 m-0.57 -0.43 l-0.43 -0.57 l--0.57 0.43 l-h-</path>-</group>-</symbol>-<symbol name="arrow/fnormal(spx)">-<path stroke="sym-stroke" fill="white" pen="sym-pen">-0 0 m--1 0.333 l--1 -0.333 l-h-</path>-</symbol>-<symbol name="arrow/pointed(spx)">-<path stroke="sym-stroke" fill="sym-stroke" pen="sym-pen">-0 0 m--1 0.333 l--0.8 0 l--1 -0.333 l-h-</path>-</symbol>-<symbol name="arrow/fpointed(spx)">-<path stroke="sym-stroke" fill="white" pen="sym-pen">-0 0 m--1 0.333 l--0.8 0 l--1 -0.333 l-h-</path>-</symbol>-<symbol name="arrow/linear(spx)">-<path stroke="sym-stroke" pen="sym-pen">--1 0.333 m-0 0 l--1 -0.333 l-</path>-</symbol>-<symbol name="arrow/fdouble(spx)">-<path stroke="sym-stroke" fill="white" pen="sym-pen">-0 0 m--1 0.333 l--1 -0.333 l-h--1 0 m--2 0.333 l--2 -0.333 l-h-</path>-</symbol>-<symbol name="arrow/double(spx)">-<path stroke="sym-stroke" fill="sym-stroke" pen="sym-pen">-0 0 m--1 0.333 l--1 -0.333 l-h--1 0 m--2 0.333 l--2 -0.333 l-h-</path>-</symbol>-<pen name="heavier" value="0.8"/>-<pen name="fat" value="1.2"/>-<pen name="ultrafat" value="2"/>-<symbolsize name="large" value="5"/>-<symbolsize name="small" value="2"/>-<symbolsize name="tiny" value="1.1"/>-<arrowsize name="large" value="10"/>-<arrowsize name="small" value="5"/>-<arrowsize name="tiny" value="3"/>-<color name="red" value="1 0 0"/>-<color name="green" value="0 1 0"/>-<color name="blue" value="0 0 1"/>-<color name="yellow" value="1 1 0"/>-<color name="orange" value="1 0.647 0"/>-<color name="gold" value="1 0.843 0"/>-<color name="purple" value="0.627 0.125 0.941"/>-<color name="gray" value="0.745"/>-<color name="brown" value="0.647 0.165 0.165"/>-<color name="navy" value="0 0 0.502"/>-<color name="pink" value="1 0.753 0.796"/>-<color name="seagreen" value="0.18 0.545 0.341"/>-<color name="turquoise" value="0.251 0.878 0.816"/>-<color name="violet" value="0.933 0.51 0.933"/>-<color name="darkblue" value="0 0 0.545"/>-<color name="darkcyan" value="0 0.545 0.545"/>-<color name="darkgray" value="0.663"/>-<color name="darkgreen" value="0 0.392 0"/>-<color name="darkmagenta" value="0.545 0 0.545"/>-<color name="darkorange" value="1 0.549 0"/>-<color name="darkred" value="0.545 0 0"/>-<color name="lightblue" value="0.678 0.847 0.902"/>-<color name="lightcyan" value="0.878 1 1"/>-<color name="lightgray" value="0.827"/>-<color name="lightgreen" value="0.565 0.933 0.565"/>-<color name="lightyellow" value="1 1 0.878"/>-<dashstyle name="dashed" value="[4] 0"/>-<dashstyle name="dotted" value="[1 3] 0"/>-<dashstyle name="dash dotted" value="[4 2 1 2] 0"/>-<dashstyle name="dash dot dotted" value="[4 2 1 2 1 2] 0"/>-<textsize name="large" value="\large"/>-<textsize name="Large" value="\Large"/>-<textsize name="LARGE" value="\LARGE"/>-<textsize name="huge" value="\huge"/>-<textsize name="Huge" value="\Huge"/>-<textsize name="small" value="\small"/>-<textsize name="footnote" value="\footnotesize"/>-<textsize name="tiny" value="\tiny"/>-<textstyle name="center" begin="\begin{center}" end="\end{center}"/>-<textstyle name="itemize" begin="\begin{itemize}" end="\end{itemize}"/>-<textstyle name="item" begin="\begin{itemize}\item{}" end="\end{itemize}"/>-<gridsize name="4 pts" value="4"/>-<gridsize name="8 pts (~3 mm)" value="8"/>-<gridsize name="16 pts (~6 mm)" value="16"/>-<gridsize name="32 pts (~12 mm)" value="32"/>-<gridsize name="10 pts (~3.5 mm)" value="10"/>-<gridsize name="20 pts (~7 mm)" value="20"/>-<gridsize name="14 pts (~5 mm)" value="14"/>-<gridsize name="28 pts (~10 mm)" value="28"/>-<gridsize name="56 pts (~20 mm)" value="56"/>-<anglesize name="90 deg" value="90"/>-<anglesize name="60 deg" value="60"/>-<anglesize name="45 deg" value="45"/>-<anglesize name="30 deg" value="30"/>-<anglesize name="22.5 deg" value="22.5"/>-<tiling name="falling" angle="-60" step="4" width="1"/>-<tiling name="rising" angle="30" step="4" width="1"/>-</ipestyle>-<ipestyle name="frank">-<arrowsize name="normal" value="5"/>-<arrowsize name="large" value="8"/>-<arrowsize name="huge" value="10"/>-<arrowsize name="small" value="3"/>-<arrowsize name="tiny" value="1"/>-<dashstyle name="dashed" value="[2 2] 0"/>-<dashstyle name="dotted" value="[0.5 1] 0"/>-<dashstyle name="dash dotted" value="[4 2 1 2] 0"/>-<dashstyle name="dash dot dotted" value="[4 2 1 2 1 2] 0"/>-<gridsize name="1 pts" value="1"/>-<gridsize name="2 pts" value="2"/>-<opacity name="10%" value="0.1"/>-<opacity name="30%" value="0.3"/>-<opacity name="50%" value="0.5"/>-<opacity name="20%" value="0.2"/>-<opacity name="40%" value="0.4"/>-<opacity name="60%" value="0.6"/>-<opacity name="70%" value="0.7"/>-<opacity name="80%" value="0.8"/>-<opacity name="90%" value="0.9"/>-</ipestyle>-<page>-<layer name="alpha"/>-<view layers="alpha" active="alpha"/>-<path layer="alpha" stroke="darkblue">-304 720 m-224 592 l-48 736 l-h-</path>-<use name="mark/disk(sx)" pos="128 704" size="normal" stroke="darkblue"/>-<use name="mark/disk(sx)" pos="192 672" size="normal" stroke="darkblue"/>-<use name="mark/disk(sx)" pos="192 720" size="normal" stroke="darkblue"/>-<use name="mark/box(sx)" pos="304 688" size="normal" stroke="black"/>-<use name="mark/cross(sx)" pos="352 736" size="normal" stroke="darkblue"/>-<use name="mark/cross(sx)" pos="352 704" size="normal" stroke="darkblue"/>-<path stroke="orange">-496 736 m-432 624 l-512 608 l-h-</path>-<use name="mark/box(sx)" pos="432 624" size="normal" stroke="orange"/>-<use name="mark/box(sx)" pos="512 608" size="normal" stroke="orange"/>-<use name="mark/box(sx)" pos="496 736" size="normal" stroke="orange"/>-<use name="mark/disk(sx)" pos="496 656" size="normal" stroke="orange"/>-<use name="mark/disk(sx)" pos="480 640" size="normal" stroke="orange"/>-<use name="mark/disk(sx)" pos="464 656" size="normal" stroke="orange"/>-<use name="mark/cross(sx)" pos="368 608" size="normal" stroke="orange"/>-<use name="mark/cross(sx)" pos="384 592" size="normal" stroke="orange"/>-<use name="mark/cross(sx)" pos="336 576" size="normal" stroke="orange"/>-<use name="mark/disk(sx)" pos="496 624" size="normal" stroke="orange"/>-<use name="mark/cross(sx)" pos="528 624" size="normal" stroke="orange"/>-<use name="mark/cross(sx)" pos="384 624" size="normal" stroke="orange"/>-<use name="mark/cross(sx)" pos="368 640" size="normal" stroke="orange"/>-<use name="mark/cross(sx)" pos="336 688" size="normal" stroke="darkblue"/>-<use name="mark/disk(sx)" pos="256 688" size="normal" stroke="darkblue"/>-<use name="mark/disk(sx)" pos="224 688" size="normal" stroke="darkblue"/>-</page>-</ipe>
− test/Data/PlaneGraph/myPlaneGraph.yaml 
@@ -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
− test/Data/PlaneGraph/small.yaml 
@@ -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
− test/Data/PlaneGraph/testsegs.png

binary file changed (56081 → absent bytes)