{-# LANGUAGE UndecidableInstances #-}
module HGeometry.LineSegment.Intersection.BentleyOttmann
( intersections
, interiorIntersections
, Intersections
, intersectionPoints
, Associated, startPointOf, endPointOf, interiorTo
, associatedSegments
, AroundEnd, AroundStart, AroundIntersection
, isInteriorIntersection
, IntersectionPoint
, intersectionPointOf
, intersectionPoint, associatedSegs
, IntersectConstraints
, OrdArounds
) where
import Control.Lens hiding (contains)
import Data.Coerce
import qualified Data.Foldable as F
import Data.Function (on)
import qualified Data.List as List
import Data.List.NonEmpty (NonEmpty(..))
import qualified Data.List.NonEmpty as NonEmpty
import qualified Data.Map as Map
import Data.Maybe
import Data.Ord (comparing)
import qualified Data.Set as EQ
import qualified Data.Set as SS
import qualified Data.Set as Set
import qualified Data.Vector as Vector
import HGeometry.Foldable.Sort
import HGeometry.Intersection
import HGeometry.Interval.Class
import HGeometry.LineSegment
import HGeometry.LineSegment.Intersection.Types
import HGeometry.Point
import HGeometry.Properties (NumType, Dimension)
import qualified HGeometry.Set.Util as SS
intersections :: forall lineSegment point r f.
( LineSegment_ lineSegment point
, Point_ point 2 r
, Eq lineSegment
, Ord r, Fractional r
, HasOnSegment lineSegment 2
, IntersectConstraints lineSegment
, Foldable f, Functor f
, StartPointOf lineSegment ~ EndPointOf lineSegment
)
=> f lineSegment -> Intersections r lineSegment
intersections :: forall lineSegment point r (f :: * -> *).
(LineSegment_ lineSegment point, Point_ point 2 r, Eq lineSegment,
Ord r, Fractional r, HasOnSegment lineSegment 2,
IntersectConstraints lineSegment, Foldable f, Functor f,
StartPointOf lineSegment ~ EndPointOf lineSegment) =>
f lineSegment -> Intersections r lineSegment
intersections = (Associated (Flipped lineSegment) -> Associated lineSegment)
-> Map (Point 2 r) (Associated (Flipped lineSegment))
-> Map (Point 2 r) (Associated lineSegment)
forall a b. (a -> b) -> Map (Point 2 r) a -> Map (Point 2 r) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Associated (Flipped lineSegment) -> Associated lineSegment
forall lineSegment point r.
(LineSegment_ lineSegment point, Point_ point 2 r, Fractional r,
Ord r, IntersectConstraints lineSegment,
StartPointOf lineSegment ~ EndPointOf lineSegment) =>
Associated (Flipped lineSegment) -> Associated lineSegment
unflipSegs (Map (Point 2 r) (Associated (Flipped lineSegment))
-> Map (Point 2 r) (Associated lineSegment))
-> (f lineSegment
-> Map (Point 2 r) (Associated (Flipped lineSegment)))
-> f lineSegment
-> Map (Point 2 r) (Associated lineSegment)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f (Flipped lineSegment)
-> Map (Point 2 r) (Associated (Flipped lineSegment))
forall lineSegment point r (f :: * -> *).
(LineSegment_ lineSegment point, Point_ point 2 r, Eq lineSegment,
Ord r, Fractional r, HasOnSegment lineSegment 2,
IntersectConstraints lineSegment,
StartPointOf lineSegment ~ EndPointOf lineSegment, Foldable f) =>
f lineSegment -> Intersections r lineSegment
intersections' (f (Flipped lineSegment)
-> Map (Point 2 r) (Associated (Flipped lineSegment)))
-> (f lineSegment -> f (Flipped lineSegment))
-> f lineSegment
-> Map (Point 2 r) (Associated (Flipped lineSegment))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (lineSegment -> Flipped lineSegment)
-> f lineSegment -> f (Flipped lineSegment)
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap lineSegment -> Flipped lineSegment
forall lineSegment point r.
(LineSegment_ lineSegment point, Point_ point 2 r, Ord r,
StartPointOf lineSegment ~ EndPointOf lineSegment) =>
lineSegment -> Flipped lineSegment
tagFlipped
intersections' :: ( LineSegment_ lineSegment point
, Point_ point 2 r
, Eq lineSegment
, Ord r, Fractional r
, HasOnSegment lineSegment 2
, IntersectConstraints lineSegment
, StartPointOf lineSegment ~ EndPointOf lineSegment
, Foldable f
)
=> f lineSegment -> Intersections r lineSegment
intersections' :: forall lineSegment point r (f :: * -> *).
(LineSegment_ lineSegment point, Point_ point 2 r, Eq lineSegment,
Ord r, Fractional r, HasOnSegment lineSegment 2,
IntersectConstraints lineSegment,
StartPointOf lineSegment ~ EndPointOf lineSegment, Foldable f) =>
f lineSegment -> Intersections r lineSegment
intersections' f lineSegment
segs = [IntersectionPoint (Point 2 r) lineSegment]
-> Intersections r lineSegment
forall r lineSegment.
(Ord r, Fractional r) =>
[IntersectionPoint (Point 2 r) lineSegment]
-> Intersections r lineSegment
merge ([IntersectionPoint (Point 2 r) lineSegment]
-> Intersections r lineSegment)
-> [IntersectionPoint (Point 2 r) lineSegment]
-> Intersections r lineSegment
forall a b. (a -> b) -> a -> b
$ EventQueue r lineSegment
-> StatusStructure r lineSegment
-> [IntersectionPoint (Point 2 r) lineSegment]
forall lineSegment point r.
(LineSegment_ lineSegment point, Point_ point 2 r, Ord r,
Fractional r, IntersectConstraints lineSegment,
HasOnSegment lineSegment 2) =>
EventQueue r lineSegment
-> StatusStructure r lineSegment
-> [IntersectionPoint (Point 2 r) lineSegment]
sweep EventQueue r lineSegment
pts StatusStructure r lineSegment
forall a. Set a
SS.empty
where
pts :: EventQueue r lineSegment
pts = [Event r lineSegment] -> EventQueue r lineSegment
forall a. Eq a => [a] -> Set a
EQ.fromAscList ([Event r lineSegment] -> EventQueue r lineSegment)
-> (f lineSegment -> [Event r lineSegment])
-> f lineSegment
-> EventQueue r lineSegment
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vector (Event r lineSegment) -> [Event r lineSegment]
forall r lineSegment.
Eq r =>
Vector (Event r lineSegment) -> [Event r lineSegment]
groupStarts (Vector (Event r lineSegment) -> [Event r lineSegment])
-> (f lineSegment -> Vector (Event r lineSegment))
-> f lineSegment
-> [Event r lineSegment]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Event r lineSegment] -> Vector (Event r lineSegment)
forall (vector :: * -> *) (f :: * -> *) a.
(Foldable f, Vector vector a, Ord a) =>
f a -> vector a
sort ([Event r lineSegment] -> Vector (Event r lineSegment))
-> (f lineSegment -> [Event r lineSegment])
-> f lineSegment
-> Vector (Event r lineSegment)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (lineSegment -> [Event r lineSegment])
-> f lineSegment -> [Event r lineSegment]
forall m a. Monoid m => (a -> m) -> f a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap lineSegment -> [Event r lineSegment]
forall lineSegment point r.
(LineSegment_ lineSegment point, Point_ point 2 r) =>
lineSegment -> [Event r lineSegment]
asEventPts (f lineSegment -> EventQueue r lineSegment)
-> f lineSegment -> EventQueue r lineSegment
forall a b. (a -> b) -> a -> b
$ f lineSegment
segs
interiorIntersections :: ( LineSegment_ lineSegment point
, Point_ point 2 r
, 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 :: forall lineSegment point r (f :: * -> *).
(LineSegment_ lineSegment point, Point_ point 2 r, 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 = (Associated lineSegment -> Bool)
-> Map (Point 2 r) (Associated lineSegment)
-> Map (Point 2 r) (Associated lineSegment)
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter Associated lineSegment -> Bool
forall lineSegment. Associated lineSegment -> Bool
isInteriorIntersection (Map (Point 2 r) (Associated lineSegment)
-> Map (Point 2 r) (Associated lineSegment))
-> (f lineSegment -> Map (Point 2 r) (Associated lineSegment))
-> f lineSegment
-> Map (Point 2 r) (Associated lineSegment)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f lineSegment -> Map (Point 2 r) (Associated lineSegment)
forall lineSegment point r (f :: * -> *).
(LineSegment_ lineSegment point, Point_ point 2 r, Eq lineSegment,
Ord r, Fractional r, HasOnSegment lineSegment 2,
IntersectConstraints lineSegment, Foldable f, Functor f,
StartPointOf lineSegment ~ EndPointOf lineSegment) =>
f lineSegment -> Intersections r lineSegment
intersections
asEventPts :: (LineSegment_ lineSegment point, Point_ point 2 r)
=> lineSegment -> [Event r lineSegment]
asEventPts :: forall lineSegment point r.
(LineSegment_ lineSegment point, Point_ point 2 r) =>
lineSegment -> [Event r lineSegment]
asEventPts lineSegment
s = [ Point 2 r -> EventType lineSegment -> Event r lineSegment
forall r lineSegment.
Point 2 r -> EventType lineSegment -> Event r lineSegment
Event (lineSegment
slineSegment
-> Getting (Point 2 r) lineSegment (Point 2 r) -> Point 2 r
forall s a. s -> Getting a s a -> a
^.(point -> Const (Point 2 r) point)
-> lineSegment -> Const (Point 2 r) lineSegment
forall seg p. HasStart seg p => Lens' seg p
Lens' lineSegment point
start((point -> Const (Point 2 r) point)
-> lineSegment -> Const (Point 2 r) lineSegment)
-> ((Point 2 r -> Const (Point 2 r) (Point 2 r))
-> point -> Const (Point 2 r) point)
-> Getting (Point 2 r) lineSegment (Point 2 r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Point 2 r -> Const (Point 2 r) (Point 2 r))
-> point -> Const (Point 2 r) point
forall point (d :: Nat) r.
Point_ point d r =>
Lens' point (Point d r)
Lens' point (Point 2 r)
asPoint) (NonEmpty lineSegment -> EventType lineSegment
forall s. NonEmpty s -> EventType s
Start (NonEmpty lineSegment -> EventType lineSegment)
-> NonEmpty lineSegment -> EventType lineSegment
forall a b. (a -> b) -> a -> b
$ lineSegment
s lineSegment -> [lineSegment] -> NonEmpty lineSegment
forall a. a -> [a] -> NonEmpty a
:| [])
, Point 2 r -> EventType lineSegment -> Event r lineSegment
forall r lineSegment.
Point 2 r -> EventType lineSegment -> Event r lineSegment
Event (lineSegment
slineSegment
-> Getting (Point 2 r) lineSegment (Point 2 r) -> Point 2 r
forall s a. s -> Getting a s a -> a
^.(point -> Const (Point 2 r) point)
-> lineSegment -> Const (Point 2 r) lineSegment
forall seg p. HasEnd seg p => Lens' seg p
Lens' lineSegment point
end((point -> Const (Point 2 r) point)
-> lineSegment -> Const (Point 2 r) lineSegment)
-> ((Point 2 r -> Const (Point 2 r) (Point 2 r))
-> point -> Const (Point 2 r) point)
-> Getting (Point 2 r) lineSegment (Point 2 r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Point 2 r -> Const (Point 2 r) (Point 2 r))
-> point -> Const (Point 2 r) point
forall point (d :: Nat) r.
Point_ point d r =>
Lens' point (Point d r)
Lens' point (Point 2 r)
asPoint) (lineSegment -> EventType lineSegment
forall s. s -> EventType s
End lineSegment
s)
]
merge :: (Ord r, Fractional r)
=> [IntersectionPoint (Point 2 r) lineSegment] -> Intersections r lineSegment
merge :: forall r lineSegment.
(Ord r, Fractional r) =>
[IntersectionPoint (Point 2 r) lineSegment]
-> Intersections r lineSegment
merge = (IntersectionPoint (Point 2 r) lineSegment
-> Intersections r lineSegment)
-> [IntersectionPoint (Point 2 r) lineSegment]
-> Intersections r lineSegment
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (\IntersectionPoint (Point 2 r) lineSegment
ip -> Point 2 r -> Associated lineSegment -> Intersections r lineSegment
forall k a. k -> a -> Map k a
Map.singleton (IntersectionPoint (Point 2 r) lineSegment
ipIntersectionPoint (Point 2 r) lineSegment
-> Getting
(Point 2 r) (IntersectionPoint (Point 2 r) lineSegment) (Point 2 r)
-> Point 2 r
forall s a. s -> Getting a s a -> a
^.Getting
(Point 2 r) (IntersectionPoint (Point 2 r) lineSegment) (Point 2 r)
forall point1 lineSegment point2 (f :: * -> *).
Functor f =>
(point1 -> f point2)
-> IntersectionPoint point1 lineSegment
-> f (IntersectionPoint point2 lineSegment)
intersectionPoint) (IntersectionPoint (Point 2 r) lineSegment
ipIntersectionPoint (Point 2 r) lineSegment
-> Getting
(Associated lineSegment)
(IntersectionPoint (Point 2 r) lineSegment)
(Associated lineSegment)
-> Associated lineSegment
forall s a. s -> Getting a s a -> a
^.Getting
(Associated lineSegment)
(IntersectionPoint (Point 2 r) lineSegment)
(Associated lineSegment)
forall point lineSegment1 lineSegment2 (f :: * -> *).
Functor f =>
(Associated lineSegment1 -> f (Associated lineSegment2))
-> IntersectionPoint point lineSegment1
-> f (IntersectionPoint point lineSegment2)
associatedSegs))
groupStarts :: Eq r => Vector.Vector (Event r lineSegment) -> [Event r lineSegment]
groupStarts :: forall r lineSegment.
Eq r =>
Vector (Event r lineSegment) -> [Event r lineSegment]
groupStarts = [Event r lineSegment] -> [Event r lineSegment]
forall r lineSegment.
Eq r =>
[Event r lineSegment] -> [Event r lineSegment]
groupStarts' ([Event r lineSegment] -> [Event r lineSegment])
-> (Vector (Event r lineSegment) -> [Event r lineSegment])
-> Vector (Event r lineSegment)
-> [Event r lineSegment]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vector (Event r lineSegment) -> [Event r lineSegment]
forall a. Vector a -> [a]
Vector.toList
groupStarts' :: Eq r => [Event r lineSegment] -> [Event r lineSegment]
groupStarts' :: forall r lineSegment.
Eq r =>
[Event r lineSegment] -> [Event r lineSegment]
groupStarts' [] = []
groupStarts' (Event Point 2 r
p (Start NonEmpty lineSegment
s) : [Event r lineSegment]
es) = Point 2 r -> EventType lineSegment -> Event r lineSegment
forall r lineSegment.
Point 2 r -> EventType lineSegment -> Event r lineSegment
Event Point 2 r
p (NonEmpty lineSegment -> EventType lineSegment
forall s. NonEmpty s -> EventType s
Start NonEmpty lineSegment
ss) Event r lineSegment
-> [Event r lineSegment] -> [Event r lineSegment]
forall a. a -> [a] -> [a]
: [Event r lineSegment] -> [Event r lineSegment]
forall r lineSegment.
Eq r =>
[Event r lineSegment] -> [Event r lineSegment]
groupStarts' [Event r lineSegment]
rest
where
([Event r lineSegment]
ss',[Event r lineSegment]
rest) = (Event r lineSegment -> Bool)
-> [Event r lineSegment]
-> ([Event r lineSegment], [Event r lineSegment])
forall a. (a -> Bool) -> [a] -> ([a], [a])
List.span Event r lineSegment -> Bool
sameStart [Event r lineSegment]
es
ss :: NonEmpty lineSegment
ss = let (lineSegment
x:|[lineSegment]
xs) = NonEmpty lineSegment
s
in lineSegment
x lineSegment -> [lineSegment] -> NonEmpty lineSegment
forall a. a -> [a] -> NonEmpty a
:| ([lineSegment]
xs [lineSegment] -> [lineSegment] -> [lineSegment]
forall a. [a] -> [a] -> [a]
++ (Event r lineSegment -> [lineSegment])
-> [Event r lineSegment] -> [lineSegment]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Event r lineSegment -> [lineSegment]
forall r lineSegment. Event r lineSegment -> [lineSegment]
startSegs [Event r lineSegment]
ss')
sameStart :: Event r lineSegment -> Bool
sameStart (Event Point 2 r
q (Start NonEmpty lineSegment
_)) = Point 2 r
p Point 2 r -> Point 2 r -> Bool
forall a. Eq a => a -> a -> Bool
== Point 2 r
q
sameStart Event r lineSegment
_ = Bool
False
groupStarts' (Event r lineSegment
e : [Event r lineSegment]
es) = Event r lineSegment
e Event r lineSegment
-> [Event r lineSegment] -> [Event r lineSegment]
forall a. a -> [a] -> [a]
: [Event r lineSegment] -> [Event r lineSegment]
forall r lineSegment.
Eq r =>
[Event r lineSegment] -> [Event r lineSegment]
groupStarts' [Event r lineSegment]
es
data EventType s = Start !(NonEmpty s)| Intersection | End !s deriving (Int -> EventType s -> ShowS
[EventType s] -> ShowS
EventType s -> String
(Int -> EventType s -> ShowS)
-> (EventType s -> String)
-> ([EventType s] -> ShowS)
-> Show (EventType s)
forall s. Show s => Int -> EventType s -> ShowS
forall s. Show s => [EventType s] -> ShowS
forall s. Show s => EventType s -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall s. Show s => Int -> EventType s -> ShowS
showsPrec :: Int -> EventType s -> ShowS
$cshow :: forall s. Show s => EventType s -> String
show :: EventType s -> String
$cshowList :: forall s. Show s => [EventType s] -> ShowS
showList :: [EventType s] -> ShowS
Show)
instance Eq (EventType s) where
EventType s
a == :: EventType s -> EventType s -> Bool
== EventType s
b = EventType s
a EventType s -> EventType s -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` EventType s
b Ordering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
== Ordering
EQ
instance Ord (EventType s) where
(Start NonEmpty s
_) compare :: EventType s -> EventType s -> Ordering
`compare` (Start NonEmpty s
_) = Ordering
EQ
(Start NonEmpty s
_) `compare` EventType s
_ = Ordering
LT
EventType s
Intersection `compare` (Start NonEmpty s
_) = Ordering
GT
EventType s
Intersection `compare` EventType s
Intersection = Ordering
EQ
EventType s
Intersection `compare` (End s
_) = Ordering
LT
(End s
_) `compare` (End s
_) = Ordering
EQ
(End s
_) `compare` EventType s
_ = Ordering
GT
data Event r lineSegment = Event { forall r lineSegment. Event r lineSegment -> Point 2 r
eventPoint :: !(Point 2 r)
, forall r lineSegment. Event r lineSegment -> EventType lineSegment
eventType :: !(EventType lineSegment)
} deriving (Int -> Event r lineSegment -> ShowS
[Event r lineSegment] -> ShowS
Event r lineSegment -> String
(Int -> Event r lineSegment -> ShowS)
-> (Event r lineSegment -> String)
-> ([Event r lineSegment] -> ShowS)
-> Show (Event r lineSegment)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall r lineSegment.
(Show r, Show lineSegment) =>
Int -> Event r lineSegment -> ShowS
forall r lineSegment.
(Show r, Show lineSegment) =>
[Event r lineSegment] -> ShowS
forall r lineSegment.
(Show r, Show lineSegment) =>
Event r lineSegment -> String
$cshowsPrec :: forall r lineSegment.
(Show r, Show lineSegment) =>
Int -> Event r lineSegment -> ShowS
showsPrec :: Int -> Event r lineSegment -> ShowS
$cshow :: forall r lineSegment.
(Show r, Show lineSegment) =>
Event r lineSegment -> String
show :: Event r lineSegment -> String
$cshowList :: forall r lineSegment.
(Show r, Show lineSegment) =>
[Event r lineSegment] -> ShowS
showList :: [Event r lineSegment] -> ShowS
Show,Event r lineSegment -> Event r lineSegment -> Bool
(Event r lineSegment -> Event r lineSegment -> Bool)
-> (Event r lineSegment -> Event r lineSegment -> Bool)
-> Eq (Event r lineSegment)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall r lineSegment.
Eq r =>
Event r lineSegment -> Event r lineSegment -> Bool
$c== :: forall r lineSegment.
Eq r =>
Event r lineSegment -> Event r lineSegment -> Bool
== :: Event r lineSegment -> Event r lineSegment -> Bool
$c/= :: forall r lineSegment.
Eq r =>
Event r lineSegment -> Event r lineSegment -> Bool
/= :: Event r lineSegment -> Event r lineSegment -> Bool
Eq)
instance Ord r => Ord (Event r lineSegment) where
(Event Point 2 r
p EventType lineSegment
s) compare :: Event r lineSegment -> Event r lineSegment -> Ordering
`compare` (Event Point 2 r
q EventType lineSegment
t) = case Point 2 r -> Point 2 r -> Ordering
forall point r.
(Point_ point 2 r, Ord r) =>
point -> point -> Ordering
ordPoints Point 2 r
p Point 2 r
q of
Ordering
EQ -> EventType lineSegment
s EventType lineSegment -> EventType lineSegment -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` EventType lineSegment
t
Ordering
x -> Ordering
x
startSegs :: Event r lineSegment -> [lineSegment]
startSegs :: forall r lineSegment. Event r lineSegment -> [lineSegment]
startSegs Event r lineSegment
e = case Event r lineSegment -> EventType lineSegment
forall r lineSegment. Event r lineSegment -> EventType lineSegment
eventType Event r lineSegment
e of
Start NonEmpty lineSegment
ss -> NonEmpty lineSegment -> [lineSegment]
forall a. NonEmpty a -> [a]
NonEmpty.toList NonEmpty lineSegment
ss
EventType lineSegment
_ -> []
type EventQueue r lineSegment = EQ.Set (Event r lineSegment)
type StatusStructure r lineSegment = SS.Set lineSegment
sweep :: ( LineSegment_ lineSegment point
, Point_ point 2 r
, Ord r, Fractional r
, IntersectConstraints lineSegment
, HasOnSegment lineSegment 2
)
=> EventQueue r lineSegment -> StatusStructure r lineSegment
-> [IntersectionPoint (Point 2 r) lineSegment]
sweep :: forall lineSegment point r.
(LineSegment_ lineSegment point, Point_ point 2 r, Ord r,
Fractional r, IntersectConstraints lineSegment,
HasOnSegment lineSegment 2) =>
EventQueue r lineSegment
-> StatusStructure r lineSegment
-> [IntersectionPoint (Point 2 r) lineSegment]
sweep EventQueue r lineSegment
eq StatusStructure r lineSegment
ss = case EventQueue r lineSegment
-> Maybe (Event r lineSegment, EventQueue r lineSegment)
forall a. Set a -> Maybe (a, Set a)
EQ.minView EventQueue r lineSegment
eq of
Maybe (Event r lineSegment, EventQueue r lineSegment)
Nothing -> []
Just (Event r lineSegment
e,EventQueue r lineSegment
eq') -> Event r lineSegment
-> EventQueue r lineSegment
-> StatusStructure r lineSegment
-> [IntersectionPoint (Point 2 r) lineSegment]
forall lineSegment point r.
(LineSegment_ lineSegment point, Point_ point 2 r, Ord r,
Fractional r, IntersectConstraints lineSegment,
HasOnSegment lineSegment 2) =>
Event r lineSegment
-> EventQueue r lineSegment
-> StatusStructure r lineSegment
-> [IntersectionPoint (Point 2 r) lineSegment]
handle Event r lineSegment
e EventQueue r lineSegment
eq' StatusStructure r lineSegment
ss
isOpen :: EndPoint_ endPoint => endPoint -> Bool
isOpen :: forall endPoint. EndPoint_ endPoint => endPoint -> Bool
isOpen = (EndPointType -> EndPointType -> Bool
forall a. Eq a => a -> a -> Bool
== EndPointType
Open) (EndPointType -> Bool)
-> (endPoint -> EndPointType) -> endPoint -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. endPoint -> EndPointType
forall endPoint. EndPoint_ endPoint => endPoint -> EndPointType
endPointType
isClosed :: EndPoint_ endPoint => endPoint -> Bool
isClosed :: forall endPoint. EndPoint_ endPoint => endPoint -> Bool
isClosed = (EndPointType -> EndPointType -> Bool
forall a. Eq a => a -> a -> Bool
== EndPointType
Closed) (EndPointType -> Bool)
-> (endPoint -> EndPointType) -> endPoint -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. endPoint -> EndPointType
forall endPoint. EndPoint_ endPoint => endPoint -> EndPointType
endPointType
handle :: ( LineSegment_ lineSegment point
, Point_ point 2 r
, Ord r, Fractional r
, IntersectConstraints lineSegment
, HasOnSegment lineSegment 2
)
=> Event r lineSegment
-> EventQueue r lineSegment -> StatusStructure r lineSegment
-> [IntersectionPoint (Point 2 r) lineSegment]
handle :: forall lineSegment point r.
(LineSegment_ lineSegment point, Point_ point 2 r, Ord r,
Fractional r, IntersectConstraints lineSegment,
HasOnSegment lineSegment 2) =>
Event r lineSegment
-> EventQueue r lineSegment
-> StatusStructure r lineSegment
-> [IntersectionPoint (Point 2 r) lineSegment]
handle e :: Event r lineSegment
e@(Event r lineSegment -> Point 2 r
forall r lineSegment. Event r lineSegment -> Point 2 r
eventPoint -> Point 2 r
p) EventQueue r lineSegment
eq StatusStructure r lineSegment
ss = [IntersectionPoint (Point 2 r) lineSegment]
toReport [IntersectionPoint (Point 2 r) lineSegment]
-> [IntersectionPoint (Point 2 r) lineSegment]
-> [IntersectionPoint (Point 2 r) lineSegment]
forall a. Semigroup a => a -> a -> a
<> EventQueue r lineSegment
-> StatusStructure r lineSegment
-> [IntersectionPoint (Point 2 r) lineSegment]
forall lineSegment point r.
(LineSegment_ lineSegment point, Point_ point 2 r, Ord r,
Fractional r, IntersectConstraints lineSegment,
HasOnSegment lineSegment 2) =>
EventQueue r lineSegment
-> StatusStructure r lineSegment
-> [IntersectionPoint (Point 2 r) lineSegment]
sweep EventQueue r lineSegment
eq' StatusStructure r lineSegment
ss'
where
starts :: [lineSegment]
starts = Event r lineSegment -> [lineSegment]
forall r lineSegment. Event r lineSegment -> [lineSegment]
startSegs Event r lineSegment
e
(StatusStructure r lineSegment
before,[lineSegment]
contains',StatusStructure r lineSegment
after) = Point 2 r
-> StatusStructure r lineSegment
-> (StatusStructure r lineSegment, [lineSegment],
StatusStructure r lineSegment)
forall lineSegment point r.
(LineSegment_ lineSegment point, HasOnSegment lineSegment 2,
Point_ point 2 r, Ord r, Fractional r) =>
Point 2 r
-> StatusStructure r lineSegment
-> (StatusStructure r lineSegment, [lineSegment],
StatusStructure r lineSegment)
extractContains Point 2 r
p StatusStructure r lineSegment
ss
([lineSegment]
ends,[lineSegment]
contains) = (lineSegment -> Bool)
-> [lineSegment] -> ([lineSegment], [lineSegment])
forall a. (a -> Bool) -> [a] -> ([a], [a])
List.partition (Point 2 r -> lineSegment -> Bool
forall lineSegment point r.
(LineSegment_ lineSegment point, Point_ point 2 r, Eq r) =>
Point 2 r -> lineSegment -> Bool
endsAt Point 2 r
p) [lineSegment]
contains'
starts' :: [lineSegment]
starts' = Point 2 r -> [lineSegment] -> [lineSegment]
forall lineSegment point r a.
(LineSegment_ lineSegment point, Point_ point 2 r, Ord r, Num r,
HasIntersectionWith lineSegment lineSegment) =>
a -> [lineSegment] -> [lineSegment]
shouldReport Point 2 r
p ([lineSegment] -> [lineSegment]) -> [lineSegment] -> [lineSegment]
forall a b. (a -> b) -> a -> b
$ StatusStructure r lineSegment -> [lineSegment]
forall a. Set a -> [a]
SS.toAscList StatusStructure r lineSegment
newSegs
pureContains :: [lineSegment]
pureContains =
(lineSegment -> Bool) -> [lineSegment] -> [lineSegment]
forall a. (a -> Bool) -> [a] -> [a]
filter (\lineSegment
seg -> Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ StartPointOf lineSegment -> Bool
forall endPoint. EndPoint_ endPoint => endPoint -> Bool
isOpen (lineSegment
seglineSegment
-> Getting
(StartPointOf lineSegment) lineSegment (StartPointOf lineSegment)
-> StartPointOf lineSegment
forall s a. s -> Getting a s a -> a
^.Getting
(StartPointOf lineSegment) lineSegment (StartPointOf lineSegment)
forall seg p. HasStartPoint seg p => Lens' seg p
Lens' lineSegment (StartPointOf lineSegment)
startPoint) Bool -> Bool -> Bool
&& Point 2 r
p Point 2 r -> Point 2 r -> Bool
forall a. Eq a => a -> a -> Bool
== lineSegment
seglineSegment
-> Getting (Point 2 r) lineSegment (Point 2 r) -> Point 2 r
forall s a. s -> Getting a s a -> a
^.(point -> Const (Point 2 r) point)
-> lineSegment -> Const (Point 2 r) lineSegment
forall seg p. HasStart seg p => Lens' seg p
Lens' lineSegment point
start((point -> Const (Point 2 r) point)
-> lineSegment -> Const (Point 2 r) lineSegment)
-> ((Point 2 r -> Const (Point 2 r) (Point 2 r))
-> point -> Const (Point 2 r) point)
-> Getting (Point 2 r) lineSegment (Point 2 r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Point 2 r -> Const (Point 2 r) (Point 2 r))
-> point -> Const (Point 2 r) point
forall point (d :: Nat) r.
Point_ point d r =>
Lens' point (Point d r)
Lens' point (Point 2 r)
asPoint) [lineSegment]
contains
closedEnds :: [lineSegment]
closedEnds = (lineSegment -> Bool) -> [lineSegment] -> [lineSegment]
forall a. (a -> Bool) -> [a] -> [a]
filter (EndPointOf lineSegment -> Bool
forall endPoint. EndPoint_ endPoint => endPoint -> Bool
isClosed (EndPointOf lineSegment -> Bool)
-> (lineSegment -> EndPointOf lineSegment) -> lineSegment -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting
(EndPointOf lineSegment) lineSegment (EndPointOf lineSegment)
-> lineSegment -> EndPointOf lineSegment
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting
(EndPointOf lineSegment) lineSegment (EndPointOf lineSegment)
forall seg p. HasEndPoint seg p => Lens' seg p
Lens' lineSegment (EndPointOf lineSegment)
endPoint) [lineSegment]
ends
toReport :: [IntersectionPoint (Point 2 r) lineSegment]
toReport = case [lineSegment]
starts' [lineSegment] -> [lineSegment] -> [lineSegment]
forall a. Semigroup a => a -> a -> a
<> [lineSegment]
closedEnds [lineSegment] -> [lineSegment] -> [lineSegment]
forall a. Semigroup a => a -> a -> a
<> [lineSegment]
pureContains of
(lineSegment
_:lineSegment
_:[lineSegment]
_) -> [ Point 2 r
-> [lineSegment]
-> [lineSegment]
-> IntersectionPoint (Point 2 r) lineSegment
forall lineSegment endPoint r point.
(LineSegment_ lineSegment endPoint, Point_ endPoint 2 r,
Point_ point 2 r, Eq r, OrdArounds lineSegment) =>
point
-> [lineSegment]
-> [lineSegment]
-> IntersectionPoint point lineSegment
mkIntersectionPoint Point 2 r
p ([lineSegment]
starts' [lineSegment] -> [lineSegment] -> [lineSegment]
forall a. Semigroup a => a -> a -> a
<> [lineSegment]
closedEnds) [lineSegment]
pureContains ]
[lineSegment]
_ -> []
ss' :: StatusStructure r lineSegment
ss' = StatusStructure r lineSegment
before StatusStructure r lineSegment
-> StatusStructure r lineSegment -> StatusStructure r lineSegment
forall a. Set a -> Set a -> Set a
`SS.join` StatusStructure r lineSegment
newSegs StatusStructure r lineSegment
-> StatusStructure r lineSegment -> StatusStructure r lineSegment
forall a. Set a -> Set a -> Set a
`SS.join` StatusStructure r lineSegment
after
newSegs :: StatusStructure r lineSegment
newSegs = Point 2 r -> [lineSegment] -> StatusStructure r lineSegment
forall lineSegment point r.
(LineSegment_ lineSegment point, Point_ point 2 r, Ord r,
Fractional r) =>
Point 2 r -> [lineSegment] -> StatusStructure r lineSegment
toStatusStruct Point 2 r
p ([lineSegment] -> StatusStructure r lineSegment)
-> [lineSegment] -> StatusStructure r lineSegment
forall a b. (a -> b) -> a -> b
$ [lineSegment]
starts [lineSegment] -> [lineSegment] -> [lineSegment]
forall a. [a] -> [a] -> [a]
++ [lineSegment]
contains
eq' :: EventQueue r lineSegment
eq' = (Event r lineSegment
-> EventQueue r lineSegment -> EventQueue r lineSegment)
-> EventQueue r lineSegment
-> [Event r lineSegment]
-> EventQueue r lineSegment
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Event r lineSegment
-> EventQueue r lineSegment -> EventQueue r lineSegment
forall a. Ord a => a -> Set a -> Set a
EQ.insert EventQueue r lineSegment
eq [Event r lineSegment]
es
es :: [Event r lineSegment]
es | StatusStructure r lineSegment -> Bool
forall a. Set a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
F.null StatusStructure r lineSegment
newSegs = Maybe (Event r lineSegment) -> [Event r lineSegment]
forall a. Maybe a -> [a]
maybeToList (Maybe (Event r lineSegment) -> [Event r lineSegment])
-> Maybe (Event r lineSegment) -> [Event r lineSegment]
forall a b. (a -> b) -> a -> b
$ (lineSegment -> lineSegment -> Maybe (Event r lineSegment))
-> Maybe lineSegment
-> Maybe lineSegment
-> Maybe (Event r lineSegment)
forall {m :: * -> *} {t} {t} {b}.
Monad m =>
(t -> t -> m b) -> m t -> m t -> m b
app (Point 2 r
-> lineSegment -> lineSegment -> Maybe (Event r lineSegment)
forall lineSegment point r.
(LineSegment_ lineSegment point, Point_ point 2 r, Ord r,
Fractional r, IsIntersectableWith lineSegment lineSegment,
Intersection lineSegment lineSegment
~ Maybe (LineSegmentLineSegmentIntersection lineSegment)) =>
Point 2 r
-> lineSegment -> lineSegment -> Maybe (Event r lineSegment)
findNewEvent Point 2 r
p) Maybe lineSegment
sl Maybe lineSegment
sr
| Bool
otherwise = let s' :: Maybe lineSegment
s' = StatusStructure r lineSegment -> Maybe lineSegment
forall a. Set a -> Maybe a
SS.lookupMin StatusStructure r lineSegment
newSegs
s'' :: Maybe lineSegment
s'' = StatusStructure r lineSegment -> Maybe lineSegment
forall a. Set a -> Maybe a
SS.lookupMax StatusStructure r lineSegment
newSegs
in [Maybe (Event r lineSegment)] -> [Event r lineSegment]
forall a. [Maybe a] -> [a]
catMaybes [ (lineSegment -> lineSegment -> Maybe (Event r lineSegment))
-> Maybe lineSegment
-> Maybe lineSegment
-> Maybe (Event r lineSegment)
forall {m :: * -> *} {t} {t} {b}.
Monad m =>
(t -> t -> m b) -> m t -> m t -> m b
app (Point 2 r
-> lineSegment -> lineSegment -> Maybe (Event r lineSegment)
forall lineSegment point r.
(LineSegment_ lineSegment point, Point_ point 2 r, Ord r,
Fractional r, IsIntersectableWith lineSegment lineSegment,
Intersection lineSegment lineSegment
~ Maybe (LineSegmentLineSegmentIntersection lineSegment)) =>
Point 2 r
-> lineSegment -> lineSegment -> Maybe (Event r lineSegment)
findNewEvent Point 2 r
p) Maybe lineSegment
sl Maybe lineSegment
s'
, (lineSegment -> lineSegment -> Maybe (Event r lineSegment))
-> Maybe lineSegment
-> Maybe lineSegment
-> Maybe (Event r lineSegment)
forall {m :: * -> *} {t} {t} {b}.
Monad m =>
(t -> t -> m b) -> m t -> m t -> m b
app (Point 2 r
-> lineSegment -> lineSegment -> Maybe (Event r lineSegment)
forall lineSegment point r.
(LineSegment_ lineSegment point, Point_ point 2 r, Ord r,
Fractional r, IsIntersectableWith lineSegment lineSegment,
Intersection lineSegment lineSegment
~ Maybe (LineSegmentLineSegmentIntersection lineSegment)) =>
Point 2 r
-> lineSegment -> lineSegment -> Maybe (Event r lineSegment)
findNewEvent Point 2 r
p) Maybe lineSegment
s'' Maybe lineSegment
sr
]
sl :: Maybe lineSegment
sl = StatusStructure r lineSegment -> Maybe lineSegment
forall a. Set a -> Maybe a
SS.lookupMax StatusStructure r lineSegment
before
sr :: Maybe lineSegment
sr = StatusStructure r lineSegment -> Maybe lineSegment
forall a. Set a -> Maybe a
SS.lookupMin StatusStructure r lineSegment
after
app :: (t -> t -> m b) -> m t -> m t -> m b
app t -> t -> m b
f m t
x m t
y = do { t
x' <- m t
x ; t
y' <- m t
y ; t -> t -> m b
f t
x' t
y'}
shouldReport :: ( LineSegment_ lineSegment point
, Point_ point 2 r
, Ord r, Num r
, HasIntersectionWith lineSegment lineSegment
) => a -> [lineSegment] -> [lineSegment]
shouldReport :: forall lineSegment point r a.
(LineSegment_ lineSegment point, Point_ point 2 r, Ord r, Num r,
HasIntersectionWith lineSegment lineSegment) =>
a -> [lineSegment] -> [lineSegment]
shouldReport a
_ = (lineSegment -> Bool)
-> (lineSegment -> lineSegment -> Bool)
-> [lineSegment]
-> [lineSegment]
forall a. (a -> Bool) -> (a -> a -> Bool) -> [a] -> [a]
overlapsOr (StartPointOf lineSegment -> Bool
forall endPoint. EndPoint_ endPoint => endPoint -> Bool
isClosed (StartPointOf lineSegment -> Bool)
-> (lineSegment -> StartPointOf lineSegment) -> lineSegment -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting
(StartPointOf lineSegment) lineSegment (StartPointOf lineSegment)
-> lineSegment -> StartPointOf lineSegment
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting
(StartPointOf lineSegment) lineSegment (StartPointOf lineSegment)
forall seg p. HasStartPoint seg p => Lens' seg p
Lens' lineSegment (StartPointOf lineSegment)
startPoint) lineSegment -> lineSegment -> Bool
forall g h. HasIntersectionWith g h => g -> h -> Bool
intersects
extractContains :: ( LineSegment_ lineSegment point
, HasOnSegment lineSegment 2
, Point_ point 2 r
, Ord r, Fractional r
)
=> Point 2 r -> StatusStructure r lineSegment
-> (StatusStructure r lineSegment, [lineSegment], StatusStructure r lineSegment)
Point 2 r
p StatusStructure r lineSegment
ss = (StatusStructure r lineSegment
before, StatusStructure r lineSegment -> [lineSegment]
forall a. Set a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList StatusStructure r lineSegment
mid1 [lineSegment] -> [lineSegment] -> [lineSegment]
forall a. Semigroup a => a -> a -> a
<> StatusStructure r lineSegment -> [lineSegment]
forall a. Set a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList StatusStructure r lineSegment
mid2, StatusStructure r lineSegment
after)
where
(StatusStructure r lineSegment
before, StatusStructure r lineSegment
mid1, StatusStructure r lineSegment
after') = (lineSegment -> r)
-> r
-> StatusStructure r lineSegment
-> (StatusStructure r lineSegment, StatusStructure r lineSegment,
StatusStructure r lineSegment)
forall b a.
Ord b =>
(a -> b) -> b -> Set a -> (Set a, Set a, Set a)
SS.splitOn (r -> lineSegment -> r
forall r lineSegment point.
(Fractional r, Ord r, LineSegment_ lineSegment point,
Point_ point 2 r) =>
r -> lineSegment -> r
xCoordAt (r -> lineSegment -> r) -> r -> lineSegment -> r
forall a b. (a -> b) -> a -> b
$ Point 2 r
pPoint 2 r -> Getting r (Point 2 r) r -> r
forall s a. s -> Getting a s a -> a
^.Getting r (Point 2 r) r
forall (d :: Nat) point r.
(2 <= d, Point_ point d r) =>
IndexedLens' Int point r
IndexedLens' Int (Point 2 r) r
yCoord) (Point 2 r
pPoint 2 r -> Getting r (Point 2 r) r -> r
forall s a. s -> Getting a s a -> a
^.Getting r (Point 2 r) r
forall (d :: Nat) point r.
(1 <= d, Point_ point d r) =>
IndexedLens' Int point r
IndexedLens' Int (Point 2 r) r
xCoord) StatusStructure r lineSegment
ss
(StatusStructure r lineSegment
mid2, StatusStructure r lineSegment
after) = (lineSegment -> Bool)
-> StatusStructure r lineSegment
-> (StatusStructure r lineSegment, StatusStructure r lineSegment)
forall a. (a -> Bool) -> Set a -> (Set a, Set a)
SS.spanAntitone (Point 2 r -> lineSegment -> Bool
forall lineSegment (d :: Nat) r point.
(HasOnSegment lineSegment d, Ord r, Point_ point d r,
r ~ NumType lineSegment, d ~ Dimension lineSegment) =>
point -> lineSegment -> Bool
forall r point.
(Ord r, Point_ point 2 r, r ~ NumType lineSegment,
2 ~ Dimension lineSegment) =>
point -> lineSegment -> Bool
onSegment Point 2 r
p) StatusStructure r lineSegment
after'
toStatusStruct :: ( LineSegment_ lineSegment point
, Point_ point 2 r
, Ord r, Fractional r
)
=> Point 2 r -> [lineSegment] -> StatusStructure r lineSegment
toStatusStruct :: forall lineSegment point r.
(LineSegment_ lineSegment point, Point_ point 2 r, Ord r,
Fractional r) =>
Point 2 r -> [lineSegment] -> StatusStructure r lineSegment
toStatusStruct Point 2 r
p [lineSegment]
xs = Set lineSegment
ss Set lineSegment -> Set lineSegment -> Set lineSegment
forall a. Set a -> Set a -> Set a
`SS.join` Set lineSegment
hors
where
([lineSegment]
hors',[lineSegment]
rest) = (lineSegment -> Bool)
-> [lineSegment] -> ([lineSegment], [lineSegment])
forall a. (a -> Bool) -> [a] -> ([a], [a])
List.partition lineSegment -> Bool
forall {p} {p} {s}.
(NumType p ~ NumType p,
Assert
(OrdCond (CmpNat 2 (Dimension p)) 'True 'True 'False)
(TypeError ...),
Assert
(OrdCond (CmpNat 2 (Dimension p)) 'True 'True 'False)
(TypeError ...),
Eq (NumType p), HasStart s p, HasEnd s p,
Point_ p (Dimension p) (NumType p),
Point_ p (Dimension p) (NumType p)) =>
s -> Bool
isHorizontal [lineSegment]
xs
ss :: Set lineSegment
ss = (lineSegment -> lineSegment -> Ordering)
-> [lineSegment] -> Set lineSegment
forall a. (a -> a -> Ordering) -> [a] -> Set a
SS.fromListBy (r -> lineSegment -> lineSegment -> Ordering
forall r lineSegment point.
(Num r, Ord r, LineSegment_ lineSegment point, Point_ point 2 r) =>
r -> lineSegment -> lineSegment -> Ordering
ordAtY (r -> lineSegment -> lineSegment -> Ordering)
-> r -> lineSegment -> lineSegment -> Ordering
forall a b. (a -> b) -> a -> b
$ [lineSegment] -> r
maxY [lineSegment]
xs) [lineSegment]
rest
hors :: Set lineSegment
hors = (lineSegment -> lineSegment -> Ordering)
-> [lineSegment] -> Set lineSegment
forall a. (a -> a -> Ordering) -> [a] -> Set a
SS.fromListBy ((lineSegment -> r) -> lineSegment -> lineSegment -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing lineSegment -> r
forall lineSegment point r.
(LineSegment_ lineSegment point, Point_ point 2 r, Ord r) =>
lineSegment -> r
rightEndpoint) [lineSegment]
hors'
isHorizontal :: s -> Bool
isHorizontal s
s = s
ss -> Getting (NumType p) s (NumType p) -> NumType p
forall s a. s -> Getting a s a -> a
^.(p -> Const (NumType p) p) -> s -> Const (NumType p) s
forall seg p. HasStart seg p => Lens' seg p
Lens' s p
start((p -> Const (NumType p) p) -> s -> Const (NumType p) s)
-> ((NumType p -> Const (NumType p) (NumType p))
-> p -> Const (NumType p) p)
-> Getting (NumType p) s (NumType p)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(NumType p -> Const (NumType p) (NumType p))
-> p -> Const (NumType p) p
forall (d :: Nat) point r.
(2 <= d, Point_ point d r) =>
IndexedLens' Int point r
IndexedLens' Int p (NumType p)
yCoord NumType p -> NumType p -> Bool
forall a. Eq a => a -> a -> Bool
== s
ss -> Getting (NumType p) s (NumType p) -> NumType p
forall s a. s -> Getting a s a -> a
^.(p -> Const (NumType p) p) -> s -> Const (NumType p) s
forall seg p. HasEnd seg p => Lens' seg p
Lens' s p
end((p -> Const (NumType p) p) -> s -> Const (NumType p) s)
-> ((NumType p -> Const (NumType p) (NumType p))
-> p -> Const (NumType p) p)
-> Getting (NumType p) s (NumType p)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(NumType p -> Const (NumType p) (NumType p))
-> p -> Const (NumType p) p
forall (d :: Nat) point r.
(2 <= d, Point_ point d r) =>
IndexedLens' Int point r
IndexedLens' Int p (NumType p)
yCoord
maxY :: [lineSegment] -> r
maxY [lineSegment]
segs = [r] -> r
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [ r
y
| lineSegment
s <- [lineSegment]
segs
, r
y <- [lineSegment
slineSegment -> Getting r lineSegment r -> r
forall s a. s -> Getting a s a -> a
^.(point -> Const r point) -> lineSegment -> Const r lineSegment
forall seg p. HasStart seg p => Lens' seg p
Lens' lineSegment point
start((point -> Const r point) -> lineSegment -> Const r lineSegment)
-> ((r -> Const r r) -> point -> Const r point)
-> Getting r lineSegment r
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(r -> Const r r) -> point -> Const r point
forall (d :: Nat) point r.
(2 <= d, Point_ point d r) =>
IndexedLens' Int point r
IndexedLens' Int point r
yCoord, lineSegment
slineSegment -> Getting r lineSegment r -> r
forall s a. s -> Getting a s a -> a
^.(point -> Const r point) -> lineSegment -> Const r lineSegment
forall seg p. HasEnd seg p => Lens' seg p
Lens' lineSegment point
end((point -> Const r point) -> lineSegment -> Const r lineSegment)
-> ((r -> Const r r) -> point -> Const r point)
-> Getting r lineSegment r
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(r -> Const r r) -> point -> Const r point
forall (d :: Nat) point r.
(2 <= d, Point_ point d r) =>
IndexedLens' Int point r
IndexedLens' Int point r
yCoord], r
y r -> r -> Bool
forall a. Ord a => a -> a -> Bool
< Point 2 r
pPoint 2 r -> Getting r (Point 2 r) r -> r
forall s a. s -> Getting a s a -> a
^.Getting r (Point 2 r) r
forall (d :: Nat) point r.
(2 <= d, Point_ point d r) =>
IndexedLens' Int point r
IndexedLens' Int (Point 2 r) r
yCoord
]
rightEndpoint :: (LineSegment_ lineSegment point, Point_ point 2 r, Ord r) => lineSegment -> r
rightEndpoint :: forall lineSegment point r.
(LineSegment_ lineSegment point, Point_ point 2 r, Ord r) =>
lineSegment -> r
rightEndpoint lineSegment
s = (lineSegment
slineSegment -> Getting r lineSegment r -> r
forall s a. s -> Getting a s a -> a
^.(point -> Const r point) -> lineSegment -> Const r lineSegment
forall seg p. HasStart seg p => Lens' seg p
Lens' lineSegment point
start((point -> Const r point) -> lineSegment -> Const r lineSegment)
-> ((r -> Const r r) -> point -> Const r point)
-> Getting r lineSegment r
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(r -> Const r r) -> point -> Const r point
forall (d :: Nat) point r.
(1 <= d, Point_ point d r) =>
IndexedLens' Int point r
IndexedLens' Int point r
xCoord) r -> r -> r
forall a. Ord a => a -> a -> a
`max` (lineSegment
slineSegment -> Getting r lineSegment r -> r
forall s a. s -> Getting a s a -> a
^.(point -> Const r point) -> lineSegment -> Const r lineSegment
forall seg p. HasEnd seg p => Lens' seg p
Lens' lineSegment point
end((point -> Const r point) -> lineSegment -> Const r lineSegment)
-> ((r -> Const r r) -> point -> Const r point)
-> Getting r lineSegment r
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(r -> Const r r) -> point -> Const r point
forall (d :: Nat) point r.
(1 <= d, Point_ point d r) =>
IndexedLens' Int point r
IndexedLens' Int point r
xCoord)
endsAt :: ( LineSegment_ lineSegment point
, Point_ point 2 r
, Eq r
) => Point 2 r -> lineSegment -> Bool
endsAt :: forall lineSegment point r.
(LineSegment_ lineSegment point, Point_ point 2 r, Eq r) =>
Point 2 r -> lineSegment -> Bool
endsAt Point 2 r
p lineSegment
seg = lineSegment
seglineSegment
-> Getting (Point 2 r) lineSegment (Point 2 r) -> Point 2 r
forall s a. s -> Getting a s a -> a
^.(point -> Const (Point 2 r) point)
-> lineSegment -> Const (Point 2 r) lineSegment
forall seg p. HasEnd seg p => Lens' seg p
Lens' lineSegment point
end((point -> Const (Point 2 r) point)
-> lineSegment -> Const (Point 2 r) lineSegment)
-> ((Point 2 r -> Const (Point 2 r) (Point 2 r))
-> point -> Const (Point 2 r) point)
-> Getting (Point 2 r) lineSegment (Point 2 r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Point 2 r -> Const (Point 2 r) (Point 2 r))
-> point -> Const (Point 2 r) point
forall point (d :: Nat) r.
Point_ point d r =>
Lens' point (Point d r)
Lens' point (Point 2 r)
asPoint Point 2 r -> Point 2 r -> Bool
forall a. Eq a => a -> a -> Bool
== Point 2 r
p
findNewEvent :: ( LineSegment_ lineSegment point
, Point_ point 2 r, Ord r, Fractional r
, IsIntersectableWith lineSegment lineSegment
, Intersection lineSegment lineSegment ~
Maybe (LineSegmentLineSegmentIntersection lineSegment)
)
=> Point 2 r -> lineSegment -> lineSegment
-> Maybe (Event r lineSegment)
findNewEvent :: forall lineSegment point r.
(LineSegment_ lineSegment point, Point_ point 2 r, Ord r,
Fractional r, IsIntersectableWith lineSegment lineSegment,
Intersection lineSegment lineSegment
~ Maybe (LineSegmentLineSegmentIntersection lineSegment)) =>
Point 2 r
-> lineSegment -> lineSegment -> Maybe (Event r lineSegment)
findNewEvent Point 2 r
p lineSegment
l lineSegment
r = lineSegment
l lineSegment -> lineSegment -> Intersection lineSegment lineSegment
forall g h. IsIntersectableWith g h => g -> h -> Intersection g h
`intersect` lineSegment
r Maybe (LineSegmentLineSegmentIntersection lineSegment)
-> (LineSegmentLineSegmentIntersection lineSegment
-> Maybe (Event r lineSegment))
-> Maybe (Event r lineSegment)
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
LineSegment_x_LineSegment_Point Point 2 (NumType lineSegment)
q
| Point 2 r -> Point 2 r -> Ordering
forall point r.
(Point_ point 2 r, Ord r) =>
point -> point -> Ordering
ordPoints Point 2 r
Point 2 (NumType lineSegment)
q Point 2 r
p Ordering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
== Ordering
GT -> Event r lineSegment -> Maybe (Event r lineSegment)
forall a. a -> Maybe a
Just (Point 2 r -> EventType lineSegment -> Event r lineSegment
forall r lineSegment.
Point 2 r -> EventType lineSegment -> Event r lineSegment
Event Point 2 r
Point 2 (NumType lineSegment)
q EventType lineSegment
forall s. EventType s
Intersection)
| Bool
otherwise -> Maybe (Event r lineSegment)
forall a. Maybe a
Nothing
LineSegment_x_LineSegment_LineSegment lineSegment
_ -> Maybe (Event r lineSegment)
forall a. Maybe a
Nothing
overlapsOr :: (a -> Bool)
-> (a -> a -> Bool)
-> [a]
-> [a]
overlapsOr :: forall a. (a -> Bool) -> (a -> a -> Bool) -> [a] -> [a]
overlapsOr a -> Bool
p a -> a -> Bool
q = ((a, Bool) -> a) -> [(a, Bool)] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map (a, Bool) -> a
forall a b. (a, b) -> a
fst ([(a, Bool)] -> [a]) -> ([a] -> [(a, Bool)]) -> [a] -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((a, Bool) -> Bool) -> [(a, Bool)] -> [(a, Bool)]
forall a. (a -> Bool) -> [a] -> [a]
filter (a, Bool) -> Bool
forall a b. (a, b) -> b
snd ([(a, Bool)] -> [(a, Bool)])
-> ([a] -> [(a, Bool)]) -> [a] -> [(a, Bool)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (((a, Bool), Bool) -> (a, Bool))
-> [((a, Bool), Bool)] -> [(a, Bool)]
forall a b. (a -> b) -> [a] -> [b]
map (\((a
a,Bool
b),Bool
b') -> (a
a, Bool
b Bool -> Bool -> Bool
|| Bool
b'))
([((a, Bool), Bool)] -> [(a, Bool)])
-> ([a] -> [((a, Bool), Bool)]) -> [a] -> [(a, Bool)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((a, Bool) -> (a, Bool) -> Bool)
-> [(a, Bool)] -> [((a, Bool), Bool)]
forall a. (a -> a -> Bool) -> [a] -> [(a, Bool)]
overlapsWithNeighbour (a -> a -> Bool
q (a -> a -> Bool)
-> ((a, Bool) -> a) -> (a, Bool) -> (a, Bool) -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (a, Bool) -> a
forall a b. (a, b) -> a
fst)
([(a, Bool)] -> [((a, Bool), Bool)])
-> ([a] -> [(a, Bool)]) -> [a] -> [((a, Bool), Bool)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> (a, Bool)) -> [a] -> [(a, Bool)]
forall a b. (a -> b) -> [a] -> [b]
map (\a
x -> (a
x, a -> Bool
p a
x))
overlapsWithNeighbour :: (a -> a -> Bool) -> [a] -> [(a,Bool)]
overlapsWithNeighbour :: forall a. (a -> a -> Bool) -> [a] -> [(a, Bool)]
overlapsWithNeighbour a -> a -> Bool
p = [a] -> [(a, Bool)]
go0
where
go0 :: [a] -> [(a, Bool)]
go0 = \case
[] -> []
(a
x:[a]
xs) -> a -> Bool -> [a] -> [(a, Bool)]
go a
x Bool
False [a]
xs
go :: a -> Bool -> [a] -> [(a, Bool)]
go a
x Bool
b = \case
[] -> [(a
x,Bool
b)]
(a
y:[a]
ys) -> let b' :: Bool
b' = a -> a -> Bool
p a
x a
y
in (a
x,Bool
b Bool -> Bool -> Bool
|| Bool
b') (a, Bool) -> [(a, Bool)] -> [(a, Bool)]
forall a. a -> [a] -> [a]
: a -> Bool -> [a] -> [(a, Bool)]
go a
y Bool
b' [a]
ys
data Flipped segment = NotFlipped segment
| Flipped segment
deriving (Int -> Flipped segment -> ShowS
[Flipped segment] -> ShowS
Flipped segment -> String
(Int -> Flipped segment -> ShowS)
-> (Flipped segment -> String)
-> ([Flipped segment] -> ShowS)
-> Show (Flipped segment)
forall segment. Show segment => Int -> Flipped segment -> ShowS
forall segment. Show segment => [Flipped segment] -> ShowS
forall segment. Show segment => Flipped segment -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall segment. Show segment => Int -> Flipped segment -> ShowS
showsPrec :: Int -> Flipped segment -> ShowS
$cshow :: forall segment. Show segment => Flipped segment -> String
show :: Flipped segment -> String
$cshowList :: forall segment. Show segment => [Flipped segment] -> ShowS
showList :: [Flipped segment] -> ShowS
Show,Flipped segment -> Flipped segment -> Bool
(Flipped segment -> Flipped segment -> Bool)
-> (Flipped segment -> Flipped segment -> Bool)
-> Eq (Flipped segment)
forall segment.
Eq segment =>
Flipped segment -> Flipped segment -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall segment.
Eq segment =>
Flipped segment -> Flipped segment -> Bool
== :: Flipped segment -> Flipped segment -> Bool
$c/= :: forall segment.
Eq segment =>
Flipped segment -> Flipped segment -> Bool
/= :: Flipped segment -> Flipped segment -> Bool
Eq,(forall a b. (a -> b) -> Flipped a -> Flipped b)
-> (forall a b. a -> Flipped b -> Flipped a) -> Functor Flipped
forall a b. a -> Flipped b -> Flipped a
forall a b. (a -> b) -> Flipped a -> Flipped b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> Flipped a -> Flipped b
fmap :: forall a b. (a -> b) -> Flipped a -> Flipped b
$c<$ :: forall a b. a -> Flipped b -> Flipped a
<$ :: forall a b. a -> Flipped b -> Flipped a
Functor)
rawSegment :: Lens' (Flipped segment) segment
rawSegment :: forall segment (f :: * -> *).
Functor f =>
(segment -> f segment) -> Flipped segment -> f (Flipped segment)
rawSegment = (Flipped segment -> segment)
-> (Flipped segment -> segment -> Flipped segment)
-> Lens (Flipped segment) (Flipped segment) segment segment
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens (\case
NotFlipped segment
s -> segment
s
Flipped segment
s -> segment
s
)
(\Flipped segment
fs segment
seg -> segment
seg segment -> Flipped segment -> Flipped segment
forall a b. a -> Flipped b -> Flipped a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Flipped segment
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 :: Lens' (Flipped lineSegment) point
start = (lineSegment -> f lineSegment)
-> Flipped lineSegment -> f (Flipped lineSegment)
forall segment (f :: * -> *).
Functor f =>
(segment -> f segment) -> Flipped segment -> f (Flipped segment)
rawSegment((lineSegment -> f lineSegment)
-> Flipped lineSegment -> f (Flipped lineSegment))
-> ((point -> f point) -> lineSegment -> f lineSegment)
-> (point -> f point)
-> Flipped lineSegment
-> f (Flipped lineSegment)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(point -> f point) -> lineSegment -> f lineSegment
forall seg p. HasStart seg p => Lens' seg p
Lens' lineSegment point
start
instance ( HasStartPoint lineSegment endPoint
) => HasStartPoint (Flipped lineSegment) endPoint where
startPoint :: Lens' (Flipped lineSegment) endPoint
startPoint = (lineSegment -> f lineSegment)
-> Flipped lineSegment -> f (Flipped lineSegment)
forall segment (f :: * -> *).
Functor f =>
(segment -> f segment) -> Flipped segment -> f (Flipped segment)
rawSegment((lineSegment -> f lineSegment)
-> Flipped lineSegment -> f (Flipped lineSegment))
-> ((endPoint -> f endPoint) -> lineSegment -> f lineSegment)
-> (endPoint -> f endPoint)
-> Flipped lineSegment
-> f (Flipped lineSegment)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(endPoint -> f endPoint) -> lineSegment -> f lineSegment
forall seg p. HasStartPoint seg p => Lens' seg p
Lens' lineSegment endPoint
startPoint
instance HasEnd lineSegment point => HasEnd (Flipped lineSegment) point where
end :: Lens' (Flipped lineSegment) point
end = (lineSegment -> f lineSegment)
-> Flipped lineSegment -> f (Flipped lineSegment)
forall segment (f :: * -> *).
Functor f =>
(segment -> f segment) -> Flipped segment -> f (Flipped segment)
rawSegment((lineSegment -> f lineSegment)
-> Flipped lineSegment -> f (Flipped lineSegment))
-> ((point -> f point) -> lineSegment -> f lineSegment)
-> (point -> f point)
-> Flipped lineSegment
-> f (Flipped lineSegment)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(point -> f point) -> lineSegment -> f lineSegment
forall seg p. HasEnd seg p => Lens' seg p
Lens' lineSegment point
end
instance ( HasEndPoint lineSegment endPoint
) => HasEndPoint (Flipped lineSegment) endPoint where
endPoint :: Lens' (Flipped lineSegment) endPoint
endPoint = (lineSegment -> f lineSegment)
-> Flipped lineSegment -> f (Flipped lineSegment)
forall segment (f :: * -> *).
Functor f =>
(segment -> f segment) -> Flipped segment -> f (Flipped segment)
rawSegment((lineSegment -> f lineSegment)
-> Flipped lineSegment -> f (Flipped lineSegment))
-> ((endPoint -> f endPoint) -> lineSegment -> f lineSegment)
-> (endPoint -> f endPoint)
-> Flipped lineSegment
-> f (Flipped lineSegment)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(endPoint -> f endPoint) -> lineSegment -> f lineSegment
forall seg p. HasEndPoint seg p => Lens' seg p
Lens' lineSegment endPoint
endPoint
type instance StartPointOf (Flipped lineSegment) = StartPointOf lineSegment
type instance EndPointOf (Flipped lineSegment) = EndPointOf lineSegment
instance IntervalLike_ lineSegment point => IntervalLike_ (Flipped lineSegment) point
instance LineSegment_ lineSegment point => LineSegment_ (Flipped lineSegment) point
instance ConstructableLineSegment_ lineSegment point
=> ConstructableLineSegment_ (Flipped lineSegment) point where
uncheckedLineSegment :: point -> point -> Flipped lineSegment
uncheckedLineSegment point
s point
t = lineSegment -> Flipped lineSegment
forall segment. segment -> Flipped segment
NotFlipped (lineSegment -> Flipped lineSegment)
-> lineSegment -> Flipped lineSegment
forall a b. (a -> b) -> a -> b
$ point -> point -> lineSegment
forall lineSegment point.
ConstructableLineSegment_ lineSegment point =>
point -> point -> lineSegment
uncheckedLineSegment point
s point
t
instance segment `HasIntersectionWith` segment
=> (Flipped segment) `HasIntersectionWith` (Flipped segment) where
Flipped segment
a intersects :: Flipped segment -> Flipped segment -> Bool
`intersects` Flipped segment
b = (Flipped segment
aFlipped segment
-> Getting segment (Flipped segment) segment -> segment
forall s a. s -> Getting a s a -> a
^.Getting segment (Flipped segment) segment
forall segment (f :: * -> *).
Functor f =>
(segment -> f segment) -> Flipped segment -> f (Flipped segment)
rawSegment) segment -> segment -> Bool
forall g h. HasIntersectionWith g h => g -> h -> Bool
`intersects` (Flipped segment
bFlipped segment
-> Getting segment (Flipped segment) segment -> segment
forall s a. s -> Getting a s a -> a
^.Getting segment (Flipped segment) segment
forall segment (f :: * -> *).
Functor f =>
(segment -> f segment) -> Flipped segment -> f (Flipped segment)
rawSegment)
instance HasOnSegment segment 2 => HasOnSegment (Flipped segment) 2 where
onSegment :: forall r point.
(Ord r, Point_ point 2 r, r ~ NumType (Flipped segment),
2 ~ Dimension (Flipped segment)) =>
point -> Flipped segment -> Bool
onSegment point
q Flipped segment
s = point -> segment -> Bool
forall lineSegment (d :: Nat) r point.
(HasOnSegment lineSegment d, Ord r, Point_ point d r,
r ~ NumType lineSegment, d ~ Dimension lineSegment) =>
point -> lineSegment -> Bool
forall r point.
(Ord r, Point_ point 2 r, r ~ NumType segment,
2 ~ Dimension segment) =>
point -> segment -> Bool
onSegment point
q (Flipped segment
sFlipped segment
-> Getting segment (Flipped segment) segment -> segment
forall s a. s -> Getting a s a -> a
^.Getting segment (Flipped segment) segment
forall segment (f :: * -> *).
Functor f =>
(segment -> f segment) -> Flipped segment -> f (Flipped segment)
rawSegment)
instance (segment `IsIntersectableWith` segment
, Intersection segment segment ~ Maybe (LineSegmentLineSegmentIntersection segment)
) => (Flipped segment) `IsIntersectableWith` (Flipped segment) where
Flipped segment
a intersect :: Flipped segment
-> Flipped segment
-> Intersection (Flipped segment) (Flipped segment)
`intersect` Flipped segment
b = segment -> segment -> Intersection segment segment
forall g h. IsIntersectableWith g h => g -> h -> Intersection g h
intersect (Flipped segment
aFlipped segment
-> Getting segment (Flipped segment) segment -> segment
forall s a. s -> Getting a s a -> a
^.Getting segment (Flipped segment) segment
forall segment (f :: * -> *).
Functor f =>
(segment -> f segment) -> Flipped segment -> f (Flipped segment)
rawSegment) (Flipped segment
bFlipped segment
-> Getting segment (Flipped segment) segment -> segment
forall s a. s -> Getting a s a -> a
^.Getting segment (Flipped segment) segment
forall segment (f :: * -> *).
Functor f =>
(segment -> f segment) -> Flipped segment -> f (Flipped segment)
rawSegment) Maybe (LineSegmentLineSegmentIntersection segment)
-> (LineSegmentLineSegmentIntersection segment
-> LineSegmentLineSegmentIntersection (Flipped segment))
-> Maybe (LineSegmentLineSegmentIntersection (Flipped segment))
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
LineSegment_x_LineSegment_Point Point 2 (NumType segment)
p -> Point 2 (NumType (Flipped segment))
-> LineSegmentLineSegmentIntersection (Flipped segment)
forall lineSegment.
Point 2 (NumType lineSegment)
-> LineSegmentLineSegmentIntersection lineSegment
LineSegment_x_LineSegment_Point Point 2 (NumType segment)
Point 2 (NumType (Flipped segment))
p
LineSegment_x_LineSegment_LineSegment segment
seg ->
Flipped segment
-> LineSegmentLineSegmentIntersection (Flipped segment)
forall lineSegment.
lineSegment -> LineSegmentLineSegmentIntersection lineSegment
LineSegment_x_LineSegment_LineSegment (Flipped segment
-> LineSegmentLineSegmentIntersection (Flipped segment))
-> Flipped segment
-> LineSegmentLineSegmentIntersection (Flipped segment)
forall a b. (a -> b) -> a -> b
$ segment -> Flipped segment
forall segment. segment -> Flipped segment
NotFlipped segment
seg
tagFlipped :: (LineSegment_ lineSegment point, Point_ point 2 r, Ord r
, StartPointOf lineSegment ~ EndPointOf lineSegment
)
=> lineSegment -> Flipped lineSegment
tagFlipped :: forall lineSegment point r.
(LineSegment_ lineSegment point, Point_ point 2 r, Ord r,
StartPointOf lineSegment ~ EndPointOf lineSegment) =>
lineSegment -> Flipped lineSegment
tagFlipped lineSegment
s = case (lineSegment
slineSegment -> Getting point lineSegment point -> point
forall s a. s -> Getting a s a -> a
^.Getting point lineSegment point
forall seg p. HasStart seg p => Lens' seg p
Lens' lineSegment point
start) point -> point -> Ordering
forall point r.
(Point_ point 2 r, Ord r) =>
point -> point -> Ordering
`ordPoints` (lineSegment
slineSegment -> Getting point lineSegment point -> point
forall s a. s -> Getting a s a -> a
^.Getting point lineSegment point
forall seg p. HasEnd seg p => Lens' seg p
Lens' lineSegment point
end) of
Ordering
GT -> lineSegment -> Flipped lineSegment
forall segment. segment -> Flipped segment
Flipped (lineSegment -> Flipped lineSegment)
-> lineSegment -> Flipped lineSegment
forall a b. (a -> b) -> a -> b
$ lineSegment -> lineSegment
forall lineSegment point.
(LineSegment_ lineSegment point,
StartPointOf lineSegment ~ EndPointOf lineSegment) =>
lineSegment -> lineSegment
flipSeg lineSegment
s
Ordering
_ -> lineSegment -> Flipped lineSegment
forall segment. segment -> Flipped segment
NotFlipped lineSegment
s
flipSeg :: ( LineSegment_ lineSegment point
, StartPointOf lineSegment ~ EndPointOf lineSegment
) => lineSegment -> lineSegment
flipSeg :: forall lineSegment point.
(LineSegment_ lineSegment point,
StartPointOf lineSegment ~ EndPointOf lineSegment) =>
lineSegment -> lineSegment
flipSeg lineSegment
seg = lineSegment
seglineSegment -> (lineSegment -> lineSegment) -> lineSegment
forall a b. a -> (a -> b) -> b
&(EndPointOf lineSegment -> Identity (EndPointOf lineSegment))
-> lineSegment -> Identity lineSegment
forall seg p. HasStartPoint seg p => Lens' seg p
Lens' lineSegment (EndPointOf lineSegment)
startPoint ((EndPointOf lineSegment -> Identity (EndPointOf lineSegment))
-> lineSegment -> Identity lineSegment)
-> EndPointOf lineSegment -> lineSegment -> lineSegment
forall s t a b. ASetter s t a b -> b -> s -> t
.~ (lineSegment
seglineSegment
-> Getting
(EndPointOf lineSegment) lineSegment (EndPointOf lineSegment)
-> EndPointOf lineSegment
forall s a. s -> Getting a s a -> a
^.Getting
(EndPointOf lineSegment) lineSegment (EndPointOf lineSegment)
forall seg p. HasEndPoint seg p => Lens' seg p
Lens' lineSegment (EndPointOf lineSegment)
endPoint)
lineSegment -> (lineSegment -> lineSegment) -> lineSegment
forall a b. a -> (a -> b) -> b
&(EndPointOf lineSegment -> Identity (EndPointOf lineSegment))
-> lineSegment -> Identity lineSegment
forall seg p. HasEndPoint seg p => Lens' seg p
Lens' lineSegment (EndPointOf lineSegment)
endPoint ((EndPointOf lineSegment -> Identity (EndPointOf lineSegment))
-> lineSegment -> Identity lineSegment)
-> EndPointOf lineSegment -> lineSegment -> lineSegment
forall s t a b. ASetter s t a b -> b -> s -> t
.~ (lineSegment
seglineSegment
-> Getting
(EndPointOf lineSegment) lineSegment (EndPointOf lineSegment)
-> EndPointOf lineSegment
forall s a. s -> Getting a s a -> a
^.Getting
(EndPointOf lineSegment) lineSegment (EndPointOf lineSegment)
forall seg p. HasStartPoint seg p => Lens' seg p
Lens' lineSegment (EndPointOf lineSegment)
startPoint)
isFlipped :: forall f lineSegment.
Coercible (f (Flipped lineSegment)) (Flipped lineSegment)
=> f (Flipped lineSegment) -> Bool
isFlipped :: forall (f :: * -> *) lineSegment.
Coercible (f (Flipped lineSegment)) (Flipped lineSegment) =>
f (Flipped lineSegment) -> Bool
isFlipped = (\case
Flipped lineSegment
_ -> Bool
True
Flipped lineSegment
_ -> Bool
False) (Flipped lineSegment -> Bool)
-> (f (Flipped lineSegment) -> Flipped lineSegment)
-> f (Flipped lineSegment)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Coercible a b => a -> b
forall a b. Coercible a b => a -> b
coerce @_ @(Flipped lineSegment)
unflipSegs :: ( LineSegment_ lineSegment point
, Point_ point 2 r
, Fractional r, Ord r
, IntersectConstraints lineSegment
, StartPointOf lineSegment ~ EndPointOf lineSegment
)
=> Associated (Flipped lineSegment)
-> Associated lineSegment
unflipSegs :: forall lineSegment point r.
(LineSegment_ lineSegment point, Point_ point 2 r, Fractional r,
Ord r, IntersectConstraints lineSegment,
StartPointOf lineSegment ~ EndPointOf lineSegment) =>
Associated (Flipped lineSegment) -> Associated lineSegment
unflipSegs Associated (Flipped lineSegment)
assocs = Set (AroundStart lineSegment)
-> Set (AroundEnd lineSegment)
-> Set (AroundIntersection lineSegment)
-> Associated lineSegment
forall lineSegment.
Set (AroundStart lineSegment)
-> Set (AroundEnd lineSegment)
-> Set (AroundIntersection lineSegment)
-> Associated lineSegment
Associated (Set (AroundStart (Flipped lineSegment))
-> Set (AroundStart lineSegment)
forall (f :: * -> *) lineSegment.
Functor f =>
Set (f (Flipped lineSegment)) -> Set (f lineSegment)
dropFlipped Set (AroundStart (Flipped lineSegment))
ss1 Set (AroundStart lineSegment)
-> Set (AroundStart lineSegment) -> Set (AroundStart lineSegment)
forall a. Semigroup a => a -> a -> a
<> Set (AroundEnd (Flipped lineSegment))
-> Set (AroundStart lineSegment)
forall (f :: * -> *) lineSegment (g :: * -> *) point.
(Functor f, Coercible (f lineSegment) (g lineSegment),
LineSegment_ lineSegment point,
StartPointOf lineSegment ~ EndPointOf lineSegment) =>
Set (f (Flipped lineSegment)) -> Set (g lineSegment)
unflipSegs' Set (AroundEnd (Flipped lineSegment))
es)
(Set (AroundEnd (Flipped lineSegment))
-> Set (AroundEnd lineSegment)
forall (f :: * -> *) lineSegment.
Functor f =>
Set (f (Flipped lineSegment)) -> Set (f lineSegment)
dropFlipped Set (AroundEnd (Flipped lineSegment))
es1 Set (AroundEnd lineSegment)
-> Set (AroundEnd lineSegment) -> Set (AroundEnd lineSegment)
forall a. Semigroup a => a -> a -> a
<> Set (AroundStart (Flipped lineSegment))
-> Set (AroundEnd lineSegment)
forall (f :: * -> *) lineSegment (g :: * -> *) point.
(Functor f, Coercible (f lineSegment) (g lineSegment),
LineSegment_ lineSegment point,
StartPointOf lineSegment ~ EndPointOf lineSegment) =>
Set (f (Flipped lineSegment)) -> Set (g lineSegment)
unflipSegs' Set (AroundStart (Flipped lineSegment))
ss)
(Set (AroundIntersection (Flipped lineSegment))
-> Set (AroundIntersection lineSegment)
forall (f :: * -> *) lineSegment.
Functor f =>
Set (f (Flipped lineSegment)) -> Set (f lineSegment)
dropFlipped Set (AroundIntersection (Flipped lineSegment))
is1 Set (AroundIntersection lineSegment)
-> Set (AroundIntersection lineSegment)
-> Set (AroundIntersection lineSegment)
forall a. Semigroup a => a -> a -> a
<> Set (AroundIntersection (Flipped lineSegment))
-> Set (AroundIntersection lineSegment)
forall (f :: * -> *) lineSegment (g :: * -> *) point.
(Functor f, Coercible (f lineSegment) (g lineSegment),
LineSegment_ lineSegment point,
StartPointOf lineSegment ~ EndPointOf lineSegment) =>
Set (f (Flipped lineSegment)) -> Set (g lineSegment)
unflipSegs' Set (AroundIntersection (Flipped lineSegment))
is)
where
(Set (AroundStart (Flipped lineSegment))
ss,Set (AroundStart (Flipped lineSegment))
ss1) = (AroundStart (Flipped lineSegment) -> Bool)
-> Set (AroundStart (Flipped lineSegment))
-> (Set (AroundStart (Flipped lineSegment)),
Set (AroundStart (Flipped lineSegment)))
forall a. (a -> Bool) -> Set a -> (Set a, Set a)
Set.partition AroundStart (Flipped lineSegment) -> Bool
forall (f :: * -> *) lineSegment.
Coercible (f (Flipped lineSegment)) (Flipped lineSegment) =>
f (Flipped lineSegment) -> Bool
isFlipped (Set (AroundStart (Flipped lineSegment))
-> (Set (AroundStart (Flipped lineSegment)),
Set (AroundStart (Flipped lineSegment))))
-> Set (AroundStart (Flipped lineSegment))
-> (Set (AroundStart (Flipped lineSegment)),
Set (AroundStart (Flipped lineSegment)))
forall a b. (a -> b) -> a -> b
$ Associated (Flipped lineSegment)
assocsAssociated (Flipped lineSegment)
-> Getting
(Set (AroundStart (Flipped lineSegment)))
(Associated (Flipped lineSegment))
(Set (AroundStart (Flipped lineSegment)))
-> Set (AroundStart (Flipped lineSegment))
forall s a. s -> Getting a s a -> a
^.Getting
(Set (AroundStart (Flipped lineSegment)))
(Associated (Flipped lineSegment))
(Set (AroundStart (Flipped lineSegment)))
forall lineSegment (f :: * -> *).
Functor f =>
(Set (AroundStart lineSegment)
-> f (Set (AroundStart lineSegment)))
-> Associated lineSegment -> f (Associated lineSegment)
startPointOf
(Set (AroundEnd (Flipped lineSegment))
es,Set (AroundEnd (Flipped lineSegment))
es1) = (AroundEnd (Flipped lineSegment) -> Bool)
-> Set (AroundEnd (Flipped lineSegment))
-> (Set (AroundEnd (Flipped lineSegment)),
Set (AroundEnd (Flipped lineSegment)))
forall a. (a -> Bool) -> Set a -> (Set a, Set a)
Set.partition AroundEnd (Flipped lineSegment) -> Bool
forall (f :: * -> *) lineSegment.
Coercible (f (Flipped lineSegment)) (Flipped lineSegment) =>
f (Flipped lineSegment) -> Bool
isFlipped (Set (AroundEnd (Flipped lineSegment))
-> (Set (AroundEnd (Flipped lineSegment)),
Set (AroundEnd (Flipped lineSegment))))
-> Set (AroundEnd (Flipped lineSegment))
-> (Set (AroundEnd (Flipped lineSegment)),
Set (AroundEnd (Flipped lineSegment)))
forall a b. (a -> b) -> a -> b
$ Associated (Flipped lineSegment)
assocsAssociated (Flipped lineSegment)
-> Getting
(Set (AroundEnd (Flipped lineSegment)))
(Associated (Flipped lineSegment))
(Set (AroundEnd (Flipped lineSegment)))
-> Set (AroundEnd (Flipped lineSegment))
forall s a. s -> Getting a s a -> a
^.Getting
(Set (AroundEnd (Flipped lineSegment)))
(Associated (Flipped lineSegment))
(Set (AroundEnd (Flipped lineSegment)))
forall lineSegment (f :: * -> *).
Functor f =>
(Set (AroundEnd lineSegment) -> f (Set (AroundEnd lineSegment)))
-> Associated lineSegment -> f (Associated lineSegment)
endPointOf
(Set (AroundIntersection (Flipped lineSegment))
is,Set (AroundIntersection (Flipped lineSegment))
is1) = (AroundIntersection (Flipped lineSegment) -> Bool)
-> Set (AroundIntersection (Flipped lineSegment))
-> (Set (AroundIntersection (Flipped lineSegment)),
Set (AroundIntersection (Flipped lineSegment)))
forall a. (a -> Bool) -> Set a -> (Set a, Set a)
Set.partition AroundIntersection (Flipped lineSegment) -> Bool
forall (f :: * -> *) lineSegment.
Coercible (f (Flipped lineSegment)) (Flipped lineSegment) =>
f (Flipped lineSegment) -> Bool
isFlipped (Set (AroundIntersection (Flipped lineSegment))
-> (Set (AroundIntersection (Flipped lineSegment)),
Set (AroundIntersection (Flipped lineSegment))))
-> Set (AroundIntersection (Flipped lineSegment))
-> (Set (AroundIntersection (Flipped lineSegment)),
Set (AroundIntersection (Flipped lineSegment)))
forall a b. (a -> b) -> a -> b
$ Associated (Flipped lineSegment)
assocsAssociated (Flipped lineSegment)
-> Getting
(Set (AroundIntersection (Flipped lineSegment)))
(Associated (Flipped lineSegment))
(Set (AroundIntersection (Flipped lineSegment)))
-> Set (AroundIntersection (Flipped lineSegment))
forall s a. s -> Getting a s a -> a
^.Getting
(Set (AroundIntersection (Flipped lineSegment)))
(Associated (Flipped lineSegment))
(Set (AroundIntersection (Flipped lineSegment)))
forall lineSegment (f :: * -> *).
Functor f =>
(Set (AroundIntersection lineSegment)
-> f (Set (AroundIntersection lineSegment)))
-> Associated lineSegment -> f (Associated lineSegment)
interiorTo
dropFlipped :: Functor f
=> Set.Set (f (Flipped lineSegment)) -> Set.Set (f lineSegment)
dropFlipped :: forall (f :: * -> *) lineSegment.
Functor f =>
Set (f (Flipped lineSegment)) -> Set (f lineSegment)
dropFlipped = (f (Flipped lineSegment) -> f lineSegment)
-> Set (f (Flipped lineSegment)) -> Set (f lineSegment)
forall a b. (a -> b) -> Set a -> Set b
Set.mapMonotonic ((Flipped lineSegment -> lineSegment)
-> f (Flipped lineSegment) -> f lineSegment
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Flipped lineSegment -> lineSegment)
-> f (Flipped lineSegment) -> f lineSegment)
-> (Flipped lineSegment -> lineSegment)
-> f (Flipped lineSegment)
-> f lineSegment
forall a b. (a -> b) -> a -> b
$ Getting lineSegment (Flipped lineSegment) lineSegment
-> Flipped lineSegment -> lineSegment
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting lineSegment (Flipped lineSegment) lineSegment
forall segment (f :: * -> *).
Functor f =>
(segment -> f segment) -> Flipped segment -> f (Flipped segment)
rawSegment)
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' :: forall (f :: * -> *) lineSegment (g :: * -> *) point.
(Functor f, Coercible (f lineSegment) (g lineSegment),
LineSegment_ lineSegment point,
StartPointOf lineSegment ~ EndPointOf lineSegment) =>
Set (f (Flipped lineSegment)) -> Set (g lineSegment)
unflipSegs' = (f (Flipped lineSegment) -> g lineSegment)
-> Set (f (Flipped lineSegment)) -> Set (g lineSegment)
forall a b. (a -> b) -> Set a -> Set b
Set.mapMonotonic (f lineSegment -> g lineSegment
forall a b. Coercible a b => a -> b
coerce (f lineSegment -> g lineSegment)
-> (f (Flipped lineSegment) -> f lineSegment)
-> f (Flipped lineSegment)
-> g lineSegment
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Flipped lineSegment -> lineSegment)
-> f (Flipped lineSegment) -> f lineSegment
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (lineSegment -> lineSegment
forall lineSegment point.
(LineSegment_ lineSegment point,
StartPointOf lineSegment ~ EndPointOf lineSegment) =>
lineSegment -> lineSegment
flipSeg (lineSegment -> lineSegment)
-> (Flipped lineSegment -> lineSegment)
-> Flipped lineSegment
-> lineSegment
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting lineSegment (Flipped lineSegment) lineSegment
-> Flipped lineSegment -> lineSegment
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting lineSegment (Flipped lineSegment) lineSegment
forall segment (f :: * -> *).
Functor f =>
(segment -> f segment) -> Flipped segment -> f (Flipped segment)
rawSegment))