some more debugging functions eand tests

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

hgeometry/src/HGeometry/PlaneGraph/Type.hs

@@ -25,8 +25,10 @@ import           HGeometry.Box
 import           HGeometry.PlaneGraph.Class
 import           HGeometry.Point
 import           HGeometry.Properties
+import           HGeometry.Transformation
 import           Hiraffe.PlanarGraph
 import qualified Hiraffe.PlanarGraph as PG
+
 --------------------------------------------------------------------------------
 -- * The PlaneGraph type
 
@@ -134,5 +136,10 @@ instance ( Point_ v 2 r
          , Ord r, Num r
          ) => IsBoxable (PlaneGraph s v e f)
 
+instance ( Point_ v 2 r
+         , DefaultTransformByConstraints (PlaneGraph s v e f) 2 r
+         ) => IsTransformable (PlaneGraph s v e f)
+
+
 
   -- boundingBox = boundingBoxList' . F.toList . fmap (^._2.location) . vertices

hgeometry/src/HGeometry/Polygon/Triangulation.hs

@@ -17,7 +17,6 @@ module HGeometry.Polygon.Triangulation
 
 import           Control.Lens
 import           Data.Coerce
-import           Data.Either (lefts)
 import qualified Data.Foldable as F
 import           HGeometry.Ext
 import           HGeometry.LineSegment

hgeometry/test-with-ipe/test/PlaneGraph/RenderSpec.hs

