diff --git a/hgeometry/src/HGeometry/LineSegment/Intersection/BentleyOttmann.hs b/hgeometry/src/HGeometry/LineSegment/Intersection/BentleyOttmann.hs index 4c517d49f..911e23873 100644 --- a/hgeometry/src/HGeometry/LineSegment/Intersection/BentleyOttmann.hs +++ b/hgeometry/src/HGeometry/LineSegment/Intersection/BentleyOttmann.hs @@ -46,17 +46,18 @@ import qualified Data.Set as EQ -- event queue import qualified Data.Set as SS -- status struct import qualified Data.Set as Set import qualified Data.Vector as Vector --- import HGeometry.Ext import HGeometry.Foldable.Sort import HGeometry.Intersection +import HGeometry.Interval.Class import HGeometry.Interval.EndPoint import HGeometry.LineSegment +import HGeometry.LineSegment.Class import HGeometry.LineSegment.Intersection.Types import HGeometry.Point -import qualified HGeometry.Set.Util as SS -- status struct -import HGeometry.Interval.Class -import HGeometry.LineSegment.Class import HGeometry.Properties (NumType, Dimension) +import qualified HGeometry.Set.Util as SS -- status struct + +-- import Debug.Trace -------------------------------------------------------------------------------- @@ -97,7 +98,7 @@ intersections' :: ( LineSegment_ lineSegment point => f lineSegment -> Intersections r lineSegment intersections' segs = merge $ sweep pts SS.empty where - pts = EQ.fromAscList . groupStarts . sort . foldMap (asEventPts . id) $ segs + pts = EQ.fromAscList . groupStarts . sort . foldMap asEventPts $ segs -- | Computes all intersection points p s.t. p lies in the interior of at least @@ -207,7 +208,7 @@ isOpen :: EndPoint_ endPoint => endPoint -> Bool isOpen = (== Open) . endPointType isClosed :: EndPoint_ endPoint => endPoint -> Bool -isClosed = (== Open) . endPointType +isClosed = (== Closed) . endPointType -- | Handle an event point handle :: ( LineSegment_ lineSegment point @@ -237,7 +238,7 @@ handle e@(eventPoint -> p) eq ss = toReport <> sweep eq' ss' closedEnds = filter (isClosed . view endPoint) ends toReport = case starts' <> closedEnds <> pureContains of - (_:_:_) -> [mkIntersectionPoint p (starts' <> closedEnds) pureContains] + (_:_:_) -> [ mkIntersectionPoint p (starts' <> closedEnds) pureContains ] _ -> [] -- new status structure @@ -367,6 +368,12 @@ overlapsOr p q = map fst . filter snd . map (\((a,b),b') -> (a, b || b')) . overlapsWithNeighbour (q `on` fst) . map (\x -> (x, p x)) + +-- -- | Compute every element together with its neighbours +-- withNeighbours :: [a] -> (a,[a]) +-- withNeighbours xs = let xs'@(_:succs) = map (:[]) xs +-- in List.zipWith3 (\p x s -> (x,p <> s)) ([]:xs') (succs <> repeat []) + -- | Given a predicate, test and a list, annotate each element whether -- it, together with one of its neighbors satisifies the predicate. overlapsWithNeighbour :: (a -> a -> Bool) -> [a] -> [(a,Bool)] @@ -377,10 +384,19 @@ overlapsWithNeighbour p = go0 (x:xs) -> go x False xs go x b = \case - [] -> [] + [] -> [(x,b)] (y:ys) -> let b' = p x y in (x,b || b') : go y b' ys + + -- map (\(x,ns) -> case ns of + -- [a] -> (x, p x a) + -- [a,b] -> (x, p x a || p x b) + -- _ -> error "overlapsWithNeighbour. absurd" + -- ) . withNeighbours + + + -- annotateReport :: (a -> Bool) -> [a] -> [(a,Bool)] -- annotateReport p = map (\x -> (x, p x)) diff --git a/hgeometry/src/HGeometry/LineSegment/Intersection/Types.hs b/hgeometry/src/HGeometry/LineSegment/Intersection/Types.hs index 0cc5f1b5f..62d858c8e 100644 --- a/hgeometry/src/HGeometry/LineSegment/Intersection/Types.hs +++ b/hgeometry/src/HGeometry/LineSegment/Intersection/Types.hs @@ -144,10 +144,10 @@ cmpAroundP p s s' = ccwCmpAround (p^.asPoint) (s^.start.asPoint) (s'^.start.asP -- if somehow the segment is degenerate, and p is both the start and -- end it is reported only as the start point. data Associated lineSegment = - Associated { _startPointOf :: Set.Set (AroundEnd lineSegment) + Associated { _startPointOf :: Set.Set (AroundStart lineSegment) -- ^ segments for which the intersection point is the -- start point (i.e. s^.start == p) - , _endPointOf :: Set.Set (AroundStart lineSegment) + , _endPointOf :: Set.Set (AroundEnd lineSegment) -- ^ segments for which the intersection point is the end -- point (i.e. s^.end == p) , _interiorTo :: Set.Set (AroundIntersection lineSegment) @@ -206,8 +206,8 @@ mkAssociated :: ( LineSegment_ lineSegment point ) => point' -> lineSegment -> Associated lineSegment mkAssociated p s - | p^.asPoint == s^.start.asPoint = mempty&startPointOf .~ Set.singleton (AroundEnd s) - | p^.asPoint == s^.end.asPoint = mempty&endPointOf .~ Set.singleton (AroundStart s) + | p^.asPoint == s^.start.asPoint = mempty&startPointOf .~ Set.singleton (AroundStart s) + | p^.asPoint == s^.end.asPoint = mempty&endPointOf .~ Set.singleton (AroundEnd s) | otherwise = mempty&interiorTo .~ Set.singleton (AroundIntersection s) diff --git a/hgeometry/test-with-ipe/test/LineSegment/Intersection/BentleyOttmannSpec.hs b/hgeometry/test-with-ipe/test/LineSegment/Intersection/BentleyOttmannSpec.hs index d05b98964..cdac4fd4b 100644 --- a/hgeometry/test-with-ipe/test/LineSegment/Intersection/BentleyOttmannSpec.hs +++ b/hgeometry/test-with-ipe/test/LineSegment/Intersection/BentleyOttmannSpec.hs @@ -30,14 +30,25 @@ spec = do describe "Testing Bentley Ottmann LineSegment Intersection" $ do -- toSpec (TestCase "myPoints" myPoints) -- toSpec (TestCase "myPoints'" myPoints') - ipeSpec + manualSpec + -- ipeSpec + + +manualSpec = describe "manual" $ do + let seg1,seg2 :: ClosedLineSegment (Point 2 R) + seg1 = ClosedLineSegment (Point2 16 16) (Point2 144 80) + seg2 = ClosedLineSegment (Point2 144 80) (Point2 225 52) + sameAsNaive [seg1,seg2] testPath = [osp|test-with-ipe//LineSegment/Intersection/|] ipeSpec :: Spec ipeSpec = do -- testCases (testPath <> [osp|open_bug.ipe|]) testCases (testPath <> [osp|manual.ipe|]) - -- testCases (testPath <> [osp|open.ipe|]) + testCases (testPath <> [osp|open.ipe|]) + + + -- openCorrect (TestCase name segs) = @@ -81,12 +92,13 @@ samePointsAsNaive :: ( LineSegment_ lineSegment point , IntersectConstraints lineSegment , StartPointOf lineSegment ~ EndPointOf lineSegment , Show lineSegment, Show r + , Show point ) => [lineSegment] -> Spec 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 +-- | Test if they evzery intersection point has the right segments sameAsNaive :: ( LineSegment_ lineSegment point , Point_ point 2 r , Eq lineSegment @@ -95,6 +107,7 @@ sameAsNaive :: ( LineSegment_ lineSegment point , IntersectConstraints lineSegment , StartPointOf lineSegment ~ EndPointOf lineSegment , Show lineSegment, Show r + , Show point ) => [lineSegment] -> Spec sameAsNaive segs = it "Same as Naive " $ do