diff --git a/hgeometry/kernel/src/HGeometry/Interval/EndPoint.hs b/hgeometry/kernel/src/HGeometry/Interval/EndPoint.hs index 07013849f..f3278c401 100644 --- a/hgeometry/kernel/src/HGeometry/Interval/EndPoint.hs +++ b/hgeometry/kernel/src/HGeometry/Interval/EndPoint.hs @@ -40,7 +40,7 @@ class IsEndPoint endPoint endPoint => EndPoint_ endPoint where mkEndPoint :: IxValue endPoint -> endPoint -- | Possible endpoint types; open or closed -data EndPointType = Open | Closed deriving (Show,Eq,Enum,Bounded) +data EndPointType = Open | Closed deriving (Show,Eq,Ord,Enum,Bounded) -- testV :: Vector 2 (Point 2 Double) @@ -117,7 +117,7 @@ pattern OpenE x = EndPoint x -- | Data type modelling an endpoint that can both be open and closed. data AnEndPoint r = AnEndPoint {-# UNPACK #-} !EndPointType !r - deriving (Show,Eq,Functor,Foldable,Traversable) + deriving (Show,Eq,Ord,Functor,Foldable,Traversable) type instance NumType (AnEndPoint r) = r type instance IxValue (AnEndPoint r) = r diff --git a/hgeometry/kernel/src/HGeometry/Interval/Internal.hs b/hgeometry/kernel/src/HGeometry/Interval/Internal.hs index 2b13fd337..4dea2b4e1 100644 --- a/hgeometry/kernel/src/HGeometry/Interval/Internal.hs +++ b/hgeometry/kernel/src/HGeometry/Interval/Internal.hs @@ -224,6 +224,7 @@ instance Ord r -- deriving stock instance (Show r) => Show (IntersectionOf (ClosedInterval r) (ClosedInterval r) ) -------------------------------------------------------------------------------- +-- * Representing Interval intersections -- | Data type representing intersections of intervals of the same type data Interval_x_IntervalIntersection r interval = @@ -235,58 +236,11 @@ data Interval_x_IntervalIntersection r interval = type instance Intersection (Interval endPoint r) (Interval endPoint r) = Maybe (Interval_x_IntervalIntersection r (Interval endPoint r)) --- | Implementation of interval intersection -intersectIntervalImpl :: ( Ord r, IxValue (endPoint r) ~ r - , EndPoint_ (endPoint r) - ) - => Interval endPoint r -> Interval endPoint r - -> Maybe (Interval_x_IntervalIntersection r (Interval endPoint r)) -intersectIntervalImpl a b = case (a^.start) `compareIntervalExact` b of - Before -> case (a^.end) `compareIntervalExact` b of - Before -> Nothing - OnStart -> do guard $ isClosed (a^.endPoint) && isClosed (b^.startPoint) - pure $ Interval_x_Interval_Point (a^.end) - Interior -> Just partialBA - OnEnd - | isClosed (a^.endPoint) || isOpen (b^.endPoint) -> - Just $ Interval_x_Interval_Contained b - | otherwise -> Just partialBA - -- if b's endpoint is "contained" in that of b, i.e. if - -- a is closed, or if b is open, then b is fully contained. - After -> Just $ Interval_x_Interval_Contained b - - OnStart - | isClosed (b^.endPoint) || isOpen (a^.endPoint) -> - aInteriorCase $ Interval_x_Interval_Contained a - | otherwise -> aInteriorCase partialAB - - Interior -> aInteriorCase $ Interval_x_Interval_Contained a - OnEnd -> do guard $ isClosed (a^.startPoint) && isClosed (b^.endPoint) - pure $ Interval_x_Interval_Point (a^.start) - After -> Nothing -- by invariant, a^.end >= a.start, so they don't intersect - where - isClosed = (== Closed) . endPointType - isOpen = not . isClosed - endPointContained = isClosed (a^.endPoint) || not (isClosed (b^.endPoint)) - - -- the case when the startpoint of a is contained in B or coincides witht the start of B - -- the argument is how to actually construct a contained interval - aInteriorCase contained = case (a^.end) `compare` (b^.end) of - LT -> Just contained - EQ - | isClosed (b^.endPoint) || isOpen (a^.endPoint) -> Just contained - | otherwise -> Just partialAB - GT -> Just partialAB - - partialAB = Interval_x_Interval_Partial $ Interval (a^.startPoint) (b^.endPoint) - partialBA = Interval_x_Interval_Partial $ Interval (b^.startPoint) (a^.endPoint) - -------------------------------------------------------------------------------- --- * Closed Interval +-- * HasIntersection ---------------------------------------- --- ** HasIntersection - +-- ** Closed Interval instance ( Ord r , IxValue (endPoint r) ~ r, EndPoint_ (endPoint r) @@ -302,34 +256,9 @@ instance ( Ord r EQ -> True GT -> False -- by invariant, intA^.end >= intA.start, so they don't intersect ----------------------------------------- --- ** IsIntersectable - -instance Ord r => ClosedInterval r `IsIntersectableWith` ClosedInterval r where - intersect = intersectIntervalImpl - - -- intA `intersect` intB = case (intA^.start) `compareInterval` intB of - -- LT -> case (intA^.end) `compareInterval` intB of - -- LT -> Nothing - -- EQ -> Just $ mkInterval' (intB^.start) (intA^.end) - -- GT -> Just $ ClosedInterval_x_ClosedInterval_Contained intB - -- -- intB is fully contained - -- EQ -> case (intA^.end) `compareInterval` intB of - -- LT -> error "intersecting intervals; invariant failed, intA should be swapped?" - -- EQ -> Just $ ClosedInterval_x_ClosedInterval_Contained intA - -- GT -> Just $ if intA^.start == intB^.start then - -- ClosedInterval_x_ClosedInterval_Contained intB - -- else mkInterval' (intA^.start) (intB^.end) - -- GT -> Nothing -- by invariant, intA^.end > intA.start, so they don't intersect - -- where - -- mkInterval' l r - -- | l == r = ClosedInterval_x_ClosedInterval_Point l - -- | otherwise = ClosedInterval_x_ClosedInterval_Partial $ ClosedInterval l r - - --------------------------------------------------------------------------------- --- * Open intervals +---------------------------------------- +-- ** Open intervals instance Ord r => OpenInterval r `HasIntersectionWith` OpenInterval r where intA `intersects` intB = case (intA^.start) `compareInterval` intB of @@ -358,7 +287,7 @@ instance Ord r => OpenInterval r `HasIntersectionWith` Interval AnEndPoint r wh p `implies` q = not p || q {-# INLINE intersects #-} --------------------------------------------------------------------------------- +---------------------------------------- -- * Mixed instance Ord r => Interval AnEndPoint r `HasIntersectionWith` Interval AnEndPoint r where @@ -386,10 +315,82 @@ instance Ord r => Interval AnEndPoint r `HasIntersectionWith` OpenInterval r whe intersects intA intB = intersects intB intA {-# INLINE intersects #-} --- instance Ord r => Interval AnEndPoint r `HasIntersectionWith` ClosedInterval r where --- intersects intA intB = intersects intB intA --- {-# INLINE intersect #-} +-------------------------------------------------------------------------------- +-- * IsIntersectableWith implementations + +-- | Implementation of interval intersection +intersectIntervalImpl :: ( Ord r, IxValue (endPoint r) ~ r + , EndPoint_ (endPoint r) + ) + => Interval endPoint r -> Interval endPoint r + -> Maybe (Interval_x_IntervalIntersection r (Interval endPoint r)) +intersectIntervalImpl a b = case (a^.start) `compareIntervalExact` b of + Before -> case (a^.end) `compareIntervalExact` b of + Before -> Nothing + OnStart -> do guard $ isClosed (a^.endPoint) && isClosed (b^.startPoint) + pure $ Interval_x_Interval_Point (a^.end) + Interior -> Just partialBA + OnEnd + | isClosed (a^.endPoint) || isOpen (b^.endPoint) -> + Just $ Interval_x_Interval_Contained b + | otherwise -> Just partialBA + -- if b's endpoint is "contained" in that of b, i.e. if + -- a is closed, or if b is open, then b is fully contained. + After -> Just $ Interval_x_Interval_Contained b + + OnStart + | isClosed (b^.startPoint) || isOpen (a^.startPoint) -> + aInteriorCase (Interval_x_Interval_Contained a) + (Interval_x_Interval_Contained b) + | otherwise -> aInteriorCase partialAB partialAB + + Interior -> aInteriorCase (Interval_x_Interval_Contained a) partialAB + OnEnd -> do guard $ isClosed (a^.startPoint) && isClosed (b^.endPoint) + pure $ Interval_x_Interval_Point (a^.start) + After -> Nothing -- by invariant, a^.end >= a.start, so they don't intersect + where + isClosed = (== Closed) . endPointType + isOpen = not . isClosed + + -- the case when the startpoint of a is contained in B or coincides witht the start of + -- B the argument is how to actually construct a contained interval + aInteriorCase containedA partialAB' = case (a^.end) `compare` (b^.end) of + LT -> Just containedA + EQ + | isClosed (b^.endPoint) || isOpen (a^.endPoint) -> Just containedA + | otherwise -> Just partialAB + GT -> Just partialAB' + + partialAB = Interval_x_Interval_Partial $ Interval (a^.startPoint) (b^.endPoint) + partialBA = Interval_x_Interval_Partial $ Interval (b^.startPoint) (a^.endPoint) + + +---------------------------------------- +-- ** IsIntersectable + +instance Ord r => ClosedInterval r `IsIntersectableWith` ClosedInterval r where + intersect = intersectIntervalImpl + + -- intA `intersect` intB = case (intA^.start) `compareInterval` intB of + -- LT -> case (intA^.end) `compareInterval` intB of + -- LT -> Nothing + -- EQ -> Just $ mkInterval' (intB^.start) (intA^.end) + -- GT -> Just $ ClosedInterval_x_ClosedInterval_Contained intB + -- -- intB is fully contained + -- EQ -> case (intA^.end) `compareInterval` intB of + -- LT -> error "intersecting intervals; invariant failed, intA should be swapped?" + -- EQ -> Just $ ClosedInterval_x_ClosedInterval_Contained intA + -- GT -> Just $ if intA^.start == intB^.start then + -- ClosedInterval_x_ClosedInterval_Contained intB + -- else mkInterval' (intA^.start) (intB^.end) + -- GT -> Nothing -- by invariant, intA^.end > intA.start, so they don't intersect + -- where + -- mkInterval' l r + -- | l == r = ClosedInterval_x_ClosedInterval_Point l + -- | otherwise = ClosedInterval_x_ClosedInterval_Partial $ ClosedInterval l r +instance Ord r => OpenInterval r `IsIntersectableWith` OpenInterval r where + intersect = intersectIntervalImpl - -- Interval (AnEndPoint Open 2) (AnEndPoint Closed 18) - -- Interval (AnEndPoint Open (-26)) (AnEndPoint Closed 2) +instance Ord r => Interval AnEndPoint r `IsIntersectableWith` Interval AnEndPoint r where + intersect = intersectIntervalImpl diff --git a/hgeometry/kernel/src/HGeometry/LineSegment/Intersection.hs b/hgeometry/kernel/src/HGeometry/LineSegment/Intersection.hs index 98e597673..540a566b9 100644 --- a/hgeometry/kernel/src/HGeometry/LineSegment/Intersection.hs +++ b/hgeometry/kernel/src/HGeometry/LineSegment/Intersection.hs @@ -261,48 +261,55 @@ instance ( Point_ point 2 r, Num r, Ord r -- todo = error "LineSegment_x_LineSegment_LineSegment, not yet implemented" -- {-# INLINE intersect #-} -instance ( Point_ point 2 r, Fractional r, Ord r +instance ( Point_ point 2 r, Num r, Ord r + , Functor endPoint + , IxValue (endPoint point) ~ point, EndPoint_ (endPoint point) + , IxValue (endPoint r) ~ r, EndPoint_ (endPoint r) + , HasIntersectionWith (Interval endPoint r) (Interval endPoint r) , IxValue (endPoint point) ~ point + , IxValue (endPoint (r :+ endPoint point)) ~ (r :+ endPoint point) , EndPoint_ (endPoint point) + , IsEndPoint (endPoint point) (endPoint (r :+ endPoint point)) , IsIntersectableWith (LinePV 2 r) (LineSegment endPoint point) + , Intersection (LinePV 2 r) (LineSegment endPoint point) + ~ Maybe (LineLineSegmentIntersection (LineSegment endPoint point)) , HasOnSegment (LineSegment endPoint point) 2 + , IsIntersectableWith (Interval endPoint (r :+ endPoint point)) + (Interval endPoint (r :+ endPoint point)) , Intersection (LineSegment endPoint point) (LineSegment endPoint point) ~ Maybe (LineSegmentLineSegmentIntersection (LineSegment endPoint point)) - , Intersection (LinePV 2 r) (LineSegment endPoint point) - ~ Maybe (LineLineSegmentIntersection (LineSegment endPoint point)) - , IxValue (endPoint r) ~ r, EndPoint_ (endPoint r) - , IxValue (endPoint (r :+ point)) ~ (r :+ point) - , HasIntersectionWith (Interval endPoint r) (Interval endPoint r) - , HasIntersectionWith (Interval endPoint (r :+ point)) (Interval endPoint (r :+ point)) - -- , Intersection (Interval endPoint (r :+ point)) (Interval endPoint (r :+ point)) - -- ~ Maybe - , Functor endPoint - ) => - LineSegment endPoint point `IsIntersectableWith` LineSegment endPoint point where + , EndPoint_ (endPoint (r :+ endPoint point)) + ) => LineSegment endPoint point `IsIntersectableWith` LineSegment endPoint point where s `intersect` s' = supportingLine s `intersect` s' >>= \case - Line_x_LineSegment_Point p - | p `onSegment` s -> Just $ LineSegment_x_LineSegment_Point p - | otherwise -> Nothing - Line_x_LineSegment_LineSegment _ -> undefined -- spanIn' s `intersect` spanIn' s' <&> undefined - -- \case - -- LineSegment_x_LineSegment_LineSegment $ LineSegment (i&start %~ view core) - -- (i&end %~ view core) - {-# INLINE intersect #-} + Line_x_LineSegment_Point p + | p `onSegment` s -> Just $ LineSegment_x_LineSegment_Point p + | otherwise -> Nothing + Line_x_LineSegment_LineSegment _ -> spanIn' s `intersect` spanIn' s' <&> \case + Interval_x_Interval_Point xy -> LineSegment_x_LineSegment_Point $ + xy^.extra._endPoint.asPoint + Interval_x_Interval_Contained i -> mkIntersect i + Interval_x_Interval_Partial i -> mkIntersect i + where + mkIntersect i = + LineSegment_x_LineSegment_LineSegment $ LineSegment (i^.start.extra) (i^.end.extra) + spanIn' :: ( Point_ point 2 r, Ord r , IxValue (endPoint point) ~ point - , IxValue (endPoint (r :+ point)) ~ (r :+ point) + , IxValue (endPoint (r :+ endPoint point)) ~ (r :+ endPoint point) , EndPoint_ (endPoint point) - , IsEndPoint (endPoint point) (endPoint (r :+ point)) - ) => LineSegment endPoint point -> Interval endPoint (r :+ point) + , IsEndPoint (endPoint point) (endPoint (r :+ endPoint point)) + ) => LineSegment endPoint point -> Interval endPoint (r :+ endPoint point) spanIn' seg@(LineSegment s t) = case (seg^.start.xCoord) `compare` (seg^.end.xCoord) of LT -> Interval (xLabel s) (xLabel t) EQ | seg^.start.yCoord <= seg^.end.yCoord -> Interval (yLabel s) (yLabel t) | otherwise -> Interval (yLabel t) (yLabel s) GT -> Interval (xLabel t) (xLabel s) where - xLabel p = p&_endPoint %~ \pt -> pt^.xCoord :+ pt - yLabel p = p&_endPoint %~ \pt -> pt^.yCoord :+ pt + xLabel p = p&_endPoint %~ \pt -> pt^.xCoord :+ p + yLabel p = p&_endPoint %~ \pt -> pt^.yCoord :+ p + +-- data XY = X | Y deriving (Show,Eq) {- diff --git a/hgeometry/kernel/test/HGeometry/HalfSpaceSpec.hs b/hgeometry/kernel/test/HGeometry/HalfSpaceSpec.hs index 60ab26bdd..63f338098 100644 --- a/hgeometry/kernel/test/HGeometry/HalfSpaceSpec.hs +++ b/hgeometry/kernel/test/HGeometry/HalfSpaceSpec.hs @@ -7,7 +7,7 @@ import HGeometry.Intersection import HGeometry.Kernel.Instances () import HGeometry.Line import HGeometry.Point -import HGeometry.Vector hiding (head) +-- import HGeometry.Vector hiding (head) import Test.Hspec import Test.Hspec.QuickCheck @@ -50,5 +50,5 @@ spec = describe "halfspace Tests" $ do -- ((horizontalLine @Rational $ 5 % 1) `intersects` h) `shouldBe` True -- (l `intersects` h) `shouldBe` True -test :: Ordering -test = (fst $ head myPoints) `onSideTest` (LineEQ 1 2) +-- test :: Ordering +-- test = (fst $ head myPoints) `onSideTest` (LineEQ 1 2) diff --git a/hgeometry/kernel/test/HGeometry/IntervalSpec.hs b/hgeometry/kernel/test/HGeometry/IntervalSpec.hs index b356b412b..11fe5757c 100644 --- a/hgeometry/kernel/test/HGeometry/IntervalSpec.hs +++ b/hgeometry/kernel/test/HGeometry/IntervalSpec.hs @@ -28,27 +28,33 @@ spec = do `shouldBe` (asAnInterval intA `intersects` intB) - prop "intersects and intersect consistent" $ + prop "intersects and intersect consistent (closed)" $ \(intA :: ClosedInterval Int) (intB :: ClosedInterval Int) -> (intA `intersects` intB) == isJust (intA `intersect` intB) + prop "intersects and intersect consistent (open)" $ + \(intA :: OpenInterval Int) (intB :: OpenInterval Int) -> + (intA `intersects` intB) == isJust (intA `intersect` intB) + prop "intersects and intersect consistent (mixed)" $ + \(intA :: Interval AnEndPoint Int) (intB :: Interval AnEndPoint Int) -> + (intA `intersects` intB) == isJust (intA `intersect` intB) -- it "openInterval cap openrange" $ do -- ((OpenInterval 1 (10 :: Int)) `intersect` (OpenInterval 5 (10 :: Int))) -- `shouldBe` (ClosedInterval_x_ClosedInterval_Partial $ OpenInterval 5 (10 :: Int)) it "openInterval cap openrange" $ do - ((OpenInterval 1 (10 :: Int)) `intersects` (OpenInterval 5 (10 :: Int))) + OpenInterval 1 (10 :: Int) `intersects` OpenInterval 5 (10 :: Int) `shouldBe` True it "disjoint open ranges" $ do - ((OpenInterval 1 (10 :: Int)) `intersects` (OpenInterval 10 (12 :: Int))) + OpenInterval 1 (10 :: Int) `intersects` OpenInterval 10 (12 :: Int) `shouldBe` False it "closed cap open, disjoint" $ do - ((ClosedInterval (1::Int) 10) `intersects` (OpenInterval 50 (60 :: Int))) + ClosedInterval (1::Int) 10 `intersects` OpenInterval 50 (60 :: Int) `shouldBe` False -- it "endpoints overlap but open/closed" $ do it "manual test closed x open" $ do - ((ClosedInterval (10::Int) 20) `intersects` (OpenInterval 5 (20 :: Int))) + ClosedInterval (10::Int) 20 `intersects` OpenInterval 5 (20 :: Int) `shouldBe` True describe "intersection is symmetirc" $ do @@ -144,19 +150,19 @@ testInts = [ ClosedInterval 10 20 -- 0 testInt :: Int -> ClosedInterval Int testInt i = testInts !! i -answers = [ ( (0,1) , Just $ ClosedInterval_x_ClosedInterval_Partial $ ClosedInterval 10 15) - , ( (0,2) , Just $ ClosedInterval_x_ClosedInterval_Point 20 ) - , ( (0,3) , Just $ ClosedInterval_x_ClosedInterval_Contained $ testInt 0 ) - , ( (0,4) , Just $ ClosedInterval_x_ClosedInterval_Contained $ testInt 4 ) - , ( (1,1) , Just $ ClosedInterval_x_ClosedInterval_Contained $ testInt 1 ) +answers = [ ( (0,1) , Just $ Interval_x_Interval_Partial $ ClosedInterval 10 15) + , ( (0,2) , Just $ Interval_x_Interval_Point 20 ) + , ( (0,3) , Just $ Interval_x_Interval_Contained $ testInt 0 ) + , ( (0,4) , Just $ Interval_x_Interval_Contained $ testInt 4 ) + , ( (1,1) , Just $ Interval_x_Interval_Contained $ testInt 1 ) , ( (1,2) , Nothing ) - , ( (1,3) , Just $ ClosedInterval_x_ClosedInterval_Contained $ testInt 1 ) - , ( (1,4) , Just $ ClosedInterval_x_ClosedInterval_Partial $ ClosedInterval 10 15 ) - , ( (2,2) , Just $ ClosedInterval_x_ClosedInterval_Contained $ testInt 2 ) - , ( (2,3) , Just $ ClosedInterval_x_ClosedInterval_Point 20 ) + , ( (1,3) , Just $ Interval_x_Interval_Contained $ testInt 1 ) + , ( (1,4) , Just $ Interval_x_Interval_Partial $ ClosedInterval 10 15 ) + , ( (2,2) , Just $ Interval_x_Interval_Contained $ testInt 2 ) + , ( (2,3) , Just $ Interval_x_Interval_Point 20 ) , ( (2,4) , Nothing ) - , ( (3,3) , Just $ ClosedInterval_x_ClosedInterval_Contained $ testInt 3 ) - , ( (3,4) , Just $ ClosedInterval_x_ClosedInterval_Contained $ testInt 4 ) + , ( (3,3) , Just $ Interval_x_Interval_Contained $ testInt 3 ) + , ( (3,4) , Just $ Interval_x_Interval_Contained $ testInt 4 ) ]