Add triangulation of simple polygons (#225)

* triangulating * triangulating a (y)Monotone polygon :) * updating branch shield * triangulation tests * implementation of shrink for many of the geometry types * triangulation tests * triangulation tests :) * proper polygon shrinking and self intersection testing * some more debugging functions eand tests * adding fromEmbedding; this fixes the final triangulation bugs :) * fixed one more (the final?) triangulation bug :)
noinia · Apr 13, 2024 · c327403 · c327403
1 parent 4c6b3c4
commit c327403
Show file tree

Hide file tree

Showing 28 changed files with 719 additions and 322 deletions.
diff --git a/README.md b/README.md
@@ -1,7 +1,7 @@
 # HGeometry
 
 ![GitHub Workflow Status](
-https://img.shields.io/github/actions/workflow/status/noinia/hgeometry/haskell-ci.yml?branch=hgeom1_again)
+https://img.shields.io/github/actions/workflow/status/noinia/hgeometry/haskell-ci.yml?branch=master)
 [![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/haddocks)
 

diff --git a/hgeometry-combinatorial/src-quickcheck/HGeometry/Combinatorial/Instances.hs b/hgeometry-combinatorial/src-quickcheck/HGeometry/Combinatorial/Instances.hs
@@ -27,7 +27,7 @@ import           HGeometry.Tree.Binary.Static
 
 instance (Arbitrary c, Arbitrary e) => Arbitrary (c :+ e) where
   arbitrary = (:+) <$> arbitrary <*> arbitrary
-
+  shrink = genericShrink
 
 --------------------------------------------------------------------------------
 
@@ -38,9 +38,15 @@ instance (Arbitrary c, Arbitrary e) => Arbitrary (c :+ e) where
 
 instance (Arbitrary a, Num a, Eq a) => Arbitrary (GRatio a) where
   arbitrary = (/) <$> arbitrary <*> (arbitrary `suchThat` (/= 0))
+  shrink r = 0 : 1 : [ a' % b'
+                     | a' <- shrink $ numerator r
+                     , b' <- fromInteger 1 : shrink (denominator r)
+                     , b' /= 0
+                     ]
 
 instance KnownNat p => Arbitrary (RealNumber p) where
   arbitrary = fromFixed <$> arbitrary
+  shrink = genericShrink
 
 instance Arbitrary Sign.Sign where
   arbitrary = (\b -> if b then Sign.Positive else Sign.Negative) <$> arbitrary
@@ -69,10 +75,12 @@ instance (Arbitrary a, Arbitrary v) => Arbitrary (BinLeafTree v a) where
               | otherwise = do
                               l <- choose (0,n-1)
                               Node <$> f l <*> arbitrary <*> f (n-l-1)
+  -- shrink = genericShrink
 
 instance Arbitrary a => Arbitrary (BinaryTree a) where
   arbitrary = sized f
     where f n | n <= 0    = pure Nil
               | otherwise = do
                               l <- choose (0,n-1)
                               Internal <$> f l <*> arbitrary <*> f (n-l-1)
+  -- shrink = genericShrink
diff --git a/hgeometry/data/test-with-ipe/golden/PlaneGraph/smallPlaneGraph.ipe b/hgeometry/data/test-with-ipe/golden/PlaneGraph/smallPlaneGraph.ipe
@@ -133,7 +133,7 @@
 <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><layer name="alpha"/><layer name="dartLabel"/><layer name="darts"/><layer name="face"/><layer name="faceLabel"/><layer name="vertex"/><layer name="vertexLabel"/><view layers="alpha dartLabel darts face faceLabel vertex vertexLabel" active="alpha"/><use layer="vertex" pos="0.0 0.0" name="mark/disk(sx)"/><text layer="vertexLabel" pos="0.0 0.0" type="label">Point2 0.0 0.0 :+ 0</text><use layer="vertex" pos="200.0 200.0" name="mark/disk(sx)"/><text layer="vertexLabel" pos="200.0 200.0" type="label">Point2 200.0 200.0 :+ 1</text><use layer="vertex" pos="200.0 0.0" name="mark/disk(sx)"/><text layer="vertexLabel" pos="200.0 0.0" type="label">Point2 200.0 0.0 :+ 2</text><use layer="vertex" pos="-100.0 400.0" name="mark/disk(sx)"/><text layer="vertexLabel" pos="-100.0 400.0" type="label">Point2 (-100.0) 400.0 :+ 3</text><path layer="darts" stroke="purple" arrow="normal/normal">0.0 1.0 m
+</ipestyle><page><layer name="alpha"/><layer name="dartLabel"/><layer name="darts"/><layer name="edgeLabel"/><layer name="edges"/><layer name="face"/><layer name="faceLabel"/><layer name="vertex"/><layer name="vertexLabel"/><view layers="alpha dartLabel darts edgeLabel edges face faceLabel vertex vertexLabel" active="alpha"/><use layer="vertex" pos="0.0 0.0" name="mark/disk(sx)"/><text layer="vertexLabel" pos="0.0 0.0" type="label">Point2 0.0 0.0 :+ 0</text><use layer="vertex" pos="200.0 200.0" name="mark/disk(sx)"/><text layer="vertexLabel" pos="200.0 200.0" type="label">Point2 200.0 200.0 :+ 1</text><use layer="vertex" pos="200.0 0.0" name="mark/disk(sx)"/><text layer="vertexLabel" pos="200.0 0.0" type="label">Point2 200.0 0.0 :+ 2</text><use layer="vertex" pos="-100.0 400.0" name="mark/disk(sx)"/><text layer="vertexLabel" pos="-100.0 400.0" type="label">Point2 (-100.0) 400.0 :+ 3</text><path layer="darts" stroke="purple" arrow="normal/normal">0.0 1.0 m
 200.0 1.0 l
 </path><text layer="dartLabel" pos="100.0 0.0" type="label">&quot;0-&gt;2&quot;</text><path layer="darts" stroke="purple" arrow="normal/normal">200.0 -1.0 m
 0.0 -1.0 l
@@ -153,7 +153,17 @@
 201.0 0.0 l
 </path><text layer="dartLabel" pos="200.0 100.0" type="label">&quot;1-&gt;2&quot;</text><path layer="darts" stroke="purple" arrow="normal/normal">199.0 0.0 m
 199.0 200.0 l
-</path><text layer="dartLabel" pos="200.0 100.0" type="label">&quot;2-&gt;1&quot;</text><path layer="face">0.0 0.0 m
+</path><text layer="dartLabel" pos="200.0 100.0" type="label">&quot;2-&gt;1&quot;</text><path layer="edges">0.0 0.0 m
+200.0 0.0 l
+</path><text layer="edgeLabel" pos="100.0 0.0" type="label">Dart (Arc 0) +1</text><path layer="edges">0.0 0.0 m
+200.0 200.0 l
+</path><text layer="edgeLabel" pos="100.0 100.0" type="label">Dart (Arc 1) +1</text><path layer="edges">0.0 0.0 m
+-100.0 400.0 l
+</path><text layer="edgeLabel" pos="-50.0 200.0" type="label">Dart (Arc 2) +1</text><path layer="edges">200.0 200.0 m
+-100.0 400.0 l
+</path><text layer="edgeLabel" pos="50.0 300.0" type="label">Dart (Arc 3) +1</text><path layer="edges">200.0 200.0 m
+200.0 0.0 l
+</path><text layer="edgeLabel" pos="200.0 100.0" type="label">Dart (Arc 4) +1</text><path layer="face">0.0 0.0 m
 200.0 0.0 l
 200.0 200.0 l
 h

diff --git a/hgeometry/hgeometry.cabal b/hgeometry/hgeometry.cabal
@@ -70,7 +70,8 @@ common all-setup
       , file-io                   >= 0.1           && < 1
       , indexed-traversable       >= 0.1.3         && < 1
       , vector-builder            >= 0.3.8         && < 1
-      , HsYAML                    >= 0.2           &&  < 1
+      , HsYAML                    >= 0.2           && < 1
+      , semialign                 >= 1.3           && < 1.4
 
       , ghc-typelits-natnormalise >= 0.7.7         && < 1
       , ghc-typelits-knownnat     >= 0.7.6         && < 1
@@ -100,14 +101,12 @@ common point-setup
 
 common vector-setup
     build-depends:
-       semialign                  >= 1.2        && < 2
-     , these                      >= 1.1        && < 2
+        these                      >= 1.1        && < 2
 
 common kernel-setup
     build-depends:
         hgeometry:vector
       , hgeometry:point
-      , semialign
 
 common hgeometry-setup
     build-depends:
@@ -381,6 +380,7 @@ library
 
         -- HGeometry.HalfPlane.CommonIntersection
 
+        HGeometry.Polygon.Triangulation
         HGeometry.Polygon.Triangulation.TriangulateMonotone
         HGeometry.Polygon.Triangulation.MakeMonotone
 
@@ -664,6 +664,7 @@ test-suite with-ipe-hspec
       LineSegmentSpec
       HalfLineSpec
       Polygon.Triangulation.TriangulateMonotoneSpec
+      Polygon.Triangulation.TriangulateSpec
       LineSegment.Intersection.BentleyOttmannSpec
       PlaneGraph.RenderSpec
 

diff --git a/hgeometry/kernel/src-quickcheck/HGeometry/Kernel/Instances.hs b/hgeometry/kernel/src-quickcheck/HGeometry/Kernel/Instances.hs
@@ -13,6 +13,7 @@
 module HGeometry.Kernel.Instances where
 
 import Control.Lens hiding (cons)
+import Data.Semialign
 import GHC.TypeLits
 import HGeometry.Ball
 import HGeometry.Box
@@ -21,7 +22,7 @@ import HGeometry.HalfSpace
 import HGeometry.HyperPlane (HyperPlane(..))
 import HGeometry.HyperPlane.NonVertical (NonVerticalHyperPlane(..))
 import HGeometry.Interval
-import HGeometry.Interval.EndPoint()
+import HGeometry.Interval.EndPoint ()
 import HGeometry.Line.LineEQ
 import HGeometry.Line.PointAndVector
 import HGeometry.LineSegment
@@ -41,25 +42,39 @@ import Test.QuickCheck
 
 instance Arbitrary r => Arbitrary (EndPoint ep r) where
   arbitrary = EndPoint <$> arbitrary
+  shrink (EndPoint p) = EndPoint <$> shrink p
 
 instance Arbitrary EndPointType where
   arbitrary = (\b -> if b then Open else Closed) <$> arbitrary
+  shrink = \case
+    Open   -> [Closed]
+    Closed -> []
 
 instance Arbitrary r => Arbitrary (AnEndPoint r) where
   arbitrary = AnEndPoint <$> arbitrary <*> arbitrary
-
+  shrink = genericShrink
 
 instance ( Arbitrary (endPoint r)
          , Eq (endPoint r), Ord r, IxValue (endPoint r) ~ r, EndPoint_ (endPoint r)
          ) => Arbitrary (Interval endPoint r) where
   arbitrary = do p <- arbitrary
-                 q <- arbitrary `suchThat` (isValid p)
+                 q <- arbitrary `suchThat` (isValidInterval p)
                  pure $ buildInterval p q
-    where
-      isValid p q = p /= q && ((p^._endPoint == q^._endPoint) `implies` bothClosed p q)
-      bothClosed p q = endPointType p == Closed && endPointType q == Closed
-      implies p q = not p || q
+  shrink i = [ buildInterval p q
+             | p <- shrink $ i^.startPoint
+             , q <- shrink $ i^.endPoint
+             , isValidInterval p q
+             ]
+
+isValidInterval     :: (Eq (endPoint r), Ord r, IxValue (endPoint r) ~ r, EndPoint_ (endPoint r))
+                    => endPoint r -> endPoint r -> Bool
+isValidInterval p q = p /= q && ((p^._endPoint == q^._endPoint) `implies` bothClosed p q)
 
+bothClosed     :: EndPoint_ (endPoint r) => endPoint r -> endPoint r -> Bool
+bothClosed p q = endPointType p == Closed && endPointType q == Closed
+
+implies :: Bool -> Bool -> Bool
+implies p q = not p || q
 
 instance ( Arbitrary (endPoint point)
          , IsEndPoint (endPoint point) (endPoint point)
@@ -69,6 +84,11 @@ instance ( Arbitrary (endPoint point)
   arbitrary = do p <- arbitrary
                  q <- arbitrary `suchThat` (\q' -> q'^._endPoint /= p^._endPoint)
                  pure $ LineSegment p q
+  shrink s = [ LineSegment p q
+             | p <- shrink $ s^.startPoint
+             , q <- shrink $ s^.endPoint
+             , q^._endPoint /= p^._endPoint
+             ]
 
 instance ( Arbitrary point
          , Arbitrary (NumType point)
@@ -77,6 +97,11 @@ instance ( Arbitrary point
          ) => Arbitrary (Ball point) where
   arbitrary = Ball <$> arbitrary
                    <*> (arbitrary `suchThat` (> 0))
+  shrink (Ball c r) = [ Ball c' r'
+                      | c' <- shrink c
+                      , r' <- 1 : shrink r
+                      , r' > 0
+                      ]
 
 instance ( Arbitrary point
          , Point_ point 2 r, Num r, Ord r
@@ -86,6 +111,8 @@ instance ( Arbitrary point
                  b <- arbitrary `suchThat` (/= a)
                  c <- arbitrary `suchThat` (\c' -> c' /= a && c' /= b && ccw a b c' /= CoLinear)
                  pure $ Triangle a b c
+  shrink = genericShrink
+
 
 instance Arbitrary r => Arbitrary (LineEQ r) where
   arbitrary = LineEQ <$> arbitrary <*> arbitrary
@@ -103,10 +130,16 @@ instance ( Arbitrary point
          , Arbitrary r
          , Point_ point d r
          , Num r
-         , Ord (Vector d r)
+         , Ord r
+         , Zip (Vector d)
          ) => Arbitrary (Box point) where
   arbitrary = (\p v -> Box p (p .+^ v)) <$> arbitrary
-                                        <*> arbitrary `suchThat` (> zero)
+                                        <*> arbitrary `suchThat` (allOf components (> 0))
+  shrink b = [ Box p (p .+^ v)
+             | p <- shrink $ b^.minPoint
+             , v <- shrink $ size b
+             , allOf components (> 0) v
+             ]
 
 instance ( Has_ Additive_ m r
          , Has_ Vector_ n (Vector m r)

diff --git a/hgeometry/kernel/src/HGeometry/Interval/EndPoint.hs b/hgeometry/kernel/src/HGeometry/Interval/EndPoint.hs
@@ -22,6 +22,7 @@ module HGeometry.Interval.EndPoint
 
 import Control.Lens
 import Data.Foldable1
+import GHC.Generics (Generic)
 import HGeometry.Properties
 import Text.Read
 
@@ -40,7 +41,7 @@ class IsEndPoint endPoint endPoint => EndPoint_ endPoint where
   mkEndPoint :: IxValue endPoint -> endPoint
 
 -- | Possible endpoint types; open or closed
-data EndPointType = Open | Closed deriving (Show,Read,Eq,Ord,Enum,Bounded)
+data EndPointType = Open | Closed deriving (Show,Read,Eq,Ord,Enum,Bounded,Generic)
 
 
 -- testV :: Vector 2 (Point 2 Double)
@@ -53,7 +54,7 @@ data EndPointType = Open | Closed deriving (Show,Read,Eq,Ord,Enum,Bounded)
 
 -- | EndPoint with a type safe tag
 newtype EndPoint (et :: EndPointType) r = EndPoint r
-  deriving stock (Eq,Ord,Functor,Foldable,Traversable)
+  deriving stock (Eq,Ord,Functor,Foldable,Traversable,Generic)
 
 instance Show r => Show (EndPoint Closed r) where
   showsPrec = showsPrecImpl "ClosedE"
@@ -117,7 +118,7 @@ pattern OpenE x = EndPoint x
 
 -- | Data type modelling an endpoint that can both be open and closed.
 data AnEndPoint r = AnEndPoint {-# UNPACK #-} !EndPointType !r
-                  deriving (Show,Read,Eq,Ord,Functor,Foldable,Traversable)
+                  deriving (Show,Read,Eq,Ord,Functor,Foldable,Traversable,Generic)
 
 type instance NumType (AnEndPoint r) = r
 type instance IxValue (AnEndPoint r) = r

diff --git a/hgeometry/kernel/src/HGeometry/LineSegment/Internal.hs b/hgeometry/kernel/src/HGeometry/LineSegment/Internal.hs
@@ -27,7 +27,6 @@ import Data.Kind (Type)
 import HGeometry.Box.Boxable
 import HGeometry.Intersection
 import HGeometry.Interval
-import HGeometry.Interval.Class
 import HGeometry.Line.Class
 import HGeometry.Line.PointAndVector
 import HGeometry.LineSegment.Class

diff --git a/hgeometry/kernel/src/HGeometry/Triangle.hs b/hgeometry/kernel/src/HGeometry/Triangle.hs
@@ -15,22 +15,22 @@ module HGeometry.Triangle
   ) where
 
 import Control.Lens
+import GHC.Generics (Generic)
 import HGeometry.Box.Boxable
--- import HGeometry.HalfSpace
--- import HGeometry.HyperPlane
-import HGeometry.Point
 import HGeometry.Intersection
+import HGeometry.Point
 import HGeometry.Properties
--- import HGeometry.Transformation
+import HGeometry.Transformation
 import HGeometry.Triangle.Class
 import HGeometry.Vector
-import Text.Read
 import Hiraffe.Graph
+import Text.Read
 
 --------------------------------------------------------------------------------
 
 -- | Triangles in d-dimensional space
 newtype Triangle point = MkTriangle (Vector 3 point)
+  deriving (Generic)
 
 -- | Construct a triangle from its three points
 pattern Triangle       :: point -> point -> point -> Triangle point
@@ -64,11 +64,9 @@ instance HasVertices (Triangle point) (Triangle point') where
 instance HasPoints (Triangle point) (Triangle point') point point' where
   allPoints = _TriangleVector.components
 
--- instance ( DefaultTransformByConstraints (Triangle point) d r
---          , Point_ point d r
---          , d > 0
---          ) => IsTransformable (Triangle point)
-
+instance ( DefaultTransformByConstraints (Triangle point) d r
+         , Point_ point d r
+         ) => IsTransformable (Triangle point)
 
 instance (Show point) => Show (Triangle point) where
   showsPrec k (Triangle a b c ) = showParen (k > appPrec) $

diff --git a/hgeometry/point/src-quickcheck/HGeometry/Point/Instances.hs b/hgeometry/point/src-quickcheck/HGeometry/Point/Instances.hs
@@ -19,3 +19,4 @@ import Test.QuickCheck
 
 instance Arbitrary v => Arbitrary (PointF v) where
   arbitrary = Point <$> arbitrary
+  shrink (Point v) = Point <$> shrink v
diff --git a/hgeometry/point/src/HGeometry/Point/Class.hs b/hgeometry/point/src/HGeometry/Point/Class.hs
@@ -24,22 +24,20 @@ module HGeometry.Point.Class
   -- , projectPoint
   -- , PointFor
   , HasPoints(..), HasPoints'
+  , NoDefault(..)
   ) where
 
 import           Control.Lens
 import           Data.Default.Class
 import           Data.Function (on)
 import qualified Data.List.NonEmpty as NonEmpty
 import           Data.Proxy (Proxy(..))
+import           GHC.Generics (Generic)
 import           GHC.TypeNats
 import           HGeometry.Ext
 import           HGeometry.Properties
 import           HGeometry.Vector
 import qualified Linear.Affine as Linear
--- import           Linear.V2 (V2(..))
--- import           Linear.V3 (V3(..))
--- import           Linear.V4 (V4(..))
-
 
 -- $setup
 -- >>> import HGeometry.Point
@@ -361,3 +359,12 @@ instance Affine_ point d r => Affine_ (point :+ extra) d r where
 instance (Point_ point d r, Default extra) => Point_ (point :+ extra) d r where
   {-# SPECIALIZE instance Point_ point d r => Point_ (point :+ ()) d r #-}
   fromVector v = fromVector v :+ def
+
+
+-- | A newtype that can discharge the Default constraint in an unsafe way, if you really
+-- sure that you'll never actually need the default
+newtype NoDefault extra = NoDefault extra
+  deriving newtype (Show,Read,Eq,Ord,Enum,Num,Bounded,Real,Fractional,RealFrac,Generic)
+
+instance Default (NoDefault extra) where
+  def = error "NoDefault does not have an actual default. So something went wrong"
diff --git a/hgeometry/src-quickcheck/HGeometry/Polygon/Instances.hs b/hgeometry/src-quickcheck/HGeometry/Polygon/Instances.hs
@@ -118,6 +118,11 @@ instance Arbitrary (SimplePolygon (Point 2 (RealNumber (p::Nat)))) where
 -- instance Arbitrary (MultiPolygon () Rational) where
 --   arbitrary = elements allMultiPolygons'
 
+
+
+
+
+
 simplifyP :: SimplePolygon (Point  2 Rational) -> [SimplePolygon (Point 2 Rational)]
 simplifyP pg
       -- Scale up polygon such that each coordinate is a whole number.
@@ -127,13 +132,12 @@ simplifyP pg
       -- Scale down polygon maintaining each coordinate as a whole number
     | gcdP /= 1 = [ pg&vertices %~ divP gcdP ]
 
-        -- unsafeFromCircularVector $ CV.map (over core (divP gcdP)) vs]
     | minX /= 0 || minY /= 0 = [ pg&vertices %~ align ]
       -- = [unsafeFromCircularVector $ CV.map (over core align) vs]
     | otherwise =
       let pg' = pg&vertices %~ _div2
             -- unsafeFromCircularVector $ CV.map (over core _div2) vs
-      in [ pg' | not (hasSelfIntersections pg') ]
+      in [ pg' | hasNoSelfIntersections $ pg'^..vertices ]
     -- otherwise = []
   where
     minX = first1Of (minimumVertexBy (comparing (^.xCoord)).xCoord) pg
@@ -154,8 +158,6 @@ simplifyP pg
     divP v (Point2 c d) = Point2 (c/v) (d/v)
     _div2 (Point2 a b) = Point2 (numerator a `div` 2 % 1) (numerator b `div` 2 % 1)
 
-hasSelfIntersections = const True
--- FIXME!
 
 lcmPoint :: SimplePolygon (Point 2 Rational) -> Rational
 lcmPoint p = realToFrac t
Original file line number	Diff line number	Diff line change
Expand Up		@@ -19,3 +19,4 @@ import Test.QuickCheck

		instance Arbitrary v => Arbitrary (PointF v) where
		arbitrary = Point <$> arbitrary
		shrink (Point v) = Point <$> shrink v