From cb64fc3d0bac49b9cbae4da16a244921c9f7ff32 Mon Sep 17 00:00:00 2001 From: Frank Staals Date: Sun, 5 Nov 2023 10:06:19 +0100 Subject: [PATCH] furhter line segment intersection work --- hgeometry/hgeometry.cabal | 2 +- .../HGeometry/Kernel/Instances.hs | 7 +- .../kernel/src/HGeometry/LineSegment/Class.hs | 2 +- .../src/HGeometry/LineSegment/Intersection.hs | 105 +++++++- .../kernel/test/HGeometry/LineSegmentSpec.hs | 34 ++- .../Intersection/BentleyOttmann.hs | 255 +++++++++--------- .../Intersection/BentleyOttmannSpec.hs | 8 +- ...LineSegmentSpec_.hs => LineSegmentSpec.hs} | 29 +- 8 files changed, 262 insertions(+), 180 deletions(-) rename hgeometry/test-with-ipe/test/{LineSegmentSpec_.hs => LineSegmentSpec.hs} (73%) diff --git a/hgeometry/hgeometry.cabal b/hgeometry/hgeometry.cabal index a42b25c80..dc88062fa 100644 --- a/hgeometry/hgeometry.cabal +++ b/hgeometry/hgeometry.cabal @@ -635,7 +635,7 @@ test-suite hgeometry-with-ipe-hspec Polygon.Convex.ConvexSpec Polygon.Convex.ConvexSpec VoronoiDiagram.VoronoiSpec - LineSegmentSpec_ + LineSegmentSpec Polygon.Triangulation.TriangulateMonotoneSpec LineSegment.Intersection.BentleyOttmannSpec diff --git a/hgeometry/kernel/src-quickcheck/HGeometry/Kernel/Instances.hs b/hgeometry/kernel/src-quickcheck/HGeometry/Kernel/Instances.hs index dd1ea1fce..49c26a769 100644 --- a/hgeometry/kernel/src-quickcheck/HGeometry/Kernel/Instances.hs +++ b/hgeometry/kernel/src-quickcheck/HGeometry/Kernel/Instances.hs @@ -21,6 +21,7 @@ import HGeometry.HalfSpace import HGeometry.HyperPlane (HyperPlane(..)) import HGeometry.HyperPlane.NonVertical (NonVerticalHyperPlane(..)) import HGeometry.Interval +import HGeometry.Interval.EndPoint import HGeometry.Line.LineEQ import HGeometry.Line.PointAndVector import HGeometry.LineSegment @@ -56,10 +57,12 @@ instance ( Arbitrary (endPoint r) pure $ Interval p q instance ( Arbitrary (endPoint point) - , Eq (endPoint point) + , IsEndPoint (endPoint point) (endPoint point) + , IxValue (endPoint point) ~ point + , Eq point ) => Arbitrary (LineSegment endPoint point) where arbitrary = do p <- arbitrary - q <- arbitrary `suchThat` (/= p) + q <- arbitrary `suchThat` (\q' -> q'^._endPoint /= p^._endPoint) pure $ LineSegment p q instance ( Arbitrary point diff --git a/hgeometry/kernel/src/HGeometry/LineSegment/Class.hs b/hgeometry/kernel/src/HGeometry/LineSegment/Class.hs index 405741cd6..6bbc5cddc 100644 --- a/hgeometry/kernel/src/HGeometry/LineSegment/Class.hs +++ b/hgeometry/kernel/src/HGeometry/LineSegment/Class.hs @@ -19,7 +19,7 @@ module HGeometry.LineSegment.Class , HasStart(..), HasEnd(..) , HasStartPoint(..), HasEndPoint(..) - + , StartPointOf, EndPointOf , ordAtY, ordAtX , xCoordAt, yCoordAt diff --git a/hgeometry/kernel/src/HGeometry/LineSegment/Intersection.hs b/hgeometry/kernel/src/HGeometry/LineSegment/Intersection.hs index 2084f0346..051c417f4 100644 --- a/hgeometry/kernel/src/HGeometry/LineSegment/Intersection.hs +++ b/hgeometry/kernel/src/HGeometry/LineSegment/Intersection.hs @@ -45,26 +45,55 @@ type instance Intersection (LineEQ r) (LineSegment AnEndPoint point) = -- * HasIntersectionWith instance ( Point_ point 2 r, Num r, Ord r - ) => LinePV 2 r `HasIntersectionWith` ClosedLineSegment point where + , IxValue (endPoint point) ~ point + , EndPoint_ (endPoint point) + ) => LinePV 2 r `HasIntersectionWith` LineSegment endPoint point where intersects = intersectsImpl {-# INLINE intersects #-} instance ( Point_ point 2 r, Num r, Ord r - ) => LineEQ r `HasIntersectionWith` ClosedLineSegment point where + , IxValue (endPoint point) ~ point + , EndPoint_ (endPoint point) + ) => LineEQ r `HasIntersectionWith` LineSegment endPoint point where -- -- >>> LineEQ 1 2 `intersects` ClosedLineSegment origin (Point2 1 10) -- True intersects = intersectsImpl {-# INLINE intersects #-} -instance ( Point_ point 2 r, Num r, Ord r - ) => LineEQ r `HasIntersectionWith` LineSegment AnEndPoint point where - intersects = intersectsImpl - {-# INLINE intersects #-} -instance ( Point_ point 2 r, Num r, Ord r - ) => LinePV 2 r `HasIntersectionWith` LineSegment AnEndPoint point where - intersects = intersectsImpl - {-# INLINE intersects #-} + +-- instance ( Point_ point 2 r, Num r, Ord r +-- ) => LinePV 2 r `HasIntersectionWith` ClosedLineSegment point where +-- intersects = intersectsImpl +-- {-# INLINE intersects #-} + +-- instance ( Point_ point 2 r, Num r, Ord r +-- ) => LineEQ r `HasIntersectionWith` ClosedLineSegment point where +-- -- +-- -- >>> LineEQ 1 2 `intersects` ClosedLineSegment origin (Point2 1 10) +-- -- True +-- intersects = intersectsImpl +-- {-# INLINE intersects #-} + +-- instance ( Point_ point 2 r, Num r, Ord r +-- ) => LineEQ r `HasIntersectionWith` LineSegment AnEndPoint point where +-- intersects = intersectsImpl +-- {-# INLINE intersects #-} +-- instance ( Point_ point 2 r, Num r, Ord r +-- ) => LinePV 2 r `HasIntersectionWith` LineSegment AnEndPoint point where +-- intersects = intersectsImpl +-- {-# INLINE intersects #-} + +-- instance ( Point_ point 2 r, Num r, Ord r +-- ) => LinePV 2 r `HasIntersectionWith` OpenLineSegment point where +-- intersects = intersectsImpl +-- {-# INLINE intersects #-} + +-- instance ( Point_ point 2 r, Num r, Ord r +-- ) => LineEQ r `HasIntersectionWith` OpenLineSegment point where +-- intersects = intersectsImpl +-- {-# INLINE intersects #-} + -- | Test whether a line in R^2 intersects a closed linesegment @@ -115,6 +144,19 @@ instance ( Point_ point 2 r intersect = intersectImpl {-# INLINE intersect #-} +instance ( Point_ point 2 r + , Fractional r, Ord r + ) => LinePV 2 r `IsIntersectableWith` OpenLineSegment point where + intersect = intersectImpl + {-# INLINE intersect #-} + +instance ( Point_ point 2 r + , Fractional r, Ord r + ) => LineEQ r `IsIntersectableWith` OpenLineSegment point where + intersect = intersectImpl + {-# INLINE intersect #-} + + -- | Implementation for intersects between lines and line segments. -- -- the type is is sufficiently general that for various line or closed line segment types @@ -136,6 +178,7 @@ l `intersectImpl` s = l `intersect` supportingLine s >>= \case Line_x_Line_Line _ -> Just $ Line_x_LineSegment_LineSegment s {-# INLINE intersectImpl #-} + -------------------------------------------------------------------------------- -- * LineSegment x LineSegment @@ -160,9 +203,49 @@ type instance Intersection (LineSegment AnEndPoint point) ---------------------------------------- -- * HasIntersectionWith +instance ( Point_ point 2 r, Num r, Ord r + , IxValue (endPoint point) ~ point + , EndPoint_ (endPoint point) + ) => + LineSegment endPoint point `HasIntersectionWith` LineSegment endPoint point where + s `intersects `s' = supportingLine s `intersects` s' && supportingLine s' `intersects` s + {-# INLINE intersects #-} + +-- TODO: specialize instance for ClosedLineSegment and AnLineSegment + +instance ( Point_ point 2 r, Num r, Ord r + ) => + LineSegment AnEndPoint point `HasIntersectionWith` ClosedLineSegment point where + s `intersects `s' = supportingLine s `intersects` s' && supportingLine s' `intersects` s + {-# INLINE intersects #-} + +instance ( Point_ point 2 r, Num r, Ord r + ) => + LineSegment AnEndPoint point `HasIntersectionWith` OpenLineSegment point where + s `intersects `s' = supportingLine s `intersects` s' && supportingLine s' `intersects` s + {-# INLINE intersects #-} + +instance ( Point_ point 2 r, Num r, Ord r + ) => + ClosedLineSegment point `HasIntersectionWith` LineSegment AnEndPoint point where + s `intersects `s' = supportingLine s `intersects` s' && supportingLine s' `intersects` s + {-# INLINE intersects #-} + +instance ( Point_ point 2 r, Num r, Ord r + ) => + ClosedLineSegment point `HasIntersectionWith` OpenLineSegment point where + s `intersects `s' = supportingLine s `intersects` s' && supportingLine s' `intersects` s + {-# INLINE intersects #-} + +instance ( Point_ point 2 r, Num r, Ord r + ) => + OpenLineSegment point `HasIntersectionWith` LineSegment AnEndPoint point where + s `intersects `s' = supportingLine s `intersects` s' && supportingLine s' `intersects` s + {-# INLINE intersects #-} + instance ( Point_ point 2 r, Num r, Ord r ) => - LineSegment AnEndPoint point `HasIntersectionWith` LineSegment AnEndPoint point where + OpenLineSegment point `HasIntersectionWith` ClosedLineSegment point where s `intersects `s' = supportingLine s `intersects` s' && supportingLine s' `intersects` s {-# INLINE intersects #-} diff --git a/hgeometry/kernel/test/HGeometry/LineSegmentSpec.hs b/hgeometry/kernel/test/HGeometry/LineSegmentSpec.hs index e094149ab..a9a4d0d14 100644 --- a/hgeometry/kernel/test/HGeometry/LineSegmentSpec.hs +++ b/hgeometry/kernel/test/HGeometry/LineSegmentSpec.hs @@ -1,5 +1,5 @@ -{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE ScopedTypeVariables #-} module HGeometry.LineSegmentSpec where import Control.Lens ((^.), IxValue) @@ -7,20 +7,21 @@ import Data.Ord (comparing) import HGeometry.Ext import HGeometry.Intersection import HGeometry.Number.Real.Rational --- import Data.Vinyl -- import HGeometry.Boundary -- import HGeometry.Box import HGeometry.LineSegment --- import HGeometry.LineSegment.Internal (onSegment, onSegment2) import HGeometry.Point import HGeometry.Interval -import HGeometry.Vector ((*^)) +import HGeometry.HyperPlane +import HGeometry.Vector ((*^), Vector(..)) +import HGeometry.Line.PointAndVector import Test.Hspec.QuickCheck import Test.Hspec import Test.QuickCheck ((===), Arbitrary(..), suchThat, Property, counterexample) import Test.QuickCheck.Instances () import HGeometry.Kernel.Instances () +import Debug.Trace -------------------------------------------------------------------------------- -- main :: IO () -- main = print $ testStartInt @@ -91,15 +92,20 @@ spec = intersects3 = intersects intersects2 :: Point 2 R -> ClosedLineSegment (Point 2 R :+ ()) -> Bool intersects2 = intersects + intersects2' :: Point 2 R -> OpenLineSegment (Point 2 R :+ ()) -> Bool + intersects2' = intersects it "2d on segment tests" $ do let seg1 = ClosedLineSegment (origin :+ ()) (Point2 2 0 :+ ()) seg2 = ClosedLineSegment (origin :+ ()) (Point2 3 3 :+ ()) + seg3 = OpenLineSegment (origin :+ ()) (Point2 3 3 :+ ()) (Point2 1 0 `intersects2` seg1) `shouldBe` True (Point2 1 1 `intersects2` seg1) `shouldBe` False (Point2 5 0 `intersects2` seg1) `shouldBe` False (Point2 (-1) 0 `intersects2` seg1) `shouldBe` False (Point2 1 1 `intersects2` seg2) `shouldBe` True + (Point2 1 1 `intersects2'` seg3) `shouldBe` True + (Point2 0 0 `intersects2'` seg3) `shouldBe` False it "3d on segment tests" $ do let seg = ClosedLineSegment (origin :+ ()) (Point3 3 3 3 :+ ()) @@ -194,16 +200,24 @@ test3 = ClosedLineSegment (Point2 0 21) (Point2 0 5) test4 :: LineSegment AnEndPoint (Point 2 Int) test4 = LineSegment (AnEndPoint Open $ Point2 0 10) (AnEndPoint Closed $ Point2 0 9) +test5 :: OpenLineSegment (Point 2 Int) +test5 = OpenLineSegment (Point2 0 20) (Point2 200 20) + -- -- test = withRank (Vector2 0 1) test1 test4 testI :: Spec testI = describe "some manual intersection tests" $ do - pure () --- it "manual intersection" $ (test1 `intersects` test2 ) `shouldBe` True --- it "manual intersection" $ (test1 `intersects` test3 ) `shouldBe` True --- it "manual intersection" $ (test1 `intersects` test4 ) `shouldBe` False --- it "manual intersection" $ (test2 `intersects` test4 ) `shouldBe` True - + it "manual intersection" $ (test1 `intersects` test2 ) `shouldBe` True + it "manual intersection" $ (test1 `intersects` test3 ) `shouldBe` True + it "manual intersection" $ (test1 `intersects` test4 ) `shouldBe` False + it "manual intersection" $ (test2 `intersects` test4 ) `shouldBe` True + it "manual intersection" $ (test2 `intersects` test5 ) `shouldBe` False + + describe "manual intersect with line" $ do + let l = LinePV origin (Vector2 0 (1 :: Int)) + it "man" $ (l `intersects` test1) `shouldBe` True + it "sideTest" $ traceShow (hyperPlaneEquation l) $ + (onSideTest (test1^.start) l) `shouldBe` EQ diff --git a/hgeometry/src/HGeometry/LineSegment/Intersection/BentleyOttmann.hs b/hgeometry/src/HGeometry/LineSegment/Intersection/BentleyOttmann.hs index e89068b60..591c6ce49 100644 --- a/hgeometry/src/HGeometry/LineSegment/Intersection/BentleyOttmann.hs +++ b/hgeometry/src/HGeometry/LineSegment/Intersection/BentleyOttmann.hs @@ -70,6 +70,7 @@ intersections :: forall lineSegment point r f. , HasOnSegment lineSegment 2 , IntersectConstraints lineSegment , Foldable f, Functor f + , StartPointOf lineSegment ~ EndPointOf lineSegment ) => f lineSegment -> Intersections r lineSegment intersections = fmap unflipSegs . intersections' . fmap tagFlipped @@ -89,6 +90,7 @@ intersections' :: ( LineSegment_ lineSegment point , Ord r, Fractional r , HasOnSegment lineSegment 2 , IntersectConstraints lineSegment + , StartPointOf lineSegment ~ EndPointOf lineSegment , Foldable f ) => f lineSegment -> Intersections r lineSegment @@ -106,135 +108,13 @@ interiorIntersections :: ( LineSegment_ lineSegment point , Eq lineSegment , Ord r, Fractional r , IntersectConstraints lineSegment + , StartPointOf lineSegment ~ EndPointOf lineSegment , HasOnSegment lineSegment 2 , Foldable f, Functor f ) => f lineSegment -> Intersections r lineSegment interiorIntersections = Map.filter isInteriorIntersection . intersections - --------------------------------------------------------------------------------- --- * Flipping and unflipping - -data Flipped segment = NotFlipped segment - | Flipped segment - deriving (Show,Eq,Functor) - --- | Access the underlying segment -rawSegment :: Lens' (Flipped segment) segment -rawSegment = lens (\case - NotFlipped s -> s - Flipped s -> s - ) - (\fs seg -> seg <$ fs) - -type instance NumType (Flipped segment) = NumType segment -type instance Dimension (Flipped segment) = Dimension segment - -type instance Intersection (Flipped segment) (Flipped segment) = - Maybe (LineSegmentLineSegmentIntersection (Flipped segment)) - -instance HasStart lineSegment point => HasStart (Flipped lineSegment) point where - start = rawSegment.start -instance ( HasStartPoint lineSegment endPoint - ) => HasStartPoint (Flipped lineSegment) endPoint where - startPoint = rawSegment.startPoint - -instance HasEnd lineSegment point => HasEnd (Flipped lineSegment) point where - end = rawSegment.end -instance ( HasEndPoint lineSegment endPoint - ) => HasEndPoint (Flipped lineSegment) endPoint where - endPoint = rawSegment.endPoint - -type instance StartPointOf (Flipped lineSegment) = StartPointOf lineSegment -type instance EndPointOf (Flipped lineSegment) = EndPointOf lineSegment - -instance IntervalLike_ lineSegment point => IntervalLike_ (Flipped lineSegment) point where - mkInterval s t = NotFlipped $ mkInterval s t -instance LineSegment_ lineSegment point => LineSegment_ (Flipped lineSegment) point where - uncheckedLineSegment s t = NotFlipped $ uncheckedLineSegment s t - - -instance segment `HasIntersectionWith` segment - => (Flipped segment) `HasIntersectionWith` (Flipped segment) where - a `intersects` b = (a^.rawSegment) `intersects` (b^.rawSegment) - -instance HasOnSegment segment 2 => HasOnSegment (Flipped segment) 2 where - onSegment q s = onSegment q (s^.rawSegment) - -instance (segment `IsIntersectableWith` segment - , Intersection segment segment ~ Maybe (LineSegmentLineSegmentIntersection segment) - ) => (Flipped segment) `IsIntersectableWith` (Flipped segment) where - a `intersect` b = intersect (a^.rawSegment) (b^.rawSegment) <&> \case - LineSegment_x_LineSegment_Point p -> LineSegment_x_LineSegment_Point p - LineSegment_x_LineSegment_LineSegment seg -> - LineSegment_x_LineSegment_LineSegment $ NotFlipped seg - -- TODO: maybe we should actually unflip segments a and b rather than use rawSegment - - --- type instance Intersection (geom :+ Flipped) (geom :+ Flipped) = --- Maybe (LineSegmentLineSegmentIntersection (geom :+ Flipped)) - --- instance IsIntersectableWith geomA geomB --- => IsIntersectableWith (geomA :+ extra) (geomB :+ extra) where --- ga `intersect` gb = (ga^.core) `intersect` (gb^.core) - - - --- | Make sure the 'start' endpoint occurs before the end-endpoints in --- terms of the sweep order. -tagFlipped :: (LineSegment_ lineSegment point, Point_ point 2 r, Ord r) - => lineSegment -> Flipped lineSegment -tagFlipped s = case (s^.start) `ordPoints` (s^.end) of - GT -> Flipped $ flipSeg s - _ -> NotFlipped s - --- | Flips the segment -flipSeg :: LineSegment_ lineSegment point => lineSegment -> lineSegment -flipSeg seg = seg&start .~ (seg^.end) - &end .~ (seg^.start) - - --------------------------------------------------------------------------------- - --- | test if the segment is flipped or not. -isFlipped :: forall f lineSegment. - Coercible (f (Flipped lineSegment)) (Flipped lineSegment) - => f (Flipped lineSegment) -> Bool -isFlipped = (\case - Flipped _ -> True - _ -> False) . coerce @_ @(Flipped lineSegment) - --- | Unflips the segments in an associated. -unflipSegs :: ( LineSegment_ lineSegment point - , Point_ point 2 r - , Fractional r, Ord r - , IntersectConstraints lineSegment - ) - => Associated (Flipped lineSegment) - -> Associated lineSegment -unflipSegs assocs = Associated (dropFlipped ss1 <> unflipSegs' es) - (dropFlipped es1 <> unflipSegs' ss) - (dropFlipped is1 <> unflipSegs' is) - where - (ss,ss1) = Set.partition isFlipped $ assocs^.startPointOf - (es,es1) = Set.partition isFlipped $ assocs^.endPointOf - (is,is1) = Set.partition isFlipped $ assocs^.interiorTo - - -- | For segments that are not acutally flipped, we can just drop the flipped bit - dropFlipped :: Functor f - => Set.Set (f (Flipped lineSegment)) -> Set.Set (f lineSegment) - dropFlipped = Set.mapMonotonic (fmap $ view rawSegment) - --- | For flipped segs we unflip them (and appropriately coerce the so that they remain in --- the same order. I.e. if they were sorted around the start point they are now sorted --- around the endpoint. -unflipSegs' :: ( Functor f, Coercible (f lineSegment) (g lineSegment) - , LineSegment_ lineSegment point - ) - => Set.Set (f (Flipped lineSegment)) -> Set.Set (g lineSegment) -unflipSegs' = Set.mapMonotonic (coerce . fmap (flipSeg . view rawSegment)) - -------------------------------------------------------------------------------- -- | Computes the event points for a given line segment @@ -534,3 +414,132 @@ propSameAsSeparate p xs = overlapsWithNeighbour p xs `shouldBe` overlapsWithNeig test' = overlapsWithNeighbour (==) testOverlapNext testOverlapNext = [1,2,3,3,3,5,6,6,8,10,11,34,2,2,3] + +-------------------------------------------------------------------------------- + +-------------------------------------------------------------------------------- +-- * Flipping and unflipping + +data Flipped segment = NotFlipped segment + | Flipped segment + deriving (Show,Eq,Functor) + +-- | Access the underlying segment +rawSegment :: Lens' (Flipped segment) segment +rawSegment = lens (\case + NotFlipped s -> s + Flipped s -> s + ) + (\fs seg -> seg <$ fs) + +type instance NumType (Flipped segment) = NumType segment +type instance Dimension (Flipped segment) = Dimension segment + +type instance Intersection (Flipped segment) (Flipped segment) = + Maybe (LineSegmentLineSegmentIntersection (Flipped segment)) + +instance HasStart lineSegment point => HasStart (Flipped lineSegment) point where + start = rawSegment.start +instance ( HasStartPoint lineSegment endPoint + ) => HasStartPoint (Flipped lineSegment) endPoint where + startPoint = rawSegment.startPoint + +instance HasEnd lineSegment point => HasEnd (Flipped lineSegment) point where + end = rawSegment.end +instance ( HasEndPoint lineSegment endPoint + ) => HasEndPoint (Flipped lineSegment) endPoint where + endPoint = rawSegment.endPoint + +type instance StartPointOf (Flipped lineSegment) = StartPointOf lineSegment +type instance EndPointOf (Flipped lineSegment) = EndPointOf lineSegment + +instance IntervalLike_ lineSegment point => IntervalLike_ (Flipped lineSegment) point where + mkInterval s t = NotFlipped $ mkInterval s t +instance LineSegment_ lineSegment point => LineSegment_ (Flipped lineSegment) point where + uncheckedLineSegment s t = NotFlipped $ uncheckedLineSegment s t + + +instance segment `HasIntersectionWith` segment + => (Flipped segment) `HasIntersectionWith` (Flipped segment) where + a `intersects` b = (a^.rawSegment) `intersects` (b^.rawSegment) + +instance HasOnSegment segment 2 => HasOnSegment (Flipped segment) 2 where + onSegment q s = onSegment q (s^.rawSegment) + +instance (segment `IsIntersectableWith` segment + , Intersection segment segment ~ Maybe (LineSegmentLineSegmentIntersection segment) + ) => (Flipped segment) `IsIntersectableWith` (Flipped segment) where + a `intersect` b = intersect (a^.rawSegment) (b^.rawSegment) <&> \case + LineSegment_x_LineSegment_Point p -> LineSegment_x_LineSegment_Point p + LineSegment_x_LineSegment_LineSegment seg -> + LineSegment_x_LineSegment_LineSegment $ NotFlipped seg + -- TODO: maybe we should actually unflip segments a and b rather than use rawSegment + + +-- type instance Intersection (geom :+ Flipped) (geom :+ Flipped) = +-- Maybe (LineSegmentLineSegmentIntersection (geom :+ Flipped)) + +-- instance IsIntersectableWith geomA geomB +-- => IsIntersectableWith (geomA :+ extra) (geomB :+ extra) where +-- ga `intersect` gb = (ga^.core) `intersect` (gb^.core) + + + +-- | Make sure the 'start' endpoint occurs before the end-endpoints in +-- terms of the sweep order. +tagFlipped :: (LineSegment_ lineSegment point, Point_ point 2 r, Ord r + , StartPointOf lineSegment ~ EndPointOf lineSegment + ) + => lineSegment -> Flipped lineSegment +tagFlipped s = case (s^.start) `ordPoints` (s^.end) of + GT -> Flipped $ flipSeg s + _ -> NotFlipped s + +-- | Flips the segment +flipSeg :: ( LineSegment_ lineSegment point + , StartPointOf lineSegment ~ EndPointOf lineSegment + ) => lineSegment -> lineSegment +flipSeg seg = seg&startPoint .~ (seg^.endPoint) + &endPoint .~ (seg^.startPoint) + +-------------------------------------------------------------------------------- + +-- | test if the segment is flipped or not. +isFlipped :: forall f lineSegment. + Coercible (f (Flipped lineSegment)) (Flipped lineSegment) + => f (Flipped lineSegment) -> Bool +isFlipped = (\case + Flipped _ -> True + _ -> False) . coerce @_ @(Flipped lineSegment) + +-- | Unflips the segments in an associated. +unflipSegs :: ( LineSegment_ lineSegment point + , Point_ point 2 r + , Fractional r, Ord r + , IntersectConstraints lineSegment + , StartPointOf lineSegment ~ EndPointOf lineSegment + ) + => Associated (Flipped lineSegment) + -> Associated lineSegment +unflipSegs assocs = Associated (dropFlipped ss1 <> unflipSegs' es) + (dropFlipped es1 <> unflipSegs' ss) + (dropFlipped is1 <> unflipSegs' is) + where + (ss,ss1) = Set.partition isFlipped $ assocs^.startPointOf + (es,es1) = Set.partition isFlipped $ assocs^.endPointOf + (is,is1) = Set.partition isFlipped $ assocs^.interiorTo + + -- | For segments that are not acutally flipped, we can just drop the flipped bit + dropFlipped :: Functor f + => Set.Set (f (Flipped lineSegment)) -> Set.Set (f lineSegment) + dropFlipped = Set.mapMonotonic (fmap $ view rawSegment) + +-- | For flipped segs we unflip them (and appropriately coerce the so that they remain in +-- the same order. I.e. if they were sorted around the start point they are now sorted +-- around the endpoint. +unflipSegs' :: ( Functor f, Coercible (f lineSegment) (g lineSegment) + , LineSegment_ lineSegment point + , StartPointOf lineSegment ~ EndPointOf lineSegment + ) + => Set.Set (f (Flipped lineSegment)) -> Set.Set (g lineSegment) +unflipSegs' = Set.mapMonotonic (coerce . fmap (flipSeg . view rawSegment)) diff --git a/hgeometry/test-with-ipe/test/LineSegment/Intersection/BentleyOttmannSpec.hs b/hgeometry/test-with-ipe/test/LineSegment/Intersection/BentleyOttmannSpec.hs index 23b7ee904..986b94fc2 100644 --- a/hgeometry/test-with-ipe/test/LineSegment/Intersection/BentleyOttmannSpec.hs +++ b/hgeometry/test-with-ipe/test/LineSegment/Intersection/BentleyOttmannSpec.hs @@ -12,10 +12,8 @@ import Control.Lens import HGeometry.Ext import HGeometry.LineSegment import HGeometry.Point -import LineSegmentSpec_ (arrowAsOpen) -import Data.List (intercalate) +import LineSegmentSpec (arrowAsOpen) import qualified Data.Map as Map -import Data.Proxy import HGeometry.Number.Real.Rational import Ipe import System.OsPath @@ -73,7 +71,7 @@ samePointsAsNaive :: ( LineSegment_ lineSegment point , Ord r, Fractional r , HasOnSegment lineSegment 2 , IntersectConstraints lineSegment - -- , IntersectConstraints (lineSegment :+ Flipped) + , StartPointOf lineSegment ~ EndPointOf lineSegment , Show lineSegment, Show r ) => [lineSegment] -> Spec @@ -87,7 +85,7 @@ sameAsNaive :: ( LineSegment_ lineSegment point , Ord r, Fractional r , HasOnSegment lineSegment 2 , IntersectConstraints lineSegment - -- , IntersectConstraints (lineSegment :+ Flipped) + , StartPointOf lineSegment ~ EndPointOf lineSegment , Show lineSegment, Show r ) => [lineSegment] -> Spec diff --git a/hgeometry/test-with-ipe/test/LineSegmentSpec_.hs b/hgeometry/test-with-ipe/test/LineSegmentSpec.hs similarity index 73% rename from hgeometry/test-with-ipe/test/LineSegmentSpec_.hs rename to hgeometry/test-with-ipe/test/LineSegmentSpec.hs index dbe584135..7d28dbadf 100644 --- a/hgeometry/test-with-ipe/test/LineSegmentSpec_.hs +++ b/hgeometry/test-with-ipe/test/LineSegmentSpec.hs @@ -1,5 +1,5 @@ {-# LANGUAGE QuasiQuotes #-} -module LineSegmentSpec_ where +module LineSegmentSpec where import Control.Lens import Control.Monad ((>=>)) @@ -31,7 +31,7 @@ getDataFileName' = decodeFS >=> getDataFileName >=> encodeFS spec :: Spec -spec = pure () +spec = testI {- describe "linesegment x box intersection tests" $ do @@ -73,28 +73,3 @@ arrowAsOpen ((LineSegment_ p q) :+ ats) = f x = case ats^?_Attr x of Just _ -> AnOpenE Nothing -> AnClosedE - - - -test1 :: ClosedLineSegment (Point 2 Int) -test1 = ClosedLineSegment (Point2 0 10) (Point2 0 20) - -test2 :: OpenLineSegment (Point 2 Int) -test2 = OpenLineSegment (Point2 0 5) (Point2 0 20) - -test3 :: ClosedLineSegment (Point 2 Int) -test3 = ClosedLineSegment (Point2 0 21) (Point2 0 5) - -test4 :: LineSegment AnEndPoint (Point 2 Int) -test4 = LineSegment (AnOpenE $ Point2 0 10) (AnClosedE $ Point2 0 9) - --- test = withRank (Vector2 0 1) test1 test4 - -{- -testI = describe "some manual intersection tests" $ do - it "manual intersection" $ (test1 `intersects` test2 ) `shouldBe` True - it "manual intersection" $ (test1 `intersects` test3 ) `shouldBe` True - it "manual intersection" $ (test1 `intersects` test4 ) `shouldBe` False - it "manual intersection" $ (test2 `intersects` test4 ) `shouldBe` True - --}