From 1e43dc86e97ede5e1a7f149ffa82b3d0acf1b046 Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Sat, 12 Jun 2021 12:20:43 +0200 Subject: [PATCH] ... --- Graphics/Slicer/Math/Contour.hs | 63 +++++++++++++++++++++++++++++---- hslice.cabal | 2 ++ tests/Main.hs | 6 ++++ 3 files changed, 65 insertions(+), 6 deletions(-) diff --git a/Graphics/Slicer/Math/Contour.hs b/Graphics/Slicer/Math/Contour.hs index 0cd8a691b..6ed024ba5 100644 --- a/Graphics/Slicer/Math/Contour.hs +++ b/Graphics/Slicer/Math/Contour.hs @@ -19,11 +19,13 @@ -- for not handling faces: {-# LANGUAGE PartialTypeSignatures #-} -{-# OPTIONS_GHC -Wno-partial-type-signatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-partial-type-signatures -Wno-orphans -Wno-monomorphism-restriction #-} -module Graphics.Slicer.Math.Contour (followingLineSeg, getContours, makeContourTree, ContourTree(ContourTree), contourContainsContour, contourIntersections, contourIntersectionsNonTotal, numPointsOfContour, pointsOfContour, firstLineSegOfContour, firstPointOfContour, justOneContourFrom, lastPointOfContour, makeSafeContour, linesOfContour) where +module Graphics.Slicer.Math.Contour (followingLineSeg, getContours, makeContourTree, ContourTree(ContourTree), contourContainsContour, contourIntersections, contourIntersectionsNonTotal, numPointsOfContour, pointsOfContour, firstLineSegOfContour, firstPointOfContour, justOneContourFrom, lastPointOfContour, makeSafeContour, linesOfContour, specs) where -import Prelude ((==), Int, (+), otherwise, (.), null, (<$>), ($), length, Show, filter, (/=), odd, snd, error, (<>), show, fst, Bool(True,False), Eq, Show, not, compare, zip, Either(Left, Right)) +import Prelude ((==), Int, (+), otherwise, (.), null, (<$>), (<*>), ($), length, Show, filter, (/=), odd, snd, error, (<>), show, fst, Bool(True,False), Eq, Show, not, compare, zip, Either(Left, Right)) import Data.List(tail, last, head, partition, reverse, sortBy) @@ -45,6 +47,10 @@ import Graphics.Slicer.Math.Line (LineSeg, lineSegFromEndpoints, makeLineSegsLoo import Graphics.Slicer.Math.PGA (Intersection(NoIntersection, HitStartPoint, HitEndPoint), PIntersection (PParallel, PAntiParallel, IntersectsIn), eToPPoint2, lineIsLeft, pointOnPerp, intersectsWith, plineFromEndpoints, pToEPoint2, PPoint2, PLine2, join2PPoint2) +import Test.Hspec +import Test.QuickCheck +import Debug.Trace + -- Unapologetically ripped from ImplicitCAD. -- Added the ability to look at line segments backwards. @@ -145,9 +151,27 @@ makeContourTree :: [Contour] -> [ContourTree] makeContourTree [] = [] makeContourTree [contour] = [ContourTree (contour, [])] makeContourTree contours = [ContourTree (foundContour, makeContourTree $ contoursWithAncestor contours foundContour) | foundContour <- contoursWithoutParents contours] - where - contoursWithAncestor cs c = mapMaybe (\cx -> if contourContainsContour c cx then Just cx else Nothing) $ filter (/=c) cs - contoursWithoutParents cs = catMaybes $ [ if null $ mapMaybe (\cx -> if contourContainedByContour contourToCheck cx then Just cx else Nothing) (filter (/=contourToCheck) cs) then Just contourToCheck else Nothing | contourToCheck <- cs ] + +{- ORMOLU_ENSABLE -} + +contoursWithAncestor :: [Contour] -> Contour -> [Contour] +contoursWithAncestor cs c = [ cx + | cx <- cs + , cx /= c + , contourContainsContour c cx + ] + +contoursWithoutParents :: [Contour] -> [Contour] +contoursWithoutParents cs = [ contourToCheck + | contourToCheck <- cs + , null [ () + | cx <- cs + , cx /= contourToCheck + , contourContainedByContour contourToCheck cx + ] + ] + +{- ORMOLU_DISABLE -} -- | Determine whether a contour is contained inside of another contour. -- FIXME: magic numbers. @@ -269,3 +293,30 @@ firstLineSegOfContour (SafeContour p1 p2 _ _) = case lineSegFromEndpoints p1 p2 linesOfContour :: Contour -> [LineSeg] linesOfContour contour = makeLineSegsLooped $ pointsOfContour contour +---------------------------------------------------------------------- +-- test suite + +specs :: Spec +specs = describe "helpers" $ do + describe "contoursWithAncestor" $ do + it "behaves like its bench implementation" . property $ + \(cs, c) -> traceShow (cs, c) $ contoursWithAncestor cs c `shouldBe` contoursWithAncestorBench cs c + describe "contoursWithoutParents" $ do + it "behaves like its bench implementation" . property $ + \cs -> traceShow cs $ contoursWithoutParents cs `shouldBe` contoursWithoutParentsBench cs + +instance Arbitrary Contour where + arbitrary = SafeContour <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary + +instance Arbitrary Point2 where + arbitrary = Point2 <$> ((,) <$> arbr <*> arbr) + where arbr = elements [0.001, 0.002, 0.1, 0.2, 0.3, 0.8, 1, 2, 3, 8, 10] + +instance Arbitrary [a] => Arbitrary (Slist a) where + arbitrary = slist <$> arbitrary + +contoursWithAncestorBench :: [Contour] -> Contour -> [Contour] +contoursWithAncestorBench cs c = mapMaybe (\cx -> if contourContainsContour c cx then Just cx else Nothing) $ filter (/= c) cs + +contoursWithoutParentsBench :: [Contour] -> [Contour] +contoursWithoutParentsBench cs = catMaybes $ [if null $ mapMaybe (\cx -> if contourContainedByContour contourToCheck cx then Just cx else Nothing) (filter (/= contourToCheck) cs) then Just contourToCheck else Nothing | contourToCheck <- cs] diff --git a/hslice.cabal b/hslice.cabal index ff40c2b03..999566545 100644 --- a/hslice.cabal +++ b/hslice.cabal @@ -77,6 +77,8 @@ Library , slist >=0.2.0.0 , Unique , utf8-string + , hspec + , QuickCheck Exposed-Modules: Graphics.Slicer Graphics.Slicer.Formats.STL.Definitions diff --git a/tests/Main.hs b/tests/Main.hs index 6a39bde12..0979dbc67 100644 --- a/tests/Main.hs +++ b/tests/Main.hs @@ -28,6 +28,8 @@ import Test.Hspec(hspec, describe) -- the execution test for warnings. import Math.PGA(contourSpec, lineSpec, linearAlgSpec, geomAlgSpec, pgaSpec, proj2DGeomAlgSpec, facetSpec) +import qualified Graphics.Slicer.Math.Contour (specs) + main :: IO () main = hspec $ do -- run tests against the mixed algebra engine. @@ -41,3 +43,7 @@ main = hspec $ do describe "2D PGA operations" pgaSpec -- run tests of the facet engine. describe "Contour facetization algorithms" facetSpec + + -- experimental new shape for the test suite: have all the tests in the production modules, + -- but export only the `specs` to run it here. + describe "Graphics.Slicer.Math.Contour" Graphics.Slicer.Math.Contour.specs