{-# LANGUAGE ScopedTypeVariables #-}
--------------------------------------------------------------------------------
-- |
-- Module      :  Algorithms.Geometry.LineSegmentIntersection.BooleanSweep
-- Copyright   :  (C) Frank Staals, David Himmelstrup
-- License     :  see the LICENSE file
-- Maintainer  :  David Himmelstrup
--
-- \( O(n \log n) \) algorithm for determining if any two sets of line segments intersect.
--
-- Shamos and Hoey.
--
--------------------------------------------------------------------------------
module Algorithms.Geometry.LineSegmentIntersection.BooleanSweep
  ( hasIntersections
  ) where

import           Control.Lens hiding (contains)
import           Data.Ext
import           Data.Geometry.Interval
import           Data.Geometry.LineSegment
import           Data.Geometry.Point

import           Data.Intersection
import qualified Data.List as L
import           Data.Maybe
import           Data.Ord (Down (..), comparing)
import qualified Data.Set as SS
import qualified Data.Set.Util as SS

-- import           Data.RealNumber.Rational
import Debug.Trace
import Data.Geometry.Polygon

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

-- | Tests if there are any intersections.
--
-- \(O(n\log n)\)
hasIntersections    :: (Ord r, Num r)
                 => [LineSegment 2 p r :+ e] -> Bool
hasIntersections :: [LineSegment 2 p r :+ e] -> Bool
hasIntersections [LineSegment 2 p r :+ e]
ss = [Event p r] -> StatusStructure p r -> Bool
forall r p.
(Ord r, Num r) =>
[Event p r] -> StatusStructure p r -> Bool
sweep [Event p r]
pts StatusStructure p r
forall a. Set a
SS.empty
  where
    pts :: [Event p r]
pts = (Event p r -> Event p r -> Ordering) -> [Event p r] -> [Event p r]
forall a. (a -> a -> Ordering) -> [a] -> [a]
L.sortBy Event p r -> Event p r -> Ordering
forall r p. (Num r, Ord r) => Event p r -> Event p r -> Ordering
ordEvents ([Event p r] -> [Event p r])
-> ([LineSegment 2 p r :+ e] -> [Event p r])
-> [LineSegment 2 p r :+ e]
-> [Event p r]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((LineSegment 2 p r :+ e) -> [Event p r])
-> [LineSegment 2 p r :+ e] -> [Event p r]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (LineSegment 2 p r :+ e) -> [Event p r]
forall r p e. Ord r => (LineSegment 2 p r :+ e) -> [Event p r]
asEventPts ([LineSegment 2 p r :+ e] -> [Event p r])
-> [LineSegment 2 p r :+ e] -> [Event p r]
forall a b. (a -> b) -> a -> b
$ [LineSegment 2 p r :+ e]
ss

-- | Computes the event points for a given line segment
asEventPts          :: Ord r => LineSegment 2 p r :+ e -> [Event p r]
asEventPts :: (LineSegment 2 p r :+ e) -> [Event p r]
asEventPts (LineSegment 2 p r
s :+ e
_) =
  case 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) of
    Ordering
LT -> [LineSegment 2 p r -> Event p r
forall p r. LineSegment 2 p r -> Event p r
Insert LineSegment 2 p r
s, LineSegment 2 p r -> Event p r
forall p r. LineSegment 2 p r -> Event p r
Delete LineSegment 2 p r
s]
    Ordering
_  -> let LineSegment EndPoint (Point 2 r :+ p)
a EndPoint (Point 2 r :+ p)
b = LineSegment 2 p r
s
              s' :: LineSegment 2 p r
