fixed some bugs :)

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))
 

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)
 
 

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