{-# LANGUAGE ScopedTypeVariables #-}
--------------------------------------------------------------------------------
-- |
-- Module      :  Algorithms.Geometry.LineSegmentIntersection.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 Algorithms.Geometry.LineSegmentIntersection.BentleyOttmann
  ( intersections
  , interiorIntersections
    -- FIXME: Move ordAt and xCoordAt to Data.Geometry.LineSegment?
  , ordAt
  , xCoordAt
  ) where

import           Algorithms.Geometry.LineSegmentIntersection.Types
import           Control.Lens hiding (contains)
import           Data.Ext
import qualified Data.Foldable as F
import           Data.Geometry.Interval
import           Data.Geometry.LineSegment
import           Data.Geometry.Point
import           Data.Geometry.Properties
import qualified Data.List as L
import           Data.List.NonEmpty (NonEmpty(..))
import qualified Data.List.NonEmpty as NonEmpty
import qualified Data.Map as M
import           Data.Maybe
import           Data.Ord (Down(..), comparing)
import qualified Data.Set as SS -- status struct
import qualified Data.Set.Util as SS -- status struct
import qualified Data.Set as EQ -- event queue
import           Data.Vinyl
import           Data.Vinyl.CoRec

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

-- | Compute all intersections
--
-- \(O((n+k)\log n)\), where \(k\) is the number of intersections.
intersections    :: (Ord r, Fractional r)
                 => [LineSegment 2 p r] -> Intersections p r
intersections :: [LineSegment 2 p r] -> Intersections p r
intersections [LineSegment 2 p r]
ss = [IntersectionPoint p r] -> Intersections p r
forall r p. Ord r => [IntersectionPoint p r] -> Intersections p r
merge ([IntersectionPoint p r] -> Intersections p r)
-> [IntersectionPoint p r] -> Intersections p r
forall a b. (a -> b) -> a -> b
$ EventQueue p r -> StatusStructure p r -> [IntersectionPoint p r]
forall r p.
(Ord r, Fractional r) =>
EventQueue p r -> StatusStructure p r -> [IntersectionPoint p r]
sweep EventQueue p r
pts StatusStructure p r
forall a. Set a
SS.empty
  where
    pts :: EventQueue p r
pts = [Event p r] -> EventQueue p r
forall a. Eq a => [a] -> Set a
EQ.fromAscList ([Event p r] -> EventQueue p r)
-> ([LineSegment 2 p r] -> [Event p r])
-> [LineSegment 2 p r]
-> EventQueue p r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Event p r] -> [Event p r]
forall r p. Eq r => [Event p r] -> [Event p r]
groupStarts ([Event p r] -> [Event p r])
-> ([LineSegment 2 p r] -> [Event p r])
-> [LineSegment 2 p r]
-> [Event p r]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Event p r] -> [Event p r]
forall a. Ord a => [a] -> [a]
L.sort ([Event p r] -> [Event p r])
-> ([LineSegment 2 p r] -> [Event p r])
-> [LineSegment 2 p r]
-> [Event p r]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LineSegment 2 p r -> [Event p r])
-> [LineSegment 2 p r] -> [Event p r]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap LineSegment 2 p r -> [Event p r]
forall r p. Ord r => LineSegment 2 p r -> [Event p r]
asEventPts ([LineSegment 2 p r] -> EventQueue p r)
-> [LineSegment 2 p r] -> EventQueue p r
forall a b. (a -> b) -> a -> b
$ [LineSegment 2 p r]
ss

-- | 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 :: (Ord r, Fractional r)
                       => [LineSegment 2 p r] -> Intersections p r
interiorIntersections :: [LineSegment 2 p r] -> Intersections p r
interiorIntersections = (Associated p r -> Bool) -> Intersections p r -> Intersections p r
forall a k. (a -> Bool) -> Map k a -> Map k a
M.filter (Bool -> Bool
not (Bool -> Bool)
-> (Associated p r -> Bool) -> Associated p r -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Associated p r -> Bool
forall p r. Associated p r -> Bool
isEndPointIntersection) (Intersections p r -> Intersections p r)
-> ([LineSegment 2 p r] -> Intersections p r)
-> [LineSegment 2 p r]
-> Intersections p r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [LineSegment 2 p r] -> Intersections p r
forall r p.
(Ord r, Fractional r) =>
[LineSegment 2 p r] -> Intersections p r
intersections