s' = EndPoint (Point 2 r :+ p)
-> EndPoint (Point 2 r :+ p) -> LineSegment 2 p r
forall (d :: Nat) r p.
EndPoint (Point d r :+ p)
-> EndPoint (Point d r :+ p) -> LineSegment d p r
LineSegment EndPoint (Point 2 r :+ p)
b EndPoint (Point 2 r :+ p)
a
          in [LineSegment 2 p r -> Event p r
forall p r. LineSegment 2 p r -> Event p r
Insert LineSegment 2 p r
s', LineSegment 2 p r -> Event p r
forall p r. LineSegment 2 p r -> Event p r
Delete LineSegment 2 p r
s']

--------------------------------------------------------------------------------
-- * Data type for Events

-- | The actual event consists of a point and its type
data Event p r = Insert (LineSegment 2 p r) | Delete (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)

eventPoint :: Event p r -> Point 2 r
eventPoint :: Event p r -> Point 2 r
eventPoint (Insert LineSegment 2 p r
l) = LineSegment 2 p r
lLineSegment 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
eventPoint (Delete LineSegment 2 p r
l) = LineSegment 2 p r
lLineSegment 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

-- Sort order:
--  1. Y-coord. Larger Ys before smaller.
--  2. X-coord. Smaller Xs before larger.
--  3. Type: Inserts before deletions
ordEvents :: (Num r, Ord r) => Event p r -> Event p r -> Ordering
ordEvents :: Event p r -> Event p r -> Ordering
ordEvents Event p r
e1 Event p r
e2 = Point 2 r -> Point 2 r -> Ordering
forall r. Ord r => Point 2 r -> Point 2 r -> Ordering
ordPoints (Event p r -> Point 2 r
forall p r. Event p r -> Point 2 r
eventPoint Event p r
e1) (Event p r -> Point 2 r
forall p r. Event p r -> Point 2 r
eventPoint Event p r
e2) Ordering -> Ordering -> Ordering
forall a. Semigroup a => a -> a -> a
<> Event p r -> Event p r -> Ordering
forall p r p r. Event p r -> Event p r -> Ordering
cmpType Event p r
e1 Event p r
e2
  where
    cmpType :: Event p r -> Event p r -> Ordering
cmpType Insert{} Delete{} = Ordering
LT
    cmpType Delete{} Insert{} = Ordering
GT
    cmpType Event p r
_ Event p r
_               = Ordering
EQ

-- | 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

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

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

-- | Run the sweep handling all events
sweep :: forall r p. (Ord r, Num r)
      => [Event p r] -> StatusStructure p r
      -> Bool
sweep :: [Event p r] -> StatusStructure p r -> Bool
sweep [] StatusStructure p r
_ = Bool
False
sweep (Delete LineSegment 2 p r
l:[Event p r]
eq) StatusStructure p r
ss =
    Bool
overlaps Bool -> Bool -> Bool
|| [Event p r] -> StatusStructure p r -> Bool
forall r p.
(Ord r, Num r) =>
[Event p r] -> StatusStructure p r -> Bool
sweep [Event p r]
eq StatusStructure p r
ss'
  where
    p :: Point 2 r
p = LineSegment 2 p r
lLineSegment 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
    (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.
(Num r, Ord r) =>
Point 2 r
-> StatusStructure p r
-> (StatusStructure p r, [LineSegment 2 p r], StatusStructure p r)
splitBeforeAfter Point 2 r
p StatusStructure p r
ss
    overlaps :: Bool
overlaps = Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
False (LineSegment 2 p r -> LineSegment 2 p r -> Bool
forall g h. HasIntersectionWith g h => g -> h -> Bool
intersects (LineSegment 2 p r -> LineSegment 2 p r -> Bool)
-> Maybe (LineSegment 2 p r) -> Maybe (LineSegment 2 p r -> Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (LineSegment 2 p r)
sl Maybe (LineSegment 2 p r -> Bool)
-> Maybe (LineSegment 2 p r) -> Maybe Bool
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> 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
    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
after
sweep (Insert l :: LineSegment 2 p r
l@(LineSegment EndPoint (Point 2 r :+ p)
startPoint EndPoint (Point 2 r :+ p)
_endPoint):[Event p r]
eq) StatusStructure p r
ss =
    Bool
endOverlap Bool -> Bool -> Bool
|| Bool
overlaps Bool -> Bool -> Bool
|| [Event p r] -> StatusStructure p r -> Bool
forall r p.
(Ord r, Num r) =>
[Event p r] -> StatusStructure p r -> Bool
sweep [Event p r]
eq StatusStructure p r
ss'
  where
    p :: Point 2 r
p = LineSegment 2 p r
lLineSegment 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
    (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.
(Num r, Ord r) =>
Point 2 r
-> StatusStructure p r
-> (StatusStructure p r, [LineSegment 2 p r], StatusStructure p r)
splitBeforeAfter Point 2 r
p StatusStructure p r
ss

    -- Check whether the endpoint is contained in one of the existing
    -- segments. The only segments that could qualify are the ones in
    -- 'contains'. Hence check only those. Note that it is not
    -- sufficient just to check whether 'contains' is empty or not,
    -- since there may be segments whose endpoint is open and coincides with p.
    endOverlap :: Bool
endOverlap = EndPoint (Point 2 r :+ p) -> Bool
forall a. EndPoint a -> Bool
isClosed EndPoint (Point 2 r :+ p)
startPoint Bool -> Bool -> Bool
&& (LineSegment 2 p r -> Bool) -> [LineSegment 2 p r] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Point 2 r
p Point 2 r -> LineSegment 2 p r -> Bool
forall g h. HasIntersectionWith g h => g -> h -> Bool
`intersects`) [LineSegment 2 p r]
contains

    overlaps :: Bool
overlaps =
      [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or [ Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
False (LineSegment 2 p r -> LineSegment 2 p r -> Bool
forall g h. HasIntersectionWith g h => g -> h -> Bool
intersects LineSegment 2 p r
l (LineSegment 2 p r -> Bool)
-> Maybe (LineSegment 2 p r) -> Maybe Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (LineSegment 2 p r)
sl)
                  , Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
False (LineSegment 2 p r -> LineSegment 2 p r -> Bool
forall g h. HasIntersectionWith g h => g -> h -> Bool
intersects LineSegment 2 p r
l (LineSegment 2 p r -> Bool)
-> Maybe (LineSegment 2 p r) -> Maybe Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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
    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` LineSegment 2 p r -> StatusStructure p r
forall a. a -> Set a
SS.singleton LineSegment 2 p r
l StatusStructure p r -> StatusStructure p r -> StatusStructure p r
forall a. Set a -> Set a -> Set a
`SS.join` StatusStructure p r
after


-- | split the status structure around p.
-- the result is (before,contains,after)
splitBeforeAfter      :: (Num r, Ord r)
                     => Point 2 r -> StatusStructure p r
                     -> (StatusStructure p r, [LineSegment 2 p r],StatusStructure p r)
splitBeforeAfter :: Point 2 r
-> StatusStructure p r
-> (StatusStructure p r, [LineSegment 2 p r], StatusStructure p r)
splitBeforeAfter Point 2 r
p StatusStructure p r
ss = (StatusStructure p r
before, (LineSegment 2 p r -> Bool)
-> [LineSegment 2 p r] -> [LineSegment 2 p r]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> (LineSegment 2 p r -> Bool) -> LineSegment 2 p r -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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] -> [LineSegment 2 p r])
-> [LineSegment 2 p r] -> [LineSegment 2 p r]
forall a b. (a -> b) -> a -> b
$ StatusStructure p r -> [LineSegment 2 p r]
forall a. Set a -> [a]
SS.toList StatusStructure p r
contains, StatusStructure p r
after)
  where
    (StatusStructure p r
before,StatusStructure p r
contains,StatusStructure p r
after) = (LineSegment 2 p r -> Ordering)
-> StatusStructure p r
-> (StatusStructure p r, StatusStructure p r, StatusStructure p r)
forall a. (a -> Ordering) -> Set a -> (Set a, Set a, Set a)
SS.splitBy LineSegment 2 p r -> Ordering
cmpLine StatusStructure p r
ss
    cmpLine :: LineSegment 2 p r -> Ordering
cmpLine LineSegment 2 p r
line
      | LineSegment 2 p r -> Bool
forall r p. Eq r => LineSegment 2 p r -> Bool
isHorizontal LineSegment 2 p r
line =
        let [Point 2 r
_top,Point 2 r
bot] = (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
lineLineSegment 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
lineLineSegment 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
botPoint 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) r -> r -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` (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)
    cmpLine LineSegment 2 p r
line =
      let [Point 2 r
top,Point 2 r
bot] = (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
lineLineSegment 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
lineLineSegment 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
      case Point 2 r -> Point 2 r -> Point 2 r -> CCW
forall r.
(Ord r, Num r) =>
Point 2 r -> Point 2 r -> Point 2 r -> CCW
ccw Point 2 r
bot Point 2 r
top Point 2 r
p of
        CCW
CW       -> Ordering
LT
        CCW
CoLinear -> Ordering
EQ
        CCW
CCW      -> Ordering
GT


isHorizontal :: Eq r => LineSegment 2 p r -> Bool
isHorizontal :: LineSegment 2 p r -> Bool
isHorizontal 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.
(2 <= d, Arity d, AsAPoint point) =>
Lens' (point d r) r
yCoord r -> r -> Bool
forall a. Eq a => a -> a -> Bool
== 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.
(2 <= d, Arity d, AsAPoint point) =>
Lens' (point d r) r
yCoord

-- | 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 EndPoint (Point 2 r :+ p)
_ EndPoint (Point 2 r :+ p)
b) = ((Point 2 r :+ p) -> Point 2 r)
-> EndPoint (Point 2 r :+ p) -> EndPoint (Point 2 r)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Getting (Point 2 r) (Point 2 r :+ p) (Point 2 r)
-> (Point 2 r :+ p) -> Point 2 r
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (Point 2 r) (Point 2 r :+ p) (Point 2 r)
forall core extra core'.
Lens (core :+ extra) (core' :+ extra) core core'
core) EndPoint (Point 2 r :+ p)
b EndPoint (Point 2 r) -> EndPoint (Point 2 r) -> Bool
forall a. Eq a => a -> a -> Bool
== Point 2 r -> EndPoint (Point 2 r)
forall a. a -> EndPoint a
Open Point 2 r
p

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

-- -- | Given two segments test if they intersect. Why don't we simply use 'intersect'
-- segmentsOverlap :: (Num r, Ord r) => LineSegment 2 p r -> LineSegment 2 p r -> Bool
-- segmentsOverlap a@(LineSegment aStart aEnd) b =
--     (isClosed aStart && (aStart^.unEndPoint.core) `intersects` b) ||
--     (isClosed aEnd && (aEnd^.unEndPoint.core) `intersects` b) ||
--     (opposite (ccw' (a^.start) (b^.start) (a^.end)) (ccw' (a^.start) (b^.end) (a^.end)) &&
--     not (onTriangleRelaxed (a^.end.core) t1) &&
--     not (onTriangleRelaxed (a^.start.core) t2))
--   where
--     opposite CW CCW = True
--     opposite CCW CW = True
--     opposite _ _    = False
--     t1 = Triangle (a^.start) (b^.start) (b^.end)
--     t2 = Triangle (a^.end) (b^.start) (b^.end)


bug' :: Bool
bug' = [LineSegment 2 () Int :+ ()] -> Bool
forall r p e. (Ord r, Num r) => [LineSegment 2 p r :+ e] -> Bool
hasIntersections ([LineSegment 2 () Int :+ ()] -> Bool)
-> [LineSegment 2 () Int :+ ()] -> Bool
forall a b. (a -> b) -> a -> b
$ (LineSegment 2 () Int -> LineSegment 2 () Int :+ ())
-> [LineSegment 2 () Int] -> [LineSegment 2 () Int :+ ()]
forall a b. (a -> b) -> [a] -> [b]
map LineSegment 2 () Int -> LineSegment 2 () Int :+ ()
forall a. a -> a :+ ()
ext ([LineSegment 2 () Int] -> [LineSegment 2 () Int :+ ()])
-> [LineSegment 2 () Int] -> [LineSegment 2 () Int :+ ()]
forall a b. (a -> b) -> a -> b
$ Polygon 'Simple () Int -> [LineSegment 2 () Int]
forall (t :: PolygonType) p r. Polygon t p r -> [LineSegment 2 p r]
listEdges Polygon 'Simple () Int
bug

bug :: SimplePolygon () Int
bug :: Polygon 'Simple () Int
bug = [Point 2 Int :+ ()] -> Polygon 'Simple () Int
forall p r. (Eq r, Num r) => [Point 2 r :+ p] -> SimplePolygon p r
fromPoints ([Point 2 Int :+ ()] -> Polygon 'Simple () Int)
-> ([Point 2 Int] -> [Point 2 Int :+ ()])
-> [Point 2 Int]
-> Polygon 'Simple () Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Point 2 Int -> Point 2 Int :+ ())
-> [Point 2 Int] -> [Point 2 Int :+ ()]
forall a b. (a -> b) -> [a] -> [b]
map Point 2 Int -> Point 2 Int :+ ()
forall a. a -> a :+ ()
ext ([Point 2 Int] -> Polygon 'Simple () Int)
-> [Point 2 Int] -> Polygon 'Simple () Int
forall a b. (a -> b) -> a -> b
$ [
  Int -> Int -> Point 2 Int
forall r. r -> r -> Point 2 r
Point2 Int
144 Int
592
  , Int -> Int -> Point 2 Int
forall r. r -> r -> Point 2 r
Point2 Int
336 Int
624
  , Int -> Int -> Point 2 Int
forall r. r -> r -> Point 2 r
Point2 Int
320 Int
544
  , Int -> Int -> Point 2 Int
forall r. r -> r -> Point 2 r
Point2 Int
240 Int
624
  ]

s1, s2 :: LineSegment 2 () Int
s1 :: LineSegment 2 () Int
s1 = String -> LineSegment 2 () Int
forall a. Read a => String -> a
read String
"LineSegment (Closed (Point2 240 620 :+ ())) (Open (Point2 320 544 :+ ()))"
s2 :: LineSegment 2 () Int
s2 = String -> LineSegment 2 () Int
forall a. Read a => String -> a
read String
"LineSegment (Closed (Point2 144 592 :+ ())) (Open (Point2 336 624 :+ ()))"

tr :: String -> b -> b
tr String
s b
x = (String, b) -> b -> b
forall a b. Show a => a -> b -> b
traceShow (String
s String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" : ", b
x) b
x

edges' :: [LineSegment 2 () Int]
edges' :: [LineSegment 2 () Int]
edges' = [ EndPoint (Point 2 Int :+ ())
-> EndPoint (Point 2 Int :+ ()) -> LineSegment 2 () Int
forall (d :: Nat) r p.
EndPoint (Point d r :+ p)
-> EndPoint (Point d r :+ p) -> LineSegment d p r
LineSegment ((Point 2 Int :+ ()) -> EndPoint (Point 2 Int :+ ())
forall a. a -> EndPoint a
Closed (Int -> Int -> Point 2 Int
forall r. r -> r -> Point 2 r
Point2 Int
240 Int
624 Point 2 Int -> () -> Point 2 Int :+ ()
forall core extra. core -> extra -> core :+ extra
:+ ())) ((Point 2 Int :+ ()) -> EndPoint (Point 2 Int :+ ())
forall a. a -> EndPoint a
Open (Int -> Int -> Point 2 Int
forall r. r -> r -> Point 2 r
Point2 Int
320 Int
544 Point 2 Int -> () -> Point 2 Int :+ ()
forall core extra. core -> extra -> core :+ extra
:+ ()))
--         , LineSegment (Closed (Point2 320 544 :+ ())) (Open (Point2 336 624 :+ ()))
         , EndPoint (Point 2 Int :+ ())
-> EndPoint (Point 2 Int :+ ()) -> LineSegment 2 () Int
forall (d :: Nat) r p.
EndPoint (Point d r :+ p)
-> EndPoint (Point d r :+ p) -> LineSegment d p r
LineSegment ((Point 2 Int :+ ()) -> EndPoint (Point 2 Int :+ ())
forall a. a -> EndPoint a
Closed (Int -> Int -> Point 2 Int
forall r. r -> r -> Point 2 r
Point2 Int
336 Int
624 Point 2 Int -> () -> Point 2 Int :+ ()
forall core extra. core -> extra -> core :+ extra
:+ ())) ((Point 2 Int :+ ()) -> EndPoint (Point 2 Int :+ ())
forall a. a -> EndPoint a
Open (Int -> Int -> Point 2 Int
forall r. r -> r -> Point 2 r
Point2 Int
144 Int
592 Point 2 Int -> () -> Point 2 Int :+ ()
forall core extra. core -> extra -> core :+ extra
:+ ()))
         , EndPoint (Point 2 Int :+ ())
-> EndPoint (Point 2 Int :+ ()) -> LineSegment 2 () Int
forall (d :: Nat) r p.
EndPoint (Point d r :+ p)
-> EndPoint (Point d r :+ p) -> LineSegment d p r
LineSegment ((Point 2 Int :+ ()) -> EndPoint (Point 2 Int :+ ())
forall a. a -> EndPoint a
Closed (Int -> Int -> Point 2 Int
forall r. r -> r -> Point 2 r
Point2 Int
144 Int
592 Point 2 Int -> () -> Point 2 Int :+ ()
forall core extra. core -> extra -> core :+ extra
:+ ())) ((Point 2 Int :+ ()) -> EndPoint (Point 2 Int :+ ())
forall a. a -> EndPoint a
Open (Int -> Int -> Point 2 Int
forall r. r -> r -> Point 2 r
Point2 Int
240 Int
624 Point 2 Int -> () -> Point 2 Int :+ ()
forall core extra. core -> extra -> core :+ extra
:+ ()))
         ]

-- ah, I guess it selects the wrong predecessor/successor seg, since they overlap at the endpoint.