Skip to content

Commit

Permalink
fixed interval testcases
Browse files Browse the repository at this point in the history
  • Loading branch information
@noinia
noinia committed Jan 2, 2024
1 parent 5b7e45b commit c3a18f2
Show file tree
Hide file tree
Showing 5 changed files with 142 additions and 128 deletions.
4 changes: 2 additions & 2 deletions hgeometry/kernel/src/HGeometry/Interval/EndPoint.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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)
Expand Down Expand Up @@ -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
Expand Down
165 changes: 83 additions & 82 deletions hgeometry/kernel/src/HGeometry/Interval/Internal.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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 =
Expand All @@ -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)
Expand All @@ -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
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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
57 changes: 32 additions & 25 deletions hgeometry/kernel/src/HGeometry/LineSegment/Intersection.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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)


{-
Expand Down
6 changes: 3 additions & 3 deletions hgeometry/kernel/test/HGeometry/HalfSpaceSpec.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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

Expand Down Expand Up @@ -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)
38 changes: 22 additions & 16 deletions hgeometry/kernel/test/HGeometry/IntervalSpec.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -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 )
]


Expand Down

0 comments on commit c3a18f2

Please sign in to comment.