{-# LANGUAGE UndecidableInstances #-}
--------------------------------------------------------------------------------
-- |
-- Module      :  HGeometry.LineSegment.Intersection.BentleyOttmann
-- Copyright   :  (C) Frank Staals
-- License     :  see the LICENSE file
-- Maintainer  :  Frank Staals
--
-- The \(O((n+k)\log n)\) time line segment intersection algorithm by Bentley
-- and Ottmann.
--
--------------------------------------------------------------------------------
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 -- event queue
import qualified Data.Set as SS -- status struct
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.Interval.EndPoint
import           HGeometry.LineSegment
import           HGeometry.LineSegment.Intersection.Types
import           HGeometry.Point
import           HGeometry.Properties (NumType, Dimension)
import qualified HGeometry.Set.Util as SS -- status struct

-- import           Debug.Trace

--------------------------------------------------------------------------------

-- | Compute all intersections
--
-- \(O((n+k)\log n)\), where \(k\) is the number of intersections.
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
  -- where
  --   intersections'' :: f (Flipped lineSegment) -> Intersections r (Flipped lineSegment)
  --   intersections'' = intersections'


-- intersections segs = fmap unflipSegs . merge $ sweep pts SS.empty
--   where
--     pts = EQ.fromAscList . groupStarts . sort . foldMap (asEventPts . tagFlipped) $ segs


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


-- | Computes all intersection points p s.t. p lies in the interior of at least
-- one of the segments.
--
--  \(O((n+k)\log n)\), where \(k\) is the number of intersections.
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

--------------------------------------------------------------------------------

-- | Computes the event points for a given line segment
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)
               ]

-- | Group the segments with the intersection points
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

-- | Group the startpoints such that segments with the same start point
-- correspond to one event.
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
    -- FIXME: this seems to keep the segments on decreasing y, increasing x. shouldn't we
    -- sort them cyclically around p instead?
    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 type for Events

-- | Type of segment
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

-- | The actual event consists of a point and its type
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
  -- decreasing on the y-coord, then increasing on x-coord, and increasing on event-type
  (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

-- | Get the segments that start at the given event point
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
_        -> []

--------------------------------------------------------------------------------
-- * The Main Sweep

type EventQueue      r lineSegment = EQ.Set (Event r lineSegment)
type StatusStructure r lineSegment = SS.Set lineSegment

-- | Run the sweep handling all events
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 an event point
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'
    -- starting segments, exluding those that have an open starting point
    -- starts' = filter (isClosedStart p) starts
    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

    -- If we just inserted open-ended segments that start here, then
    -- don't consider them to be "contained" segments.
    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

    -- any (closed) ending segments at this event point.
    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]
_       -> []

    -- new status structure
    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

    -- the new eeventqueue
    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
    -- the new events:
    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'}

-- | Given the starting point p, and the segments that either start in
-- p, or continue in p, in left to right order along a line just
-- epsilon below p, figure out which segments we should report as
-- intersecting at p.
--
-- in partcular; those that:
-- - have a closed endpoint at p
-- - those that have an open endpoint at p and have an intersection
--   with a segment eps below p. Those segments thus overlap wtih
--   their predecessor or successor in the cyclic order.
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

-- | split the status structure, extracting the segments that contain p.
-- the result is (before,contains,after)
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)
extractContains :: 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 = (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
    -- Make sure to also select the horizontal segments containing p
    (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'

-- | Given a point and the linesegements that contain it. Create a piece of
-- status structure for it.
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
  -- ss { SS.nav = ordAtNav $ p^.yCoord } `SS.join` 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

    -- ordAtY' q sa sb = ordAtY q sa sb

    -- find the y coord of the first interesting thing below the sweep at y
    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
                        ]
    -- fixme, why can't segs be empty

-- | Get the right endpoint of a segment
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)

-- | Test if a segment ends at p
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
  -- all (\q -> ordPoints (q^.core) p /= GT) [a,b]

--------------------------------------------------------------------------------
-- * Finding New events

-- | Find all events
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
    -- full segment intersectsions are handled at insertion time

-- type R = Rational

-- seg1, seg2 :: LineSegment 2 () R
-- seg1 = ClosedLineSegment (ext $ Point2 0 0) (ext $ Point2 0 10)
-- seg2 = ClosedLineSegment (ext $ Point2 0 1) (ext $ Point2 0 5)


--------------------------------------------------------------------------------
-- *

-- | Given a predicate p on elements, and a predicate q on
-- (neighbouring) pairs of elements, filter the elements that satisfy
-- p, or together with one of their neighbours satisfy q.
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))

-- | Given a predicate, test and a list, annotate each element whether
-- it, together with one of its neighbors satisifies the predicate.
overlapsWithNeighbour   :: (a -> a -> Bool) -> [a] -> [(a,Bool)]
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

--------------------------------------------------------------------------------

--------------------------------------------------------------------------------
-- * Flipping and unflipping

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)

-- | Access the underlying segment
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
    -- TODO: maybe we should actually unflip segments a and b rather than use rawSegment


-- type instance Intersection (geom :+ Flipped) (geom :+ Flipped) =
--   Maybe (LineSegmentLineSegmentIntersection (geom :+ Flipped))

-- instance IsIntersectableWith geomA geomB
--          => IsIntersectableWith (geomA :+ extra) (geomB :+ extra) where
--   ga `intersect` gb = (ga^.core) `intersect` (gb^.core)



-- | Make sure the 'start' endpoint occurs before the end-endpoints in
-- terms of the sweep order.
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

-- | Flips the segment
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)

--------------------------------------------------------------------------------

-- | test if the segment is flipped or not.
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)

-- | Unflips the segments in an associated.
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

    -- | For segments that are not acutally flipped, we can just drop the flipped bit
    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)

-- | For flipped segs we unflip them (and appropriately coerce the so that they remain in
-- the same order. I.e. if they were sorted around the start point they are now sorted
-- around the endpoint.
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))