module Algorithms.Geometry.LineSegmentIntersection.BentleyOttmannSpec where import qualified Algorithms.Geometry.LineSegmentIntersection.BentleyOttmann as Sweep import qualified Algorithms.Geometry.LineSegmentIntersection.Naive as Naive import Algorithms.Geometry.LineSegmentIntersection.Types import Control.Lens import Data.Ext import Data.Geometry.Interval import Data.Geometry.Ipe import Data.Geometry.LineSegment import Data.Geometry.Point import qualified Data.List as L import qualified Data.List.NonEmpty as NonEmpty import qualified Data.Map as Map import qualified Data.Set as Set import Test.Hspec import Test.QuickCheck import Util spec :: Spec spec = do describe "Testing Bentley Ottmann LineSegment Intersection" $ do -- toSpec (TestCase "myPoints" myPoints) -- toSpec (TestCase "myPoints'" myPoints') ipeSpec ipeSpec :: Spec ipeSpec = testCases "test/Algorithms/Geometry/LineSegmentIntersection/manual.ipe" testCases :: FilePath -> Spec testCases fp = (runIO $ readInput fp) >>= \case Left e -> it "reading LineSegment Intersection file" $ expectationFailure $ "Failed to read ipe file " ++ show e Right tcs -> mapM_ toSpec tcs -- | Point sets per color, Crosses form the solution readInput :: FilePath -> IO (Either ConversionError [TestCase Rational]) readInput fp = fmap f <$> readSinglePageFile fp where f page = [TestCase segs] where segs = page^..content.traverse._IpePath.core._asLineSegment data TestCase r = TestCase { _segments :: [LineSegment 2 () r] } deriving (Show,Eq) toSpec :: (Fractional r, Ord r, Show r) => TestCase r -> Spec toSpec (TestCase segs) = describe ("testing segments ") $ do samePointsAsNaive segs sameAsNaive segs -- | Test if we have the same intersection points samePointsAsNaive segs = it "Same points as Naive" $ do (Map.keys $ Sweep.intersections segs) `shouldBe` (Map.keys $ Naive.intersections segs) -- | Test if they every intersection point has the right segments sameAsNaive :: (Fractional r, Ord r, Eq p , Show p, Show r ) => [LineSegment 2 p r] -> Spec sameAsNaive segs = it "Same as Naive " $ do (Sweep.intersections segs) `shouldBe` (Naive.intersections segs)