@@ -2,6 +2,11 @@
 {-# LANGUAGE OverloadedStrings #-}
 module PlaneGraph.RenderSpec
   ( spec
+  , drawGraph
+  , drawVertex
+  , drawDart
+  , drawFace
+  , drawEdge
   ) where
 
 import           Control.Lens
@@ -14,7 +19,6 @@ import           HGeometry.Boundary
 import           HGeometry.Ext
 import           HGeometry.Line
 import           HGeometry.LineSegment
-import           HGeometry.Number.Radical
 import           HGeometry.PlaneGraph
 import           HGeometry.PlaneGraph.Class
 import           HGeometry.Point
@@ -94,13 +98,16 @@ spec = describe "render planegraph tests" $ do
 
 drawGraph    :: ( PlaneGraph_ planeGraph vertex
                 , IsTransformable vertex
-                , Point_ vertex 2 r, Ord r, Radical r, Fractional r, Show r, Eq (FaceIx planeGraph)
+                , Point_ vertex 2 r, Ord r, Real r
+                , Fractional r, Show r, Eq (FaceIx planeGraph)
                 , Show (Vertex planeGraph), Show (Dart planeGraph), Show (Face planeGraph)
+                , Show (EdgeIx planeGraph)
                 ) => planeGraph -> [IpeObject r]
 drawGraph gr = theVertices <> theEdges <> theFaces
   where
     theVertices = ifoldMapOf vertices             drawVertex    gr
     theEdges    = ifoldMapOf dartSegments         (drawDart gr) gr
+               <> ifoldMapOf edgeSegments         (drawEdge gr) gr
     theFaces    = ifoldMapOf interiorFacePolygons (drawFace gr) gr
 
 drawVertex     :: ( Point_ vertex 2 r, Show vertex)
@@ -110,8 +117,18 @@ drawVertex _ v = [ iO $ ipeDiskMark (v^.asPoint) ! attr SLayer "vertex"
                                                          -- ! attr SStroke Ipe.red
                  ]
 
+drawEdge        :: ( PlaneGraph_ planeGraph vertex, Point_ vertex 2 r, IsTransformable vertex
+                   , Show (EdgeIx planeGraph), Fractional r, Real r)
+                => planeGraph -> EdgeIx planeGraph -> ClosedLineSegment vertex -> [IpeObject r]
+drawEdge gr d s = [ iO $ ipeLineSegment s ! attr SLayer "edges"
+                  , iO $ ipeLabel (tshow d :+ c) ! attr SLayer "edgeLabel"
+                  ]
+  where
+    c = interpolate 0.5 s ^. asPoint
+
+
 drawDart        :: ( PlaneGraph_ planeGraph vertex, Point_ vertex 2 r, IsTransformable vertex
-                   , Show (Dart planeGraph), Radical r, Fractional r)
+                   , Show (Dart planeGraph), Fractional r, Real r)
                 => planeGraph -> DartIx planeGraph -> ClosedLineSegment vertex -> [IpeObject r]
 drawDart gr d s = [ iO $ ipeLineSegment (offset s)
                          ! attr SArrow normalArrow
@@ -123,15 +140,18 @@ drawDart gr d s = [ iO $ ipeLineSegment (offset s)
     c = interpolate 0.5 s ^. asPoint
     -- computes the midpoint of the segment.
 
+offset   :: forall lineSegment point r.
+            (LineSegment_ lineSegment point, IsTransformable lineSegment
+            , HasSupportingLine lineSegment
+            , Point_ point 2 r, Real r, Fractional r)
+         => lineSegment -> lineSegment
 offset s = translateBy theOffset s
   where
-    theOffset = negated $ signorm v
+    theOffset :: Vector 2 r
+    theOffset = fmap realToFrac . negated $ signorm (realToFrac @_ @Double <$> v)
+    v :: Vector 2 r
     v = perpendicularTo (supportingLine s) ^. direction
 
-
-
-
-
 drawFace         :: ( PlaneGraph_ planeGraph vertex, Point_ vertex 2 r
                     , Show (Face planeGraph), Ord r, Fractional r)
                  => planeGraph -> FaceIx planeGraph -> SimplePolygon (vertex :+ VertexIx planeGraph) -> [IpeObject r]

hgeometry/test-with-ipe/test/Polygon/Triangulation/TriangulateSpec.hs

@@ -2,23 +2,63 @@
 {-# LANGUAGE QuasiQuotes #-}
 module Polygon.Triangulation.TriangulateSpec (spec) where
 
-import Control.Lens
-import HGeometry
-import HGeometry.Ext
-import HGeometry.Number.Real.Rational
-import HGeometry.PlaneGraph
--- import HGeometry.Polygon.Instances ()
-import HGeometry.Polygon.Triangulation
-import Test.Hspec
-import Test.QuickCheck
-import Test.QuickCheck.Instances ()
+import           Control.Lens
+import           Debug.Trace
+import           HGeometry
+import           HGeometry.Ext
+import           HGeometry.Number.Real.Rational
+import           HGeometry.PlaneGraph
+import           HGeometry.Polygon.Class
+import           HGeometry.Polygon.Simple
+import           HGeometry.Polygon.Triangulation
+import qualified HGeometry.Polygon.Triangulation.TriangulateMonotone as TM
+import           HGeometry.Transformation
+import           Ipe
+import           PlaneGraph.RenderSpec (drawVertex, drawDart, drawFace, drawEdge)
+import           System.OsPath
+import           Test.Hspec
+import           Test.QuickCheck
+import           Test.QuickCheck.Instances ()
 
 --------------------------------------------------------------------------------
 
--- type R = RealNumber 5
+type R = RealNumber 5
 
 spec :: Spec
-spec = pure ()
+spec = describe "triangulateSpec" $ do
+  let g     = traceShowWith (\g' -> ("g", g',"dual g",dualGraph g')) $ TM.triangulate @() buggyPolygon
+      faces' = g^..interiorFacePolygons
+      trigs = graphPolygons $ traceShowWith ("faces",faces',) $ g
+  runIO $ writeIpeFile [osp|/tmp/out.ipe|] . singlePageFromContent $ drawGraph $ scaleUniformlyBy 10 g
+  -- runIO $ writeIpeFile [osp|/tmp/dual.ipe|] . singlePageFromContent $ drawGraph $ scaleUniformlyBy 10 (dualGraph g)
+  it "buggy polygon monotone area" $ do
+    sum (map area trigs) `shouldBe` area buggyPolygon
+
+
+--------------------------------------------------------------------------------
+
+drawGraph    :: ( PlaneGraph_ planeGraph vertex
+                , IsTransformable vertex
+                , Point_ vertex 2 r, Ord r, Real r, Fractional r, Show r, Eq (FaceIx planeGraph)
+                , Show (Vertex planeGraph), Show (Dart planeGraph), Show (Face planeGraph)
+                , Show (EdgeIx planeGraph)
+                ) => planeGraph -> [IpeObject r]
+drawGraph gr = theVertices <> theEdges <> theFaces
+  where
+    theVertices = ifoldMapOf vertices             drawVertex    gr
+    theEdges    = ifoldMapOf dartSegments         (drawDart gr) gr
+               <> ifoldMapOf edgeSegments         (drawEdge gr) gr
+    theFaces    = [] -- ifoldMapOf interiorFacePolygons (drawFace gr) gr
+
+
+buggyPolygon :: SimplePolygon (Point 2 R)
+buggyPolygon = read "SimplePolygon [Point2 9 9,Point2 3 6,Point2 0 3,Point2 2 3,Point2 0 0]"
+
+graphPolygons    :: (Ord r, Num r, Point_ point 2 r)
+                 => PlaneGraph s point PolygonEdgeType PolygonFaceData
+                 -> [SimplePolygon (Point 2 r)]
+graphPolygons gr = map (&vertices %~ view (core.asPoint)) $ gr^..interiorFacePolygons
+
 
 -- spec :: Spec
 -- spec = do testCases [osp|test-with-ipe/Polygon/Triangulation/monotone.ipe|]

hgeometry/test/Polygon/TriangulateSpec.hs

@@ -1,36 +1,58 @@
 {-# LANGUAGE OverloadedStrings #-}
 module Polygon.TriangulateSpec (spec) where
 
-import Control.Lens
-import HGeometry
-import HGeometry.Ext
-import HGeometry.Number.Real.Rational
-import HGeometry.PlaneGraph
-import HGeometry.Polygon.Class
-import HGeometry.Polygon.Instances ()
-import HGeometry.Polygon.Simple
-import HGeometry.Polygon.Triangulation
-import Test.Hspec
-import Test.Hspec.QuickCheck
-import Test.QuickCheck
-import Test.QuickCheck.Instances ()
+import           Control.Lens
+import           HGeometry
+import           HGeometry.Ext
+import           HGeometry.Number.Real.Rational
+import           HGeometry.PlaneGraph
+import           HGeometry.Polygon.Class
+import           HGeometry.Polygon.Instances ()
+import           HGeometry.Polygon.Simple
+import           HGeometry.Polygon.Triangulation
+import qualified HGeometry.Polygon.Triangulation.TriangulateMonotone as TM
+import           Test.Hspec
+import           Test.Hspec.QuickCheck
+import           Test.QuickCheck
+import           Test.QuickCheck.Instances ()
 
+
+
+import           Debug.Trace
 --------------------------------------------------------------------------------
 
 type R = RealNumber 5
 
+
+
 spec :: Spec
 spec = do
-  prop "sum (map area (triangulate polygon)) == area polygon" $
-    \(poly :: SimplePolygon (Point 2 R)) ->
-      let g = triangulate @() poly
-          trigs = graphPolygons g
-      in counterexample (show g) $ sum (map area trigs) === area poly
-  prop "all isTriangle . triangulate" $
-    \(poly :: SimplePolygon (Point 2 R)) ->
-      let g = triangulate @() poly
-          trigs = graphPolygons g
-      in all isTriangle trigs
+  it "buggy polygon diagionals" $
+    computeDiagonals buggyPolygon `shouldBe` [ Vector2 3 1
+                                             , Vector2 3 0
+                                             ]
+  it "buggy polygon monotone area" $
+    let g     = traceShowWith (\g' -> ("dual g",dualGraph g')) $ TM.triangulate @() buggyPolygon
+        faces' = g^..interiorFacePolygons
+        trigs = graphPolygons $ traceShowWith ("faces",faces',) $ g
+    in sum (map area trigs) `shouldBe` area buggyPolygon
+
+
+  it "buggy polygon area" $
+    let g     = traceShowWith (\g' -> ("dual g",dualGraph g')) $ triangulate @() buggyPolygon
+        faces' = g^..interiorFacePolygons
+        trigs = graphPolygons $ traceShowWith ("faces",faces',) $ g
+    in sum (map area trigs) `shouldBe` area buggyPolygon
+  -- prop "sum (map area (triangulate polygon)) == area polygon" $
+  --   \(poly :: SimplePolygon (Point 2 R)) ->
+  --     let g = triangulate @() poly
+  --         trigs = graphPolygons g
+  --     in counterexample (show g) $ sum (map area trigs) === area poly
+  -- prop "all isTriangle . triangulate" $
+  --   \(poly :: SimplePolygon (Point 2 R)) ->
+  --     let g = triangulate @() poly
+  --         trigs = graphPolygons g
+  --     in all isTriangle trigs
 
   -- prop "creating the graph does not create additional diagionals" $
   --   \poly ->
@@ -40,7 +62,10 @@ spec = do
 
 
 
+buggyPolygon :: SimplePolygon (Point 2 R)
+buggyPolygon = read "SimplePolygon [Point2 9 13,Point2 3 6,Point2 0 3,Point2 2 3,Point2 0 0]"
 
+isTriangle :: SimplePolygon (Point 2 R) -> Bool
 isTriangle = (== 3) . numVertices
 
 graphPolygons    :: (Ord r, Num r, Point_ point 2 r)