From 3a97a0dbd08c6cb056a2a8680fd3acdbb6c2a0c3 Mon Sep 17 00:00:00 2001 From: Frank Staals Date: Sun, 7 Apr 2024 12:10:21 +0200 Subject: [PATCH] some more debugging functions eand tests --- .../golden/PlaneGraph/smallPlaneGraph.ipe | 14 +++- hgeometry/src/HGeometry/PlaneGraph/Type.hs | 7 ++ .../src/HGeometry/Polygon/Triangulation.hs | 1 - .../test/PlaneGraph/RenderSpec.hs | 36 +++++++--- .../Polygon/Triangulation/TriangulateSpec.hs | 64 +++++++++++++---- hgeometry/test/Polygon/TriangulateSpec.hs | 71 +++++++++++++------ 6 files changed, 147 insertions(+), 46 deletions(-) diff --git a/hgeometry/data/test-with-ipe/golden/PlaneGraph/smallPlaneGraph.ipe b/hgeometry/data/test-with-ipe/golden/PlaneGraph/smallPlaneGraph.ipe index 8988561db..5ae5285d5 100644 --- a/hgeometry/data/test-with-ipe/golden/PlaneGraph/smallPlaneGraph.ipe +++ b/hgeometry/data/test-with-ipe/golden/PlaneGraph/smallPlaneGraph.ipe @@ -133,7 +133,7 @@ -Point2 0.0 0.0 :+ 0Point2 200.0 200.0 :+ 1Point2 200.0 0.0 :+ 2Point2 (-100.0) 400.0 :+ 30.0 1.0 m +Point2 0.0 0.0 :+ 0Point2 200.0 200.0 :+ 1Point2 200.0 0.0 :+ 2Point2 (-100.0) 400.0 :+ 30.0 1.0 m 200.0 1.0 l "0->2"200.0 -1.0 m 0.0 -1.0 l @@ -153,7 +153,17 @@ 201.0 0.0 l "1->2"199.0 0.0 m 199.0 200.0 l -"2->1"0.0 0.0 m +"2->1"0.0 0.0 m +200.0 0.0 l +Dart (Arc 0) +10.0 0.0 m +200.0 200.0 l +Dart (Arc 1) +10.0 0.0 m +-100.0 400.0 l +Dart (Arc 2) +1200.0 200.0 m +-100.0 400.0 l +Dart (Arc 3) +1200.0 200.0 m +200.0 0.0 l +Dart (Arc 4) +10.0 0.0 m 200.0 0.0 l 200.0 200.0 l h diff --git a/hgeometry/src/HGeometry/PlaneGraph/Type.hs b/hgeometry/src/HGeometry/PlaneGraph/Type.hs index 52d8942e7..8eba028b0 100644 --- a/hgeometry/src/HGeometry/PlaneGraph/Type.hs +++ b/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 diff --git a/hgeometry/src/HGeometry/Polygon/Triangulation.hs b/hgeometry/src/HGeometry/Polygon/Triangulation.hs index 2d91d76f6..7463f14c6 100644 --- a/hgeometry/src/HGeometry/Polygon/Triangulation.hs +++ b/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 diff --git a/hgeometry/test-with-ipe/test/PlaneGraph/RenderSpec.hs b/hgeometry/test-with-ipe/test/PlaneGraph/RenderSpec.hs index 539ba5248..caa710ff2 100644 --- a/hgeometry/test-with-ipe/test/PlaneGraph/RenderSpec.hs +++ b/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] diff --git a/hgeometry/test-with-ipe/test/Polygon/Triangulation/TriangulateSpec.hs b/hgeometry/test-with-ipe/test/Polygon/Triangulation/TriangulateSpec.hs index 3d7fbfdaa..8eee19f35 100644 --- a/hgeometry/test-with-ipe/test/Polygon/Triangulation/TriangulateSpec.hs +++ b/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|] diff --git a/hgeometry/test/Polygon/TriangulateSpec.hs b/hgeometry/test/Polygon/TriangulateSpec.hs index 2eaaa6302..c6d74d9b2 100644 --- a/hgeometry/test/Polygon/TriangulateSpec.hs +++ b/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)