-- | Computes the event points for a given line segment
asEventPts   :: Ord r => LineSegment 2 p r -> [Event p r]
asEventPts :: LineSegment 2 p r -> [Event p r]
asEventPts LineSegment 2 p r
s = let [Point 2 r
p,Point 2 r
q] = (Point 2 r -> Point 2 r -> Ordering) -> [Point 2 r] -> [Point 2 r]
forall a. (a -> a -> Ordering) -> [a] -> [a]
L.sortBy Point 2 r -> Point 2 r -> Ordering
forall r. Ord r => Point 2 r -> Point 2 r -> Ordering
ordPoints [LineSegment 2 p r
sLineSegment 2 p r
-> Getting (Point 2 r) (LineSegment 2 p r) (Point 2 r) -> Point 2 r
forall s a. s -> Getting a s a -> a
^.((Point 2 r :+ p) -> Const (Point 2 r) (Point 2 r :+ p))
-> LineSegment 2 p r -> Const (Point 2 r) (LineSegment 2 p r)
forall t. HasStart t => Lens' t (StartCore t :+ StartExtra t)
start(((Point 2 r :+ p) -> Const (Point 2 r) (Point 2 r :+ p))
 -> LineSegment 2 p r -> Const (Point 2 r) (LineSegment 2 p r))
-> ((Point 2 r -> Const (Point 2 r) (Point 2 r))
    -> (Point 2 r :+ p) -> Const (Point 2 r) (Point 2 r :+ p))
-> Getting (Point 2 r) (LineSegment 2 p r) (Point 2 r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Point 2 r -> Const (Point 2 r) (Point 2 r))
-> (Point 2 r :+ p) -> Const (Point 2 r) (Point 2 r :+ p)
forall core extra core'.
Lens (core :+ extra) (core' :+ extra) core core'
core,LineSegment 2 p r
sLineSegment 2 p r
-> Getting (Point 2 r) (LineSegment 2 p r) (Point 2 r) -> Point 2 r
forall s a. s -> Getting a s a -> a
^.((Point 2 r :+ p) -> Const (Point 2 r) (Point 2 r :+ p))
-> LineSegment 2 p r -> Const (Point 2 r) (LineSegment 2 p r)
forall t. HasEnd t => Lens' t (EndCore t :+ EndExtra t)
end(((Point 2 r :+ p) -> Const (Point 2 r) (Point 2 r :+ p))
 -> LineSegment 2 p r -> Const (Point 2 r) (LineSegment 2 p r))
-> ((Point 2 r -> Const (Point 2 r) (Point 2 r))
    -> (Point 2 r :+ p) -> Const (Point 2 r) (Point 2 r :+ p))
-> Getting (Point 2 r) (LineSegment 2 p r) (Point 2 r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Point 2 r -> Const (Point 2 r) (Point 2 r))
-> (Point 2 r :+ p) -> Const (Point 2 r) (Point 2 r :+ p)
forall core extra core'.
Lens (core :+ extra) (core' :+ extra) core core'
core]
               in [Point 2 r -> EventType (LineSegment 2 p r) -> Event p r
forall p r. Point 2 r -> EventType (LineSegment 2 p r) -> Event p r
Event Point 2 r
p (NonEmpty (LineSegment 2 p r) -> EventType (LineSegment 2 p r)
forall s. NonEmpty s -> EventType s
Start (NonEmpty (LineSegment 2 p r) -> EventType (LineSegment 2 p r))
-> NonEmpty (LineSegment 2 p r) -> EventType (LineSegment 2 p r)
forall a b. (a -> b) -> a -> b
$ LineSegment 2 p r
s LineSegment 2 p r
-> [LineSegment 2 p r] -> NonEmpty (LineSegment 2 p r)
forall a. a -> [a] -> NonEmpty a
:| []), Point 2 r -> EventType (LineSegment 2 p r) -> Event p r
forall p r. Point 2 r -> EventType (LineSegment 2 p r) -> Event p r
Event Point 2 r
q (LineSegment 2 p r -> EventType (LineSegment 2 p r)
forall s. s -> EventType s
End LineSegment 2 p r
s)]

-- | Group the segments with the intersection points
merge :: Ord r =>  [IntersectionPoint p r] -> Intersections p r
merge :: [IntersectionPoint p r] -> Intersections p r
merge = (IntersectionPoint p r -> Intersections p r -> Intersections p r)
-> Intersections p r
-> [IntersectionPoint p r]
-> Intersections p r
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\(IntersectionPoint Point 2 r
p Associated p r
a) -> (Associated p r -> Associated p r -> Associated p r)
-> Point 2 r
-> Associated p r
-> Intersections p r
-> Intersections p r
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
M.insertWith Associated p r -> Associated p r -> Associated p r
forall a. Semigroup a => a -> a -> a
(<>) Point 2 r
p Associated p r
a) Intersections p r
forall k a. Map k a
M.empty

-- | Group the startpoints such that segments with the same start point
-- correspond to one event.
groupStarts                          :: Eq r => [Event p r] -> [Event p r]
groupStarts :: [Event p r] -> [Event p r]
groupStarts []                       = []
groupStarts (Event Point 2 r
p (Start NonEmpty (LineSegment 2 p r)
s) : [Event p r]
es) = Point 2 r -> EventType (LineSegment 2 p r) -> Event p r
forall p r. Point 2 r -> EventType (LineSegment 2 p r) -> Event p r
Event Point 2 r
p (NonEmpty (LineSegment 2 p r) -> EventType (LineSegment 2 p r)
forall s. NonEmpty s -> EventType s
Start NonEmpty (LineSegment 2 p r)
ss) Event p r -> [Event p r] -> [Event p r]
forall a. a -> [a] -> [a]
: [Event p r] -> [Event p r]
forall r p. Eq r => [Event p r] -> [Event p r]
groupStarts [Event p r]
rest
  where
    ([Event p r]
ss',[Event p r]
rest) = (Event p r -> Bool) -> [Event p r] -> ([Event p r], [Event p r])
forall a. (a -> Bool) -> [a] -> ([a], [a])
L.span Event p r -> Bool
sameStart [Event p r]
es
    -- sort the segs on lower endpoint
    ss :: NonEmpty (LineSegment 2 p r)
ss         = let (LineSegment 2 p r
x:|[LineSegment 2 p r]
xs) = NonEmpty (LineSegment 2 p r)
s in LineSegment 2 p r
x LineSegment 2 p r
-> [LineSegment 2 p r] -> NonEmpty (LineSegment 2 p r)
forall a. a -> [a] -> NonEmpty a
:| ([LineSegment 2 p r]
xs [LineSegment 2 p r] -> [LineSegment 2 p r] -> [LineSegment 2 p r]
forall a. [a] -> [a] -> [a]
++ (Event p r -> [LineSegment 2 p r])
-> [Event p r] -> [LineSegment 2 p r]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Event p r -> [LineSegment 2 p r]
forall p r. Event p r -> [LineSegment 2 p r]
startSegs [Event p r]
ss')

    sameStart :: Event p r -> Bool
sameStart (Event Point 2 r
q (Start NonEmpty (LineSegment 2 p r)
_)) = Point 2 r
p Point 2 r -> Point 2 r -> Bool
forall a. Eq a => a -> a -> Bool
== Point 2 r
q
    sameStart Event p r
_                   = Bool
False
groupStarts (Event p r
e : [Event p r]
es)                 = Event p r
e Event p r -> [Event p r] -> [Event p r]
forall a. a -> [a] -> [a]
: [Event p r] -> [Event p r]
forall r p. Eq r => [Event p r] -> [Event p r]
groupStarts [Event p r]
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
showList :: [EventType s] -> ShowS
$cshowList :: forall s. Show s => [EventType s] -> ShowS
show :: EventType s -> String
$cshow :: forall s. Show s => EventType s -> String
showsPrec :: Int -> EventType s -> ShowS
$cshowsPrec :: forall s. Show s => Int -> 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 p r = Event { Event p r -> Point 2 r
eventPoint :: !(Point 2 r)
                       , Event p r -> EventType (LineSegment 2 p r)
eventType  :: !(EventType (LineSegment 2 p r))
                       } deriving (Int -> Event p r -> ShowS
[Event p r] -> ShowS
Event p r -> String
(Int -> Event p r -> ShowS)
-> (Event p r -> String)
-> ([Event p r] -> ShowS)
-> Show (Event p r)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall p r. (Show r, Show p) => Int -> Event p r -> ShowS
forall p r. (Show r, Show p) => [Event p r] -> ShowS
forall p r. (Show r, Show p) => Event p r -> String
showList :: [Event p r] -> ShowS
$cshowList :: forall p r. (Show r, Show p) => [Event p r] -> ShowS
show :: Event p r -> String
$cshow :: forall p r. (Show r, Show p) => Event p r -> String
showsPrec :: Int -> Event p r -> ShowS
$cshowsPrec :: forall p r. (Show r, Show p) => Int -> Event p r -> ShowS
Show,Event p r -> Event p r -> Bool
(Event p r -> Event p r -> Bool)
-> (Event p r -> Event p r -> Bool) -> Eq (Event p r)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall p r. Eq r => Event p r -> Event p r -> Bool
/= :: Event p r -> Event p r -> Bool
$c/= :: forall p r. Eq r => Event p r -> Event p r -> Bool
== :: Event p r -> Event p r -> Bool
$c== :: forall p r. Eq r => Event p r -> Event p r -> Bool
Eq)

instance Ord r => Ord (Event p r) where
  -- decreasing on the y-coord, then increasing on x-coord, and increasing on event-type
  (Event Point 2 r
p EventType (LineSegment 2 p r)
s) compare :: Event p r -> Event p r -> Ordering
`compare` (Event Point 2 r
q EventType (LineSegment 2 p r)
t) = case Point 2 r -> Point 2 r -> Ordering
forall r. Ord r => Point 2 r -> Point 2 r -> Ordering
ordPoints Point 2 r
p Point 2 r
q of
                                        Ordering
EQ -> EventType (LineSegment 2 p r)
s EventType (LineSegment 2 p r)
-> EventType (LineSegment 2 p r) -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` EventType (LineSegment 2 p r)
t
                                        Ordering
x  -> Ordering
x

-- | An ordering that is decreasing on y, increasing on x
ordPoints     :: Ord r => Point 2 r -> Point 2 r -> Ordering
ordPoints :: Point 2 r -> Point 2 r -> Ordering
ordPoints Point 2 r
a Point 2 r
b = let f :: point d b -> (Down b, b)
f point d b
p = (b -> Down b
forall a. a -> Down a
Down (b -> Down b) -> b -> Down b
forall a b. (a -> b) -> a -> b
$ point d b
ppoint d b -> Getting b (point d b) b -> b
forall s a. s -> Getting a s a -> a
^.Getting b (point d b) b
forall (d :: Nat) (point :: Nat -> * -> *) r.
(2 <= d, Arity d, AsAPoint point) =>
Lens' (point d r) r
yCoord, point d b
ppoint d b -> Getting b (point d b) b -> b
forall s a. s -> Getting a s a -> a
^.Getting b (point d b) b
forall (d :: Nat) (point :: Nat -> * -> *) r.
(1 <= d, Arity d, AsAPoint point) =>
Lens' (point d r) r
xCoord) in (Point 2 r -> (Down r, r)) -> Point 2 r -> Point 2 r -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing Point 2 r -> (Down r, r)
forall (d :: Nat) (point :: Nat -> * -> *) b.
(ImplicitPeano (Peano d), ArityPeano (Peano (FromPeano (Peano d))),
 KnownNat (FromPeano (Peano d)), KnownNat d, AsAPoint point,
 (1 <=? d) ~ 'True, (2 <=? d) ~ 'True,
 Peano (FromPeano (Peano d) + 1)
 ~ 'S (Peano (FromPeano (Peano d)))) =>
point d b -> (Down b, b)
f Point 2 r
a Point 2 r
b

-- | Get the segments that start at the given event point
startSegs   :: Event p r -> [LineSegment 2 p r]
startSegs :: Event p r -> [LineSegment 2 p r]
startSegs Event p r
e = case Event p r -> EventType (LineSegment 2 p r)
forall p r. Event p r -> EventType (LineSegment 2 p r)
eventType Event p r
e of
                Start NonEmpty (LineSegment 2 p r)
ss -> NonEmpty (LineSegment 2 p r) -> [LineSegment 2 p r]
forall a. NonEmpty a -> [a]
NonEmpty.toList NonEmpty (LineSegment 2 p r)
ss
                EventType (LineSegment 2 p r)
_        -> []

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

-- | Compare based on the x-coordinate of the intersection with the horizontal
-- line through y
ordAt   :: (Fractional r, Ord r) => r -> Compare (LineSegment 2 p r)
ordAt :: r -> Compare (LineSegment 2 p r)
ordAt r
y = (LineSegment 2 p r -> r) -> Compare (LineSegment 2 p r)
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (r -> LineSegment 2 p r -> r
forall r p. (Fractional r, Ord r) => r -> LineSegment 2 p r -> r
xCoordAt r
y)

-- | Given a y coord and a line segment that intersects the horizontal line
-- through y, compute the x-coordinate of this intersection point.
--
-- note that we will pretend that the line segment is closed, even if it is not
xCoordAt             :: (Fractional r, Ord r) => r -> LineSegment 2 p r -> r
xCoordAt :: r -> LineSegment 2 p r -> r
xCoordAt r
y (LineSegment' (Point2 r
px r
py :+ p
_) (Point2 r
qx r
qy :+ p
_))
      | r
py r -> r -> Bool
forall a. Eq a => a -> a -> Bool
== r
qy     = r
px r -> r -> r
forall a. Ord a => a -> a -> a
`max` r
qx  -- s is horizontal, and since it by the
                                    -- precondition it intersects the sweep
                                    -- line, we return the x-coord of the
                                    -- rightmost endpoint.
      | Bool
otherwise    = r
px r -> r -> r
forall a. Num a => a -> a -> a
+ r
alpha r -> r -> r
forall a. Num a => a -> a -> a
* (r
qx r -> r -> r
forall a. Num a => a -> a -> a
- r
px)
  where
    alpha :: r
alpha = (r
y r -> r -> r
forall a. Num a => a -> a -> a
- r
py) r -> r -> r
forall a. Fractional a => a -> a -> a
/ (r
qy r -> r -> r
forall a. Num a => a -> a -> a
- r
py)

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

type EventQueue      p r = EQ.Set (Event p r)
type StatusStructure p r = SS.Set (LineSegment 2 p r)

-- | Run the sweep handling all events
sweep       :: (Ord r, Fractional r)
            => EventQueue p r -> StatusStructure p r -> [IntersectionPoint p r]
sweep :: EventQueue p r -> StatusStructure p r -> [IntersectionPoint p r]
sweep EventQueue p r
eq StatusStructure p r
ss = case EventQueue p r -> Maybe (Event p r, EventQueue p r)
forall a. Set a -> Maybe (a, Set a)
EQ.minView EventQueue p r
eq of
    Maybe (Event p r, EventQueue p r)
Nothing      -> []
    Just (Event p r
e,EventQueue p r
eq') -> Event p r
-> EventQueue p r -> StatusStructure p r -> [IntersectionPoint p r]
forall r p.
(Ord r, Fractional r) =>
Event p r
-> EventQueue p r -> StatusStructure p r -> [IntersectionPoint p r]
handle Event p r
e EventQueue p r
eq' StatusStructure p r
ss

isClosedStart                     :: Eq r => Point 2 r -> LineSegment 2 p r -> Bool
isClosedStart :: Point 2 r -> LineSegment 2 p r -> Bool
isClosedStart Point 2 r
p (LineSegment EndPoint (Point 2 r :+ p)
s EndPoint (Point 2 r :+ p)
e)
  | Point 2 r
p Point 2 r -> Point 2 r -> Bool
forall a. Eq a => a -> a -> Bool
== EndPoint (Point 2 r :+ p)
sEndPoint (Point 2 r :+ p)
-> Getting (Point 2 r) (EndPoint (Point 2 r :+ p)) (Point 2 r)
-> Point 2 r
forall s a. s -> Getting a s a -> a
^.((Point 2 r :+ p) -> Const (Point 2 r) (Point 2 r :+ p))
-> EndPoint (Point 2 r :+ p)
-> Const (Point 2 r) (EndPoint (Point 2 r :+ p))
forall a b. Lens (EndPoint a) (EndPoint b) a b
unEndPoint(((Point 2 r :+ p) -> Const (Point 2 r) (Point 2 r :+ p))
 -> EndPoint (Point 2 r :+ p)
 -> Const (Point 2 r) (EndPoint (Point 2 r :+ p)))
-> ((Point 2 r -> Const (Point 2 r) (Point 2 r))
    -> (Point 2 r :+ p) -> Const (Point 2 r) (Point 2 r :+ p))
-> Getting (Point 2 r) (EndPoint (Point 2 r :+ p)) (Point 2 r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Point 2 r -> Const (Point 2 r) (Point 2 r))
-> (Point 2 r :+ p) -> Const (Point 2 r) (Point 2 r :+ p)
forall core extra core'.
Lens (core :+ extra) (core' :+ extra) core core'
core       = EndPoint (Point 2 r :+ p) -> Bool
forall a. EndPoint a -> Bool
isClosed EndPoint (Point 2 r :+ p)
s
  | Bool
otherwise                     = EndPoint (Point 2 r :+ p) -> Bool
forall a. EndPoint a -> Bool
isClosed EndPoint (Point 2 r :+ p)
e

-- | Handle an event point
handle                           :: forall r p. (Ord r, Fractional r)
                                 => Event p r -> EventQueue p r -> StatusStructure p r
                                 -> [IntersectionPoint p r]
handle :: Event p r
-> EventQueue p r -> StatusStructure p r -> [IntersectionPoint p r]
handle e :: Event p r
e@(Event p r -> Point 2 r
forall p r. Event p r -> Point 2 r
eventPoint -> Point 2 r
p) EventQueue p r
eq StatusStructure p r
ss = [IntersectionPoint p r]
toReport [IntersectionPoint p r]
-> [IntersectionPoint p r] -> [IntersectionPoint p r]
forall a. Semigroup a => a -> a -> a
<> EventQueue p r -> StatusStructure p r -> [IntersectionPoint p r]
forall r p.
(Ord r, Fractional r) =>
EventQueue p r -> StatusStructure p r -> [IntersectionPoint p r]
sweep EventQueue p r
eq' StatusStructure p r
ss'
  where
    starts :: [LineSegment 2 p r]
starts                   = Event p r -> [LineSegment 2 p r]
forall p r. Event p r -> [LineSegment 2 p r]
startSegs Event p r
e
    (StatusStructure p r
before,[LineSegment 2 p r]
contains',StatusStructure p r
after) = Point 2 r
-> StatusStructure p r
-> (StatusStructure p r, [LineSegment 2 p r], StatusStructure p r)
forall r p.
(Fractional r, Ord r) =>
Point 2 r
-> StatusStructure p r
-> (StatusStructure p r, [LineSegment 2 p r], StatusStructure p r)
extractContains Point 2 r
p StatusStructure p r
ss
    ([LineSegment 2 p r]
ends,[LineSegment 2 p r]
contains)          = (LineSegment 2 p r -> Bool)
-> [LineSegment 2 p r]
-> ([LineSegment 2 p r], [LineSegment 2 p r])
forall a. (a -> Bool) -> [a] -> ([a], [a])
L.partition (Point 2 r -> LineSegment 2 p r -> Bool
forall r p. Ord r => Point 2 r -> LineSegment 2 p r -> Bool
endsAt Point 2 r
p) [LineSegment 2 p r]
contains'
    -- starting segments, exluding those that have an open starting point
    starts' :: [LineSegment 2 p r]
starts'  = (LineSegment 2 p r -> Bool)
-> [LineSegment 2 p r] -> [LineSegment 2 p r]
forall a. (a -> Bool) -> [a] -> [a]
filter (Point 2 r -> LineSegment 2 p r -> Bool
forall r p. Eq r => Point 2 r -> LineSegment 2 p r -> Bool
isClosedStart Point 2 r
p) [LineSegment 2 p r]
starts
    toReport :: [IntersectionPoint p r]
toReport = case [LineSegment 2 p r]
starts' [LineSegment 2 p r] -> [LineSegment 2 p r] -> [LineSegment 2 p r]
forall a. [a] -> [a] -> [a]
++ [LineSegment 2 p r]
contains' of
                 (LineSegment 2 p r
_:LineSegment 2 p r
_:[LineSegment 2 p r]
_) -> [Point 2 r -> Associated p r -> IntersectionPoint p r
forall p r. Point 2 r -> Associated p r -> IntersectionPoint p r
IntersectionPoint Point 2 r
p (Associated p r -> IntersectionPoint p r)
-> Associated p r -> IntersectionPoint p r
forall a b. (a -> b) -> a -> b
$ [LineSegment 2 p r] -> [LineSegment 2 p r] -> Associated p r
forall r p.
Ord r =>
[LineSegment 2 p r] -> [LineSegment 2 p r] -> Associated p r
associated ([LineSegment 2 p r]
starts' [LineSegment 2 p r] -> [LineSegment 2 p r] -> [LineSegment 2 p r]
forall a. Semigroup a => a -> a -> a
<> [LineSegment 2 p r]
ends) [LineSegment 2 p r]
contains]
                 [LineSegment 2 p r]
_       -> []

    -- new status structure
    ss' :: StatusStructure p r
ss' = StatusStructure p r
before StatusStructure p r -> StatusStructure p r -> StatusStructure p r
forall a. Set a -> Set a -> Set a
`SS.join` StatusStructure p r
newSegs StatusStructure p r -> StatusStructure p r -> StatusStructure p r
forall a. Set a -> Set a -> Set a
`SS.join` StatusStructure p r
after
    newSegs :: StatusStructure p r
newSegs = Point 2 r -> [LineSegment 2 p r] -> StatusStructure p r
forall r p.
(Fractional r, Ord r) =>
Point 2 r -> [LineSegment 2 p r] -> StatusStructure p r
toStatusStruct Point 2 r
p ([LineSegment 2 p r] -> StatusStructure p r)
-> [LineSegment 2 p r] -> StatusStructure p r
forall a b. (a -> b) -> a -> b
$ [LineSegment 2 p r]
starts [LineSegment 2 p r] -> [LineSegment 2 p r] -> [LineSegment 2 p r]
forall a. [a] -> [a] -> [a]
++ [LineSegment 2 p r]
contains

    -- the new eeventqueue
    eq' :: EventQueue p r
eq' = (Event p r -> EventQueue p r -> EventQueue p r)
-> EventQueue p r -> [Event p r] -> EventQueue p r
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Event p r -> EventQueue p r -> EventQueue p r
forall a. Ord a => a -> Set a -> Set a
EQ.insert EventQueue p r
eq [Event p r]
es
    -- the new events:
    es :: [Event p r]
es | StatusStructure p r -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
F.null StatusStructure p r
newSegs  = Maybe (Event p r) -> [Event p r]
forall a. Maybe a -> [a]
maybeToList (Maybe (Event p r) -> [Event p r])
-> Maybe (Event p r) -> [Event p r]
forall a b. (a -> b) -> a -> b
$ (LineSegment 2 p r -> LineSegment 2 p r -> Maybe (Event p r))
-> Maybe (LineSegment 2 p r)
-> Maybe (LineSegment 2 p r)
-> Maybe (Event p r)
forall (m :: * -> *) t t b.
Monad m =>
(t -> t -> m b) -> m t -> m t -> m b
app (Point 2 r
-> LineSegment 2 p r -> LineSegment 2 p r -> Maybe (Event p r)
forall r p.
(Ord r, Fractional r) =>
Point 2 r
-> LineSegment 2 p r -> LineSegment 2 p r -> Maybe (Event p r)
findNewEvent Point 2 r
p) Maybe (LineSegment 2 p r)
sl Maybe (LineSegment 2 p r)
sr
       | Bool
otherwise       = let s' :: Maybe (LineSegment 2 p r)
s'  = StatusStructure p r -> Maybe (LineSegment 2 p r)
forall a. Set a -> Maybe a
SS.lookupMin StatusStructure p r
newSegs
                               s'' :: Maybe (LineSegment 2 p r)
s'' = StatusStructure p r -> Maybe (LineSegment 2 p r)
forall a. Set a -> Maybe a
SS.lookupMax StatusStructure p r
newSegs
                           in [Maybe (Event p r)] -> [Event p r]
forall a. [Maybe a] -> [a]
catMaybes [ (LineSegment 2 p r -> LineSegment 2 p r -> Maybe (Event p r))
-> Maybe (LineSegment 2 p r)
-> Maybe (LineSegment 2 p r)
-> Maybe (Event p r)
forall (m :: * -> *) t t b.
Monad m =>
(t -> t -> m b) -> m t -> m t -> m b
app (Point 2 r
-> LineSegment 2 p r -> LineSegment 2 p r -> Maybe (Event p r)
forall r p.
(Ord r, Fractional r) =>
Point 2 r
-> LineSegment 2 p r -> LineSegment 2 p r -> Maybe (Event p r)
findNewEvent Point 2 r
p) Maybe (LineSegment 2 p r)
sl  Maybe (LineSegment 2 p r)
s'
                                        , (LineSegment 2 p r -> LineSegment 2 p r -> Maybe (Event p r))
-> Maybe (LineSegment 2 p r)
-> Maybe (LineSegment 2 p r)
-> Maybe (Event p r)
forall (m :: * -> *) t t b.
Monad m =>
(t -> t -> m b) -> m t -> m t -> m b
app (Point 2 r
-> LineSegment 2 p r -> LineSegment 2 p r -> Maybe (Event p r)
forall r p.
(Ord r, Fractional r) =>
Point 2 r
-> LineSegment 2 p r -> LineSegment 2 p r -> Maybe (Event p r)
findNewEvent Point 2 r
p) Maybe (LineSegment 2 p r)
s'' Maybe (LineSegment 2 p r)
sr
                                        ]
    sl :: Maybe (LineSegment 2 p r)
sl = StatusStructure p r -> Maybe (LineSegment 2 p r)
forall a. Set a -> Maybe a
SS.lookupMax StatusStructure p r
before
    sr :: Maybe (LineSegment 2 p r)
sr = StatusStructure p r -> Maybe (LineSegment 2 p r)
forall a. Set a -> Maybe a
SS.lookupMin StatusStructure p r
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'}

-- | split the status structure, extracting the segments that contain p.
-- the result is (before,contains,after)
extractContains      :: (Fractional r, Ord r)
                     => Point 2 r -> StatusStructure p r
                     -> (StatusStructure p r, [LineSegment 2 p r], StatusStructure p r)
extractContains :: Point 2 r
-> StatusStructure p r
-> (StatusStructure p r, [LineSegment 2 p r], StatusStructure p r)
extractContains Point 2 r
p StatusStructure p r
ss = (StatusStructure p r
before, StatusStructure p r -> [LineSegment 2 p r]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList StatusStructure p r
mid1 [LineSegment 2 p r] -> [LineSegment 2 p r] -> [LineSegment 2 p r]
forall a. Semigroup a => a -> a -> a
<> StatusStructure p r -> [LineSegment 2 p r]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList StatusStructure p r
mid2, StatusStructure p r
after)
  where
    (StatusStructure p r
before, StatusStructure p r
mid1, StatusStructure p r
after') = (LineSegment 2 p r -> r)
-> r
-> StatusStructure p r
-> (StatusStructure p r, StatusStructure p r, StatusStructure p r)
forall b a.
Ord b =>
(a -> b) -> b -> Set a -> (Set a, Set a, Set a)
SS.splitOn (r -> LineSegment 2 p r -> r
forall r p. (Fractional r, Ord r) => r -> LineSegment 2 p r -> r
xCoordAt (r -> LineSegment 2 p r -> r) -> r -> LineSegment 2 p r -> 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 :: Nat -> * -> *) r.
(2 <= d, Arity d, AsAPoint point) =>
Lens' (point d 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 :: Nat -> * -> *) r.
(1 <= d, Arity d, AsAPoint point) =>
Lens' (point d r) r
xCoord) StatusStructure p r
ss
    -- Make sure to also select the horizontal segments containing p
    (StatusStructure p r
mid2, StatusStructure p r
after) = (LineSegment 2 p r -> Bool)
-> StatusStructure p r
-> (StatusStructure p r, StatusStructure p r)
forall a. (a -> Bool) -> Set a -> (Set a, Set a)
SS.spanAntitone (Point 2 r -> LineSegment 2 p r -> Bool
forall g h. IsIntersectableWith g h => g -> h -> Bool
intersects Point 2 r
p) StatusStructure p r
after'


-- | Given a point and the linesegements that contain it. Create a piece of
-- status structure for it.
toStatusStruct      :: (Fractional r, Ord r)
                    => Point 2 r -> [LineSegment 2 p r] -> StatusStructure p r
toStatusStruct :: Point 2 r -> [LineSegment 2 p r] -> StatusStructure p r
toStatusStruct Point 2 r
p [LineSegment 2 p r]
xs = StatusStructure p r
ss StatusStructure p r -> StatusStructure p r -> StatusStructure p r
forall a. Set a -> Set a -> Set a
`SS.join` StatusStructure p r
hors
  -- ss { SS.nav = ordAtNav $ p^.yCoord } `SS.join` hors
  where
    ([LineSegment 2 p r]
hors',[LineSegment 2 p r]
rest) = (LineSegment 2 p r -> Bool)
-> [LineSegment 2 p r]
-> ([LineSegment 2 p r], [LineSegment 2 p r])
forall a. (a -> Bool) -> [a] -> ([a], [a])
L.partition LineSegment 2 p r -> Bool
forall (d :: Nat) (d :: Nat) s a (point :: Nat -> * -> *)
       (point :: Nat -> * -> *).
(ImplicitPeano (Peano d), ImplicitPeano (Peano d), HasEnd s, Eq a,
 HasStart s, ArityPeano (Peano (FromPeano (Peano d))),
 ArityPeano (Peano (FromPeano (Peano d))), KnownNat d,
 KnownNat (FromPeano (Peano d)), KnownNat (FromPeano (Peano d)),
 KnownNat d, AsAPoint point, AsAPoint point, (2 <=? d) ~ 'True,
 (2 <=? d) ~ 'True,
 Peano (FromPeano (Peano d) + 1) ~ 'S (Peano (FromPeano (Peano d))),
 EndCore s ~ point d a, StartCore s ~ point d a,
 Peano (FromPeano (Peano d) + 1)
 ~ 'S (Peano (FromPeano (Peano d)))) =>
s -> Bool
isHorizontal [LineSegment 2 p r]
xs
    ss :: StatusStructure p r
ss           = (LineSegment 2 p r -> LineSegment 2 p r -> Ordering)
-> [LineSegment 2 p r] -> StatusStructure p r
forall a. (a -> a -> Ordering) -> [a] -> Set a
SS.fromListBy (r -> LineSegment 2 p r -> LineSegment 2 p r -> Ordering
forall r p.
(Fractional r, Ord r) =>
r -> Compare (LineSegment 2 p r)
ordAt (r -> LineSegment 2 p r -> LineSegment 2 p r -> Ordering)
-> r -> LineSegment 2 p r -> LineSegment 2 p r -> Ordering
forall a b. (a -> b) -> a -> b
$ [LineSegment 2 p r] -> r
maxY [LineSegment 2 p r]
xs) [LineSegment 2 p r]
rest
    hors :: StatusStructure p r
hors         = (LineSegment 2 p r -> LineSegment 2 p r -> Ordering)
-> [LineSegment 2 p r] -> StatusStructure p r
forall a. (a -> a -> Ordering) -> [a] -> Set a
SS.fromListBy ((LineSegment 2 p r -> r)
-> LineSegment 2 p r -> LineSegment 2 p r -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing LineSegment 2 p r -> r
forall r p. Ord r => LineSegment 2 p r -> r
rightEndpoint) [LineSegment 2 p r]
hors'

    isHorizontal :: s -> Bool
isHorizontal s
s  = s
ss -> Getting a s a -> a
forall s a. s -> Getting a s a -> a
^.((point d a :+ StartExtra s)
 -> Const a (point d a :+ StartExtra s))
-> s -> Const a s
forall t. HasStart t => Lens' t (StartCore t :+ StartExtra t)
start(((point d a :+ StartExtra s)
  -> Const a (point d a :+ StartExtra s))
 -> s -> Const a s)
-> ((a -> Const a a)
    -> (point d a :+ StartExtra s)
    -> Const a (point d a :+ StartExtra s))
-> Getting a s a
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(point d a -> Const a (point d a))
-> (point d a :+ StartExtra s)
-> Const a (point d a :+ StartExtra s)
forall core extra core'.
Lens (core :+ extra) (core' :+ extra) core core'
core((point d a -> Const a (point d a))
 -> (point d a :+ StartExtra s)
 -> Const a (point d a :+ StartExtra s))
-> ((a -> Const a a) -> point d a -> Const a (point d a))
-> (a -> Const a a)
-> (point d a :+ StartExtra s)
-> Const a (point d a :+ StartExtra s)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(a -> Const a a) -> point d a -> Const a (point d a)
forall (d :: Nat) (point :: Nat -> * -> *) r.
(2 <= d, Arity d, AsAPoint point) =>
Lens' (point d r) r
yCoord a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== s
ss -> Getting a s a -> a
forall s a. s -> Getting a s a -> a
^.((point d a :+ EndExtra s) -> Const a (point d a :+ EndExtra s))
-> s -> Const a s
forall t. HasEnd t => Lens' t (EndCore t :+ EndExtra t)
end(((point d a :+ EndExtra s) -> Const a (point d a :+ EndExtra s))
 -> s -> Const a s)
-> ((a -> Const a a)
    -> (point d a :+ EndExtra s) -> Const a (point d a :+ EndExtra s))
-> Getting a s a
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(point d a -> Const a (point d a))
-> (point d a :+ EndExtra s) -> Const a (point d a :+ EndExtra s)
forall core extra core'.
Lens (core :+ extra) (core' :+ extra) core core'
core((point d a -> Const a (point d a))
 -> (point d a :+ EndExtra s) -> Const a (point d a :+ EndExtra s))
-> ((a -> Const a a) -> point d a -> Const a (point d a))
-> (a -> Const a a)
-> (point d a :+ EndExtra s)
-> Const a (point d a :+ EndExtra s)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(a -> Const a a) -> point d a -> Const a (point d a)
forall (d :: Nat) (point :: Nat -> * -> *) r.
(2 <= d, Arity d, AsAPoint point) =>
Lens' (point d r) r
yCoord

    -- find the y coord of the first interesting thing below the sweep at y
    maxY :: [LineSegment 2 p r] -> r
maxY = [r] -> r
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ([r] -> r)
-> ([LineSegment 2 p r] -> [r]) -> [LineSegment 2 p r] -> r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (r -> Bool) -> [r] -> [r]
forall a. (a -> Bool) -> [a] -> [a]
filter (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 :: Nat -> * -> *) r.
(2 <= d, Arity d, AsAPoint point) =>
Lens' (point d r) r
yCoord)
         ([r] -> [r])
-> ([LineSegment 2 p r] -> [r]) -> [LineSegment 2 p r] -> [r]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LineSegment 2 p r -> [r]) -> [LineSegment 2 p r] -> [r]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\LineSegment 2 p r
s -> [LineSegment 2 p r
sLineSegment 2 p r -> Getting r (LineSegment 2 p r) r -> r
forall s a. s -> Getting a s a -> a
^.((Point 2 r :+ p) -> Const r (Point 2 r :+ p))
-> LineSegment 2 p r -> Const r (LineSegment 2 p r)
forall t. HasStart t => Lens' t (StartCore t :+ StartExtra t)
start(((Point 2 r :+ p) -> Const r (Point 2 r :+ p))
 -> LineSegment 2 p r -> Const r (LineSegment 2 p r))
-> ((r -> Const r r)
    -> (Point 2 r :+ p) -> Const r (Point 2 r :+ p))
-> Getting r (LineSegment 2 p r) r
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Point 2 r -> Const r (Point 2 r))
-> (Point 2 r :+ p) -> Const r (Point 2 r :+ p)
forall core extra core'.
Lens (core :+ extra) (core' :+ extra) core core'
core((Point 2 r -> Const r (Point 2 r))
 -> (Point 2 r :+ p) -> Const r (Point 2 r :+ p))
-> Getting r (Point 2 r) r
-> (r -> Const r r)
-> (Point 2 r :+ p)
-> Const r (Point 2 r :+ p)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Getting r (Point 2 r) r
forall (d :: Nat) (point :: Nat -> * -> *) r.
(2 <= d, Arity d, AsAPoint point) =>
Lens' (point d r) r
yCoord,LineSegment 2 p r
sLineSegment 2 p r -> Getting r (LineSegment 2 p r) r -> r
forall s a. s -> Getting a s a -> a
^.((Point 2 r :+ p) -> Const r (Point 2 r :+ p))
-> LineSegment 2 p r -> Const r (LineSegment 2 p r)
forall t. HasEnd t => Lens' t (EndCore t :+ EndExtra t)
end(((Point 2 r :+ p) -> Const r (Point 2 r :+ p))
 -> LineSegment 2 p r -> Const r (LineSegment 2 p r))
-> ((r -> Const r r)
    -> (Point 2 r :+ p) -> Const r (Point 2 r :+ p))
-> Getting r (LineSegment 2 p r) r
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Point 2 r -> Const r (Point 2 r))
-> (Point 2 r :+ p) -> Const r (Point 2 r :+ p)
forall core extra core'.
Lens (core :+ extra) (core' :+ extra) core core'
core((Point 2 r -> Const r (Point 2 r))
 -> (Point 2 r :+ p) -> Const r (Point 2 r :+ p))
-> Getting r (Point 2 r) r
-> (r -> Const r r)
-> (Point 2 r :+ p)
-> Const r (Point 2 r :+ p)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Getting r (Point 2 r) r
forall (d :: Nat) (point :: Nat -> * -> *) r.
(2 <= d, Arity d, AsAPoint point) =>
Lens' (point d r) r
yCoord])

-- | Get the right endpoint of a segment
rightEndpoint   :: Ord r => LineSegment 2 p r -> r
rightEndpoint :: LineSegment 2 p r -> r
rightEndpoint LineSegment 2 p r
s = (LineSegment 2 p r
sLineSegment 2 p r -> Getting r (LineSegment 2 p r) r -> r
forall s a. s -> Getting a s a -> a
^.((Point 2 r :+ p) -> Const r (Point 2 r :+ p))
-> LineSegment 2 p r -> Const r (LineSegment 2 p r)
forall t. HasStart t => Lens' t (StartCore t :+ StartExtra t)
start(((Point 2 r :+ p) -> Const r (Point 2 r :+ p))
 -> LineSegment 2 p r -> Const r (LineSegment 2 p r))
-> ((r -> Const r r)
    -> (Point 2 r :+ p) -> Const r (Point 2 r :+ p))
-> Getting r (LineSegment 2 p r) r
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Point 2 r -> Const r (Point 2 r))
-> (Point 2 r :+ p) -> Const r (Point 2 r :+ p)
forall core extra core'.
Lens (core :+ extra) (core' :+ extra) core core'
core((Point 2 r -> Const r (Point 2 r))
 -> (Point 2 r :+ p) -> Const r (Point 2 r :+ p))
-> ((r -> Const r r) -> Point 2 r -> Const r (Point 2 r))
-> (r -> Const r r)
-> (Point 2 r :+ p)
-> Const r (Point 2 r :+ p)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(r -> Const r r) -> Point 2 r -> Const r (Point 2 r)
forall (d :: Nat) (point :: Nat -> * -> *) r.
(1 <= d, Arity d, AsAPoint point) =>
Lens' (point d r) r
xCoord) r -> r -> r
forall a. Ord a => a -> a -> a
`max` (LineSegment 2 p r
sLineSegment 2 p r -> Getting r (LineSegment 2 p r) r -> r
forall s a. s -> Getting a s a -> a
^.((Point 2 r :+ p) -> Const r (Point 2 r :+ p))
-> LineSegment 2 p r -> Const r (LineSegment 2 p r)
forall t. HasEnd t => Lens' t (EndCore t :+ EndExtra t)
end(((Point 2 r :+ p) -> Const r (Point 2 r :+ p))
 -> LineSegment 2 p r -> Const r (LineSegment 2 p r))
-> ((r -> Const r r)
    -> (Point 2 r :+ p) -> Const r (Point 2 r :+ p))
-> Getting r (LineSegment 2 p r) r
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Point 2 r -> Const r (Point 2 r))
-> (Point 2 r :+ p) -> Const r (Point 2 r :+ p)
forall core extra core'.
Lens (core :+ extra) (core' :+ extra) core core'
core((Point 2 r -> Const r (Point 2 r))
 -> (Point 2 r :+ p) -> Const r (Point 2 r :+ p))
-> ((r -> Const r r) -> Point 2 r -> Const r (Point 2 r))
-> (r -> Const r r)
-> (Point 2 r :+ p)
-> Const r (Point 2 r :+ p)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(r -> Const r r) -> Point 2 r -> Const r (Point 2 r)
forall (d :: Nat) (point :: Nat -> * -> *) r.
(1 <= d, Arity d, AsAPoint point) =>
Lens' (point d r) r
xCoord)

-- | Test if a segment ends at p
endsAt                      :: Ord r => Point 2 r -> LineSegment 2 p r -> Bool
endsAt :: Point 2 r -> LineSegment 2 p r -> Bool
endsAt Point 2 r
p (LineSegment' Point 2 r :+ p
a Point 2 r :+ p
b) = ((Point 2 r :+ p) -> Bool) -> [Point 2 r :+ p] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\Point 2 r :+ p
q -> Point 2 r -> Point 2 r -> Ordering
forall r. Ord r => Point 2 r -> Point 2 r -> Ordering
ordPoints (Point 2 r :+ p
q(Point 2 r :+ p)
-> Getting (Point 2 r) (Point 2 r :+ p) (Point 2 r) -> Point 2 r
forall s a. s -> Getting a s a -> a
^.Getting (Point 2 r) (Point 2 r :+ p) (Point 2 r)
forall core extra core'.
Lens (core :+ extra) (core' :+ extra) core core'
core) Point 2 r
p Ordering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
/= Ordering
GT) [Point 2 r :+ p
a,Point 2 r :+ p
b]

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

-- | Find all events
findNewEvent       :: (Ord r, Fractional r)
                   => Point 2 r -> LineSegment 2 p r -> LineSegment 2 p r
                   -> Maybe (Event p r)
findNewEvent :: Point 2 r
-> LineSegment 2 p r -> LineSegment 2 p r -> Maybe (Event p r)
findNewEvent Point 2 r
p LineSegment 2 p r
l LineSegment 2 p r
r = CoRec Identity '[NoIntersection, Point 2 r, LineSegment 2 p r]
-> Handlers
     '[NoIntersection, Point 2 r, LineSegment 2 p r] (Maybe (Event p r))
-> Maybe (Event p r)
forall (ts :: [*]) b. CoRec Identity ts -> Handlers ts b -> b
match (LineSegment 2 p r
l LineSegment 2 p r
-> LineSegment 2 p r
-> Intersection (LineSegment 2 p r) (LineSegment 2 p r)
forall g h. IsIntersectableWith g h => g -> h -> Intersection g h
`intersect` LineSegment 2 p r
r) (Handlers
   '[NoIntersection, Point 2 r, LineSegment 2 p r] (Maybe (Event p r))
 -> Maybe (Event p r))
-> Handlers
     '[NoIntersection, Point 2 r, LineSegment 2 p r] (Maybe (Event p r))
-> Maybe (Event p r)
forall a b. (a -> b) -> a -> b
$
     (NoIntersection -> Maybe (Event p r))
-> Handler (Maybe (Event p r)) NoIntersection
forall b a. (a -> b) -> Handler b a
H (Maybe (Event p r) -> NoIntersection -> Maybe (Event p r)
forall a b. a -> b -> a
const Maybe (Event p r)
forall a. Maybe a
Nothing) -- NoIntersection
  Handler (Maybe (Event p r)) NoIntersection
-> Rec
     (Handler (Maybe (Event p r))) '[Point 2 r, LineSegment 2 p r]
-> Handlers
     '[NoIntersection, Point 2 r, LineSegment 2 p r] (Maybe (Event p r))
forall u (a :: u -> *) (r :: u) (rs :: [u]).
a r -> Rec a rs -> Rec a (r : rs)
:& (Point 2 r -> Maybe (Event p r))
-> Handler (Maybe (Event p r)) (Point 2 r)
forall b a. (a -> b) -> Handler b a
H (\Point 2 r
q -> if Point 2 r -> Point 2 r -> Ordering
forall r. Ord r => Point 2 r -> Point 2 r -> Ordering
ordPoints Point 2 r
q Point 2 r
p Ordering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
== Ordering
GT then Event p r -> Maybe (Event p r)
forall a. a -> Maybe a
Just (Point 2 r -> EventType (LineSegment 2 p r) -> Event p r
forall p r. Point 2 r -> EventType (LineSegment 2 p r) -> Event p r
Event Point 2 r
q EventType (LineSegment 2 p r)
forall s. EventType s
Intersection)
                                     else Maybe (Event p r)
forall a. Maybe a
Nothing)
  Handler (Maybe (Event p r)) (Point 2 r)
-> Rec (Handler (Maybe (Event p r))) '[LineSegment 2 p r]
-> Rec
     (Handler (Maybe (Event p r))) '[Point 2 r, LineSegment 2 p r]
forall u (a :: u -> *) (r :: u) (rs :: [u]).
a r -> Rec a rs -> Rec a (r : rs)
:& (LineSegment 2 p r -> Maybe (Event p r))
-> Handler (Maybe (Event p r)) (LineSegment 2 p r)
forall b a. (a -> b) -> Handler b a
H (Maybe (Event p r) -> LineSegment 2 p r -> Maybe (Event p r)
forall a b. a -> b -> a
const Maybe (Event p r)
forall a. Maybe a
Nothing) -- full segment intersectsions are handled
                       -- at insertion time
  Handler (Maybe (Event p r)) (LineSegment 2 p r)
-> Rec (Handler (Maybe (Event p r))) '[]
-> Rec (Handler (Maybe (Event p r))) '[LineSegment 2 p r]
forall u (a :: u -> *) (r :: u) (rs :: [u]).
a r -> Rec a rs -> Rec a (r : rs)
:& Rec (Handler (Maybe (Event p r))) '[]
forall u (a :: u -> *). Rec a '[]
RNil