{-# LANGUAGE TemplateHaskell #-}
--------------------------------------------------------------------------------
-- |
-- Module      :  Data.Geometry.Arrangement.Internal
-- Copyright   :  (C) Frank Staals
-- License     :  see the LICENSE file
-- Maintainer  :  Frank Staals
--
-- Data type for representing an Arrangement of lines in \(\mathbb{R}^2\).
--
--------------------------------------------------------------------------------
module Data.Geometry.Arrangement.Internal where

import           Algorithms.BinarySearch
import           Control.Lens
import           Data.Bifunctor
import qualified Data.CircularSeq                as CSeq
import           Data.Ext
import qualified Data.Foldable                   as F
import           Data.Geometry.Boundary
import           Data.Geometry.Box
import           Data.Geometry.Line
import           Data.Geometry.LineSegment
import           Data.Geometry.PlanarSubdivision
import           Data.Geometry.Point
import           Data.Geometry.Properties
import qualified Data.List                       as List
import           Data.Maybe
import           Data.Ord                        (Down (..))
import qualified Data.Vector                     as V
import           Data.Vinyl.CoRec

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

type ArrangementBoundary s e r = V.Vector (Point 2 r, VertexId' s, Maybe (Line 2 r :+ e))

-- | Data type representing a two dimensional planar arrangement
data Arrangement s l v e f r = Arrangement {
    Arrangement s l v e f r -> Vector (Line 2 r :+ l)
_inputLines             :: V.Vector (Line 2 r :+ l)
  , Arrangement s l v e f r -> PlanarSubdivision s v e f r
_subdivision            :: PlanarSubdivision s v e f r
  , Arrangement s l v e f r -> Rectangle () r
_boundedArea            :: Rectangle () r
  , Arrangement s l v e f r -> ArrangementBoundary s l r
_unboundedIntersections :: ArrangementBoundary s l r
  } deriving (Int -> Arrangement s l v e f r -> ShowS
[Arrangement s l v e f r] -> ShowS
Arrangement s l v e f r -> String
(Int -> Arrangement s l v e f r -> ShowS)
-> (Arrangement s l v e f r -> String)
-> ([Arrangement s l v e f r] -> ShowS)
-> Show (Arrangement s l v e f r)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall k (s :: k) l v e f r.
(Show r, Show l, Show v, Show e, Show f) =>
Int -> Arrangement s l v e f r -> ShowS
forall k (s :: k) l v e f r.
(Show r, Show l, Show v, Show e, Show f) =>
[Arrangement s l v e f r] -> ShowS
forall k (s :: k) l v e f r.
(Show r, Show l, Show v, Show e, Show f) =>
Arrangement s l v e f r -> String
showList :: [Arrangement s l v e f r] -> ShowS
$cshowList :: forall k (s :: k) l v e f r.
(Show r, Show l, Show v, Show e, Show f) =>
[Arrangement s l v e f r] -> ShowS
show :: Arrangement s l v e f r -> String
$cshow :: forall k (s :: k) l v e f r.
(Show r, Show l, Show v, Show e, Show f) =>
Arrangement s l v e f r -> String
showsPrec :: Int -> Arrangement s l v e f r -> ShowS
$cshowsPrec :: forall k (s :: k) l v e f r.
(Show r, Show l, Show v, Show e, Show f) =>
Int -> Arrangement s l v e f r -> ShowS
Show,Arrangement s l v e f r -> Arrangement s l v e f r -> Bool
(Arrangement s l v e f r -> Arrangement s l v e f r -> Bool)
-> (Arrangement s l v e f r -> Arrangement s l v e f r -> Bool)
-> Eq (Arrangement s l v e f r)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall k (s :: k) l v e f r.
(Fractional r, Eq r, Eq l, Eq v, Eq e, Eq f) =>
Arrangement s l v e f r -> Arrangement s l v e f r -> Bool
/= :: Arrangement s l v e f r -> Arrangement s l v e f r -> Bool
$c/= :: forall k (s :: k) l v e f r.
(Fractional r, Eq r, Eq l, Eq v, Eq e, Eq f) =>
Arrangement s l v e f r -> Arrangement s l v e f r -> Bool
== :: Arrangement s l v e f r -> Arrangement s l v e f r -> Bool
$c== :: forall k (s :: k) l v e f r.
(Fractional r, Eq r, Eq l, Eq v, Eq e, Eq f) =>
Arrangement s l v e f r -> Arrangement s l v e f r -> Bool
Eq)
  -- unboundedIntersections also stores the corners of the box. They are not
  -- associated with any line
makeLenses ''Arrangement

type instance NumType   (Arrangement s l v e f r) = r
type instance Dimension (Arrangement s l v e f r) = 2

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

-- | Builds an arrangement of \(n\) lines
--
-- running time: \(O(n^2\log n\)
constructArrangement       :: (Ord r, Fractional r)
                           => proxy s
                           -> [Line 2 r :+ l]
                           -> Arrangement s l () (Maybe l) () r
constructArrangement :: proxy s -> [Line 2 r :+ l] -> Arrangement s l () (Maybe l) () r
constructArrangement proxy s
px [Line 2 r :+ l]
ls = let b :: Rectangle () r
b  = [Line 2 r :+ l] -> Rectangle () r
forall r l.
(Ord r, Fractional r) =>
[Line 2 r :+ l] -> Rectangle () r
makeBoundingBox [Line 2 r :+ l]
ls
                             in proxy s
-> Rectangle () r
-> [Line 2 r :+ l]
-> Arrangement s l () (Maybe l) () r
forall k r (proxy :: k -> *) (s :: k) l.
(Ord r, Fractional r) =>
proxy s
-> Rectangle () r
-> [Line 2 r :+ l]
-> Arrangement s l () (Maybe l) () r
constructArrangementInBox' proxy s
px Rectangle () r
b [Line 2 r :+ l]
ls

-- | Constructs the arrangemnet inside the box.  note that the resulting box
-- may be larger than the given box to make sure that all vertices of the
-- arrangement actually fit.
--
-- running time: \(O(n^2\log n\)
constructArrangementInBox            :: (Ord r, Fractional r)
                                     => proxy s
                                     -> Rectangle () r
                                     -> [Line 2 r :+ l]
                                     -> Arrangement s l () (Maybe l) () r
constructArrangementInBox :: proxy s
-> Rectangle () r
-> [Line 2 r :+ l]
-> Arrangement s l () (Maybe l) () r
constructArrangementInBox proxy s
px Rectangle () r
rect [Line 2 r :+ l]
ls = let b :: Rectangle () r
b  = [Line 2 r :+ l] -> Rectangle () r
forall r l.
(Ord r, Fractional r) =>
[Line 2 r :+ l] -> Rectangle () r
makeBoundingBox [Line 2 r :+ l]
ls
                                       in proxy s
-> Rectangle () r
-> [Line 2 r :+ l]
-> Arrangement s l () (Maybe l) () r
forall k r (proxy :: k -> *) (s :: k) l.
(Ord r, Fractional r) =>
proxy s
-> Rectangle () r
-> [Line 2 r :+ l]
-> Arrangement s l () (Maybe l) () r
constructArrangementInBox' proxy s
px (Rectangle () r
b Rectangle () r -> Rectangle () r -> Rectangle () r
forall a. Semigroup a => a -> a -> a
<> Rectangle () r
rect) [Line 2 r :+ l]
ls


-- | Constructs the arrangemnet inside the box. (for parts to be useful, it is
-- assumed this boxfits at least the boundingbox of the intersections in the
-- Arrangement)
constructArrangementInBox'            :: (Ord r, Fractional r)
                                      => proxy s
                                      -> Rectangle () r
                                      -> [Line 2 r :+ l]
                                      -> Arrangement s l () (Maybe l) () r
constructArrangementInBox' :: proxy s
-> Rectangle () r
-> [Line 2 r :+ l]
-> Arrangement s l () (Maybe l) () r
constructArrangementInBox' proxy s
px Rectangle () r
rect [Line 2 r :+ l]
ls =
    Vector (Line 2 r :+ l)
-> PlanarSubdivision s () (Maybe l) () r
-> Rectangle () r
-> ArrangementBoundary s l r
-> Arrangement s l () (Maybe l) () r
forall k (s :: k) l v e f r.
Vector (Line 2 r :+ l)
-> PlanarSubdivision s v e f r
-> Rectangle () r
-> ArrangementBoundary s l r
-> Arrangement s l v e f r
Arrangement ([Line 2 r :+ l] -> Vector (Line 2 r :+ l)
forall a. [a] -> Vector a
V.fromList [Line 2 r :+ l]
ls) PlanarSubdivision s () (Maybe l) () r
subdiv Rectangle () r
rect ([(Point 2 r, Maybe (Line 2 r :+ l))]
-> PlanarSubdivision s () (Maybe l) () r
-> ArrangementBoundary s l r
forall k r a (s :: k) v e f.
Eq r =>
[(Point 2 r, a)]
-> PlanarSubdivision s v (Maybe e) f r
-> Vector (Point 2 r, VertexId' s, a)
link [(Point 2 r, Maybe (Line 2 r :+ l))]
parts' PlanarSubdivision s () (Maybe l) () r
subdiv)
  where
    subdiv :: PlanarSubdivision s () (Maybe l) () r
subdiv = proxy s
-> [LineSegment 2 () r :+ Maybe l]
-> PlanarSubdivision s (NonEmpty ()) (Maybe l) () r
forall k (f :: * -> *) r (proxy :: k -> *) (s :: k) p e.
(Foldable f, Ord r, Fractional r) =>
proxy s
-> f (LineSegment 2 p r :+ e)
-> PlanarSubdivision s (NonEmpty p) e () r
fromConnectedSegments proxy s
px [LineSegment 2 () r :+ Maybe l]
segs
                PlanarSubdivision s (NonEmpty ()) (Maybe l) () r
-> (PlanarSubdivision s (NonEmpty ()) (Maybe l) () r
    -> PlanarSubdivision s () (Maybe l) () r)
-> PlanarSubdivision s () (Maybe l) () r
forall a b. a -> (a -> b) -> b
& (Vector (Raw s (VertexId' (Wrap s)) (NonEmpty ()))
 -> Identity (Vector (Raw s (VertexId' (Wrap s)) ())))
-> PlanarSubdivision s (NonEmpty ()) (Maybe l) () r
-> Identity (PlanarSubdivision s () (Maybe l) () r)
forall k (s :: k) v1 e f r v2.
Lens
  (PlanarSubdivision s v1 e f r)
  (PlanarSubdivision s v2 e f r)
  (Vector (Raw s (VertexId' (Wrap s)) v1))
  (Vector (Raw s (VertexId' (Wrap s)) v2))
rawVertexData((Vector (Raw s (VertexId' (Wrap s)) (NonEmpty ()))
  -> Identity (Vector (Raw s (VertexId' (Wrap s)) ())))
 -> PlanarSubdivision s (NonEmpty ()) (Maybe l) () r
 -> Identity (PlanarSubdivision s () (Maybe l) () r))
-> ((NonEmpty () -> Identity ())
    -> Vector (Raw s (VertexId' (Wrap s)) (NonEmpty ()))
    -> Identity (Vector (Raw s (VertexId' (Wrap s)) ())))
-> (NonEmpty () -> Identity ())
-> PlanarSubdivision s (NonEmpty ()) (Maybe l) () r
-> Identity (PlanarSubdivision s () (Maybe l) () r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Raw s (VertexId' (Wrap s)) (NonEmpty ())
 -> Identity (Raw s (VertexId' (Wrap s)) ()))
-> Vector (Raw s (VertexId' (Wrap s)) (NonEmpty ()))
-> Identity (Vector (Raw s (VertexId' (Wrap s)) ()))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse((Raw s (VertexId' (Wrap s)) (NonEmpty ())
  -> Identity (Raw s (VertexId' (Wrap s)) ()))
 -> Vector (Raw s (VertexId' (Wrap s)) (NonEmpty ()))
 -> Identity (Vector (Raw s (VertexId' (Wrap s)) ())))
-> ((NonEmpty () -> Identity ())
    -> Raw s (VertexId' (Wrap s)) (NonEmpty ())
    -> Identity (Raw s (VertexId' (Wrap s)) ()))
-> (NonEmpty () -> Identity ())
-> Vector (Raw s (VertexId' (Wrap s)) (NonEmpty ()))
-> Identity (Vector (Raw s (VertexId' (Wrap s)) ()))
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(NonEmpty () -> Identity ())
-> Raw s (VertexId' (Wrap s)) (NonEmpty ())
-> Identity (Raw s (VertexId' (Wrap s)) ())
forall k (s :: k) ia a b. Lens (Raw s ia a) (Raw s ia b) a b
dataVal ((NonEmpty () -> Identity ())
 -> PlanarSubdivision s (NonEmpty ()) (Maybe l) () r
 -> Identity (PlanarSubdivision s () (Maybe l) () r))
-> ()
-> PlanarSubdivision s (NonEmpty ()) (Maybe l) () r
-> PlanarSubdivision s () (Maybe l) () r
forall s t a b. ASetter s t a b -> b -> s -> t
.~ ()
    ([LineSegment 2 () r :+ Maybe l]
segs,[(Point 2 r, Maybe (Line 2 r :+ l))]
parts') = Rectangle () r
-> [Line 2 r :+ l]
-> ([LineSegment 2 () r :+ Maybe l],
    [(Point 2 r, Maybe (Line 2 r :+ l))])
forall r l.
(Ord r, Fractional r) =>
Rectangle () r
-> [Line 2 r :+ l]
-> ([LineSegment 2 () r :+ Maybe l],
    [(Point 2 r, Maybe (Line 2 r :+ l))])
computeSegsAndParts Rectangle () r
rect [Line 2 r :+ l]
ls

computeSegsAndParts         :: forall r l. (Ord r, Fractional r)
                            => Rectangle () r
                            -> [Line 2 r :+ l]
                            -> ( [LineSegment 2 () r :+ Maybe l]
                               , [(Point 2 r, Maybe (Line 2 r :+ l))]
                               )
computeSegsAndParts :: Rectangle () r
-> [Line 2 r :+ l]
-> ([LineSegment 2 () r :+ Maybe l],
    [(Point 2 r, Maybe (Line 2 r :+ l))])
computeSegsAndParts Rectangle () r
rect [Line 2 r :+ l]
ls = ( [LineSegment 2 () r :+ Maybe l]
segs [LineSegment 2 () r :+ Maybe l]
-> [LineSegment 2 () r :+ Maybe l]
-> [LineSegment 2 () r :+ Maybe l]
forall a. Semigroup a => a -> a -> a
<> [LineSegment 2 () r :+ Maybe l]
boundarySegs, [(Point 2 r, Maybe (Line 2 r :+ l))]
parts')
  where
    segs :: [LineSegment 2 () r :+ Maybe l]
segs         = ((LineSegment 2 () r :+ l) -> LineSegment 2 () r :+ Maybe l)
-> [LineSegment 2 () r :+ l] -> [LineSegment 2 () r :+ Maybe l]
forall a b. (a -> b) -> [a] -> [b]
map ((LineSegment 2 () r :+ l)
-> ((LineSegment 2 () r :+ l) -> LineSegment 2 () r :+ Maybe l)
-> LineSegment 2 () r :+ Maybe l
forall a b. a -> (a -> b) -> b
&(l -> Identity (Maybe l))
-> (LineSegment 2 () r :+ l)
-> Identity (LineSegment 2 () r :+ Maybe l)
forall core extra extra'.
Lens (core :+ extra) (core :+ extra') extra extra'
extra ((l -> Identity (Maybe l))
 -> (LineSegment 2 () r :+ l)
 -> Identity (LineSegment 2 () r :+ Maybe l))
-> (l -> Maybe l)
-> (LineSegment 2 () r :+ l)
-> LineSegment 2 () r :+ Maybe l
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ l -> Maybe l
forall a. a -> Maybe a
Just)
                 ([LineSegment 2 () r :+ l] -> [LineSegment 2 () r :+ Maybe l])
-> ([(Line 2 r :+ l, [Line 2 r :+ l])]
    -> [LineSegment 2 () r :+ l])
-> [(Line 2 r :+ l, [Line 2 r :+ l])]
-> [LineSegment 2 () r :+ Maybe l]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Line 2 r :+ l, [Line 2 r :+ l]) -> [LineSegment 2 () r :+ l])
-> [(Line 2 r :+ l, [Line 2 r :+ l])] -> [LineSegment 2 () r :+ l]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (((Line 2 r :+ l) -> [Line 2 r :+ l] -> [LineSegment 2 () r :+ l])
-> (Line 2 r :+ l, [Line 2 r :+ l]) -> [LineSegment 2 () r :+ l]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (Rectangle () r
-> (Line 2 r :+ l) -> [Line 2 r :+ l] -> [LineSegment 2 () r :+ l]
forall r l.
(Ord r, Fractional r) =>
Rectangle () r
-> (Line 2 r :+ l) -> [Line 2 r :+ l] -> [LineSegment 2 () r :+ l]
perLine Rectangle () r
rect)) ([(Line 2 r :+ l, [Line 2 r :+ l])]
 -> [LineSegment 2 () r :+ Maybe l])
-> [(Line 2 r :+ l, [Line 2 r :+ l])]
-> [LineSegment 2 () r :+ Maybe l]
forall a b. (a -> b) -> a -> b
$ [Line 2 r :+ l] -> [(Line 2 r :+ l, [Line 2 r :+ l])]
forall a. [a] -> [(a, [a])]
makePairs [Line 2 r :+ l]
ls
    boundarySegs :: [LineSegment 2 () r :+ Maybe l]
boundarySegs = (LineSegment 2 () r -> LineSegment 2 () r :+ Maybe l)
-> [LineSegment 2 () r] -> [LineSegment 2 () r :+ Maybe l]
forall a b. (a -> b) -> [a] -> [b]
map (LineSegment 2 () r -> Maybe l -> LineSegment 2 () r :+ Maybe l
forall core extra. core -> extra -> core :+ extra
:+ Maybe l
forall a. Maybe a
Nothing) ([LineSegment 2 () r] -> [LineSegment 2 () r :+ Maybe l])
-> ([Point 2 r] -> [LineSegment 2 () r])
-> [Point 2 r]
-> [LineSegment 2 () r :+ Maybe l]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Point 2 r] -> [LineSegment 2 () r]
forall r. Ord r => [Point 2 r] -> [LineSegment 2 () r]
toSegments ([Point 2 r] -> [LineSegment 2 () r])
-> ([Point 2 r] -> [Point 2 r])
-> [Point 2 r]
-> [LineSegment 2 () r]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Point 2 r] -> [Point 2 r]
forall a. [a] -> [a]
dupFirst ([Point 2 r] -> [LineSegment 2 () r :+ Maybe l])
-> [Point 2 r] -> [LineSegment 2 () r :+ Maybe l]
forall a b. (a -> b) -> a -> b
$ ((Point 2 r, Maybe (Line 2 r :+ l)) -> Point 2 r)
-> [(Point 2 r, Maybe (Line 2 r :+ l))] -> [Point 2 r]
forall a b. (a -> b) -> [a] -> [b]
map (Point 2 r, Maybe (Line 2 r :+ l)) -> Point 2 r
forall a b. (a, b) -> a
fst [(Point 2 r, Maybe (Line 2 r :+ l))]
parts'
    dupFirst :: [a] -> [a]
dupFirst = \case []       -> []
                     xs :: [a]
xs@(a
x:[a]
_) -> [a]
xs [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a
x]
    parts' :: [(Point 2 r, Maybe (Line 2 r :+ l))]
parts'       = Rectangle () r
-> [Line 2 r :+ l] -> [(Point 2 r, Maybe (Line 2 r :+ l))]
forall r l.
(Ord r, Fractional r) =>
Rectangle () r
-> [Line 2 r :+ l] -> [(Point 2 r, Maybe (Line 2 r :+ l))]
unBoundedParts Rectangle () r
rect [Line 2 r :+ l]
ls


perLine       :: forall r l. (Ord r, Fractional r)
              => Rectangle () r -> Line 2 r :+ l -> [Line 2 r :+ l]
              -> [LineSegment 2 () r :+ l]
perLine :: Rectangle () r
-> (Line 2 r :+ l) -> [Line 2 r :+ l] -> [LineSegment 2 () r :+ l]
perLine Rectangle () r
b Line 2 r :+ l
m [Line 2 r :+ l]
ls = (LineSegment 2 () r -> LineSegment 2 () r :+ l)
-> [LineSegment 2 () r] -> [LineSegment 2 () r :+ l]
forall a b. (a -> b) -> [a] -> [b]
map (LineSegment 2 () r -> l -> LineSegment 2 () r :+ l
forall core extra. core -> extra -> core :+ extra
:+ Line 2 r :+ l
m(Line 2 r :+ l) -> Getting l (Line 2 r :+ l) l -> l
forall s a. s -> Getting a s a -> a
^.Getting l (Line 2 r :+ l) l
forall core extra extra'.
Lens (core :+ extra) (core :+ extra') extra extra'
extra) ([LineSegment 2 () r] -> [LineSegment 2 () r :+ l])
-> ([Point 2 r] -> [LineSegment 2 () r])
-> [Point 2 r]
-> [LineSegment 2 () r :+ l]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Point 2 r] -> [LineSegment 2 () r]
forall r. Ord r => [Point 2 r] -> [LineSegment 2 () r]
toSegments ([Point 2 r] -> [LineSegment 2 () r])
-> ([Point 2 r] -> [Point 2 r])
-> [Point 2 r]
-> [LineSegment 2 () r]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Point 2 r] -> [Point 2 r]
rmDuplicates ([Point 2 r] -> [Point 2 r])
-> ([Point 2 r] -> [Point 2 r]) -> [Point 2 r] -> [Point 2 r]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Point 2 r] -> [Point 2 r]
forall a. Ord a => [a] -> [a]
List.sort ([Point 2 r] -> [LineSegment 2 () r :+ l])
-> [Point 2 r] -> [LineSegment 2 () r :+ l]
forall a b. (a -> b) -> a -> b
$ [Point 2 r]
vs [Point 2 r] -> [Point 2 r] -> [Point 2 r]
forall a. Semigroup a => a -> a -> a
<> [Point 2 r]
vs'
  where
    rmDuplicates :: [Point 2 r] -> [Point 2 r]
rmDuplicates = ([Point 2 r] -> Point 2 r) -> [[Point 2 r]] -> [Point 2 r]
forall a b. (a -> b) -> [a] -> [b]
map [Point 2 r] -> Point 2 r
forall a. [a] -> a
head ([[Point 2 r]] -> [Point 2 r])
-> ([Point 2 r] -> [[Point 2 r]]) -> [Point 2 r] -> [Point 2 r]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Point 2 r] -> [[Point 2 r]]
forall a. Eq a => [a] -> [[a]]
List.group
    vs :: [Point 2 r]
vs  = ((Line 2 r :+ l) -> Maybe (Point 2 r))
-> [Line 2 r :+ l] -> [Point 2 r]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Line 2 r :+ l
m (Line 2 r :+ l) -> (Line 2 r :+ l) -> Maybe (Point 2 r)
forall r l.
(Ord r, Fractional r) =>
(Line 2 r :+ l) -> (Line 2 r :+ l) -> Maybe (Point 2 r)
`intersectionPoint`) [Line 2 r :+ l]
ls
    vs' :: [Point 2 r]
vs' = [Point 2 r]
-> ((Point 2 r, Point 2 r) -> [Point 2 r])
-> Maybe (Point 2 r, Point 2 r)
-> [Point 2 r]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\(Point 2 r
p,Point 2 r
q) -> [Point 2 r
p,Point 2 r
q]) (Maybe (Point 2 r, Point 2 r) -> [Point 2 r])
-> (CoRec
      Identity
      '[NoIntersection, Point 2 r, (Point 2 r, Point 2 r),
        LineSegment 2 () r]
    -> Maybe (Point 2 r, Point 2 r))
-> CoRec
     Identity
     '[NoIntersection, Point 2 r, (Point 2 r, Point 2 r),
       LineSegment 2 () r]
-> [Point 2 r]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (ts :: [*]).
NatToInt (RIndex (Point 2 r, Point 2 r) ts) =>
CoRec Identity ts -> Maybe (Point 2 r, Point 2 r)
forall t (ts :: [*]).
NatToInt (RIndex t ts) =>
CoRec Identity ts -> Maybe t
asA @(Point 2 r, Point 2 r)
        (CoRec
   Identity
   '[NoIntersection, Point 2 r, (Point 2 r, Point 2 r),
     LineSegment 2 () r]
 -> [Point 2 r])
-> CoRec
     Identity
     '[NoIntersection, Point 2 r, (Point 2 r, Point 2 r),
       LineSegment 2 () r]
-> [Point 2 r]
forall a b. (a -> b) -> a -> b
$ (Line 2 r :+ l
m(Line 2 r :+ l)
-> Getting (Line 2 r) (Line 2 r :+ l) (Line 2 r) -> Line 2 r
forall s a. s -> Getting a s a -> a
^.Getting (Line 2 r) (Line 2 r :+ l) (Line 2 r)
forall core extra core'.
Lens (core :+ extra) (core' :+ extra) core core'
core) Line 2 r
-> Boundary (Rectangle () r)
-> Intersection (Line 2 r) (Boundary (Rectangle () r))
forall g h. IsIntersectableWith g h => g -> h -> Intersection g h
`intersect` Rectangle () r -> Boundary (Rectangle () r)
forall g. g -> Boundary g
Boundary Rectangle () r
b


intersectionPoint                   :: forall r l. (Ord r, Fractional r)
                                    => Line 2 r :+ l -> Line 2 r :+ l -> Maybe (Point 2 r)
intersectionPoint :: (Line 2 r :+ l) -> (Line 2 r :+ l) -> Maybe (Point 2 r)
intersectionPoint (Line 2 r
l :+ l
_) (Line 2 r
m :+ l
_) = forall (ts :: [*]).
NatToInt (RIndex (Point 2 r) ts) =>
CoRec Identity ts -> Maybe (Point 2 r)
forall t (ts :: [*]).
NatToInt (RIndex t ts) =>
CoRec Identity ts -> Maybe t
asA @(Point 2 r) (CoRec Identity '[NoIntersection, Point 2 r, Line 2 r]
 -> Maybe (Point 2 r))
-> CoRec Identity '[NoIntersection, Point 2 r, Line 2 r]
-> Maybe (Point 2 r)
forall a b. (a -> b) -> a -> b
$ Line 2 r
l Line 2 r -> Line 2 r -> Intersection (Line 2 r) (Line 2 r)
forall g h. IsIntersectableWith g h => g -> h -> Intersection g h
`intersect` Line 2 r
m


toSegments      :: Ord r => [Point 2 r] -> [LineSegment 2 () r]
toSegments :: [Point 2 r] -> [LineSegment 2 () r]
toSegments [Point 2 r]
ps = let pts :: [Point 2 r :+ ()]
pts = (Point 2 r -> Point 2 r :+ ()) -> [Point 2 r] -> [Point 2 r :+ ()]
forall a b. (a -> b) -> [a] -> [b]
map Point 2 r -> Point 2 r :+ ()
forall a. a -> a :+ ()
ext [Point 2 r]
ps in
  ((Point 2 r :+ ()) -> (Point 2 r :+ ()) -> LineSegment 2 () r)
-> [Point 2 r :+ ()] -> [Point 2 r :+ ()] -> [LineSegment 2 () r]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Point 2 r :+ ()) -> (Point 2 r :+ ()) -> LineSegment 2 () r
forall (d :: Nat) r p.
(Point d r :+ p) -> (Point d r :+ p) -> LineSegment d p r
ClosedLineSegment [Point 2 r :+ ()]
pts ([Point 2 r :+ ()] -> [Point 2 r :+ ()]
forall a. [a] -> [a]
tail [Point 2 r :+ ()]
pts)


-- | Constructs a boundingbox containing all intersections
--
-- running time: \(O(n^2)\), where \(n\) is the number of input lines
makeBoundingBox :: (Ord r, Fractional r) => [Line 2 r :+ l] -> Rectangle () r
makeBoundingBox :: [Line 2 r :+ l] -> Rectangle () r
makeBoundingBox = r -> Rectangle () r -> Rectangle () r
forall r (d :: Nat) p.
(Num r, Arity d) =>
r -> Box d p r -> Box d p r
grow r
1 (Rectangle () r -> Rectangle () r)
-> ([Line 2 r :+ l] -> Rectangle () r)
-> [Line 2 r :+ l]
-> Rectangle () r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Point 2 r] -> Rectangle () r
forall g (c :: * -> *).
(IsBoxable g, Foldable c, Ord (NumType g), Arity (Dimension g)) =>
c g -> Box (Dimension g) () (NumType g)
boundingBoxList' ([Point 2 r] -> Rectangle () r)
-> ([Line 2 r :+ l] -> [Point 2 r])
-> [Line 2 r :+ l]
-> Rectangle () r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Line 2 r :+ l] -> [Point 2 r]
forall r l. (Ord r, Fractional r) => [Line 2 r :+ l] -> [Point 2 r]
intersections

-- | Computes all intersections
intersections :: (Ord r, Fractional r) => [Line 2 r :+ l] -> [Point 2 r]
intersections :: [Line 2 r :+ l] -> [Point 2 r]
intersections = ((Line 2 r :+ l, Line 2 r :+ l) -> Maybe (Point 2 r))
-> [(Line 2 r :+ l, Line 2 r :+ l)] -> [Point 2 r]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (((Line 2 r :+ l) -> (Line 2 r :+ l) -> Maybe (Point 2 r))
-> (Line 2 r :+ l, Line 2 r :+ l) -> Maybe (Point 2 r)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (Line 2 r :+ l) -> (Line 2 r :+ l) -> Maybe (Point 2 r)
forall r l.
(Ord r, Fractional r) =>
(Line 2 r :+ l) -> (Line 2 r :+ l) -> Maybe (Point 2 r)
intersectionPoint) ([(Line 2 r :+ l, Line 2 r :+ l)] -> [Point 2 r])
-> ([Line 2 r :+ l] -> [(Line 2 r :+ l, Line 2 r :+ l)])
-> [Line 2 r :+ l]
-> [Point 2 r]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Line 2 r :+ l] -> [(Line 2 r :+ l, Line 2 r :+ l)]
forall a. [a] -> [(a, a)]
allPairs


-- intersections :: forall p r. (Ord r, Fractional r)
--               => [Line 2 r :+ p] -> Map.Map (Point 2 r) (NonEmpty (Line 2 r :+ p))
-- intersections = Map.map sortNub . collect
--               . mapMaybe (\(l,m) -> (l, m,) <$> f l m) . allPairs
--   where
--     f (l :+ _) (m :+ _) = asA (Proxy :: Proxy (Point 2 r)) $ l `intersect` m



-- collect :: Ord k => [(v,v,k)] -> Map.Map k (NonEmpty v)
-- collect = foldr f mempty
--   where
--     f (l,m,p) = Map.insertWith (<>) p (NonEmpty.fromList [l,m])

-- sortNub :: Ord r => NonEmpty (Line 2 r :+ p) -> NonEmpty (Line 2 r :+ p)
-- sortNub = fmap (NonEmpty.head) .  groupLines

-- groupLines :: Ord r => NonEmpty (Line 2 r :+ p)
--            -> NonEmpty (NonEmpty (Line 2 r :+ p))
-- groupLines = NonEmpty.groupWith1 L2 . NonEmpty.sortWith L2


-- -- | Newtype wrapper that allows us to sort lines
-- newtype L2 r p = L2 (Line 2 r :+ p) deriving (Show)

-- instance Eq r => Eq (L2 r p) where
--   (L2 (Line p u :+ _)) == (L2 (Line q v :+ _)) = (p,u) == (q,v)
-- instance Ord r => Ord (L2 r p) where
--   (L2 (Line p u :+ _)) `compare` (L2 (Line q v :+ _)) = p `compare` q <> u `compare` v

-- -- | Collect the intersection points per line
-- byLine :: Ord r
--        => Map.Map (Point 2 r) (NonEmpty (Line 2 r :+ p))
--        -> Map.Map (L2 r p)    (NonEmpty (Point 2 r))
-- byLine = foldr f mempty . flatten . Map.assocs
--   where
--     flatten = concatMap (\(p,ls) -> map (\l -> (L2 l,p)) $ NonEmpty.toList ls)
--     f (l,p) = Map.insertWith (<>) l $ NonEmpty.fromList [p]


-- | Computes the intersections with a particular side
sideIntersections      :: (Ord r, Fractional r)
                       => [Line 2 r :+ l] -> LineSegment 2 q r
                       -> [(Point 2 r, Line 2 r :+ l)]
sideIntersections :: [Line 2 r :+ l]
-> LineSegment 2 q r -> [(Point 2 r, Line 2 r :+ l)]
sideIntersections [Line 2 r :+ l]
ls LineSegment 2 q r
s = let l :: Line 2 r :+ l
l   = LineSegment 2 q r
-> Line
     (Dimension (LineSegment 2 q r)) (NumType (LineSegment 2 q r))
forall t.
HasSupportingLine t =>
t -> Line (Dimension t) (NumType t)
supportingLine LineSegment 2 q r
s Line 2 r -> l -> Line 2 r :+ l
forall core extra. core -> extra -> core :+ extra
:+ l
forall a. HasCallStack => a
undefined
                         in ((Point 2 r, Line 2 r :+ l) -> Point 2 r)
-> [(Point 2 r, Line 2 r :+ l)] -> [(Point 2 r, Line 2 r :+ l)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
List.sortOn (Point 2 r, Line 2 r :+ l) -> Point 2 r
forall a b. (a, b) -> a
fst ([(Point 2 r, Line 2 r :+ l)] -> [(Point 2 r, Line 2 r :+ l)])
-> ([Line 2 r :+ l] -> [(Point 2 r, Line 2 r :+ l)])
-> [Line 2 r :+ l]
-> [(Point 2 r, Line 2 r :+ l)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Point 2 r, Line 2 r :+ l) -> Bool)
-> [(Point 2 r, Line 2 r :+ l)] -> [(Point 2 r, Line 2 r :+ l)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Point 2 r -> LineSegment 2 q r -> Bool
forall g h. IsIntersectableWith g h => g -> h -> Bool
`intersects` LineSegment 2 q r
s) (Point 2 r -> Bool)
-> ((Point 2 r, Line 2 r :+ l) -> Point 2 r)
-> (Point 2 r, Line 2 r :+ l)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Point 2 r, Line 2 r :+ l) -> Point 2 r
forall a b. (a, b) -> a
fst)
                          ([(Point 2 r, Line 2 r :+ l)] -> [(Point 2 r, Line 2 r :+ l)])
-> ([Line 2 r :+ l] -> [(Point 2 r, Line 2 r :+ l)])
-> [Line 2 r :+ l]
-> [(Point 2 r, Line 2 r :+ l)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Line 2 r :+ l) -> Maybe (Point 2 r, Line 2 r :+ l))
-> [Line 2 r :+ l] -> [(Point 2 r, Line 2 r :+ l)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\Line 2 r :+ l
m -> (,Line 2 r :+ l
m) (Point 2 r -> (Point 2 r, Line 2 r :+ l))
-> Maybe (Point 2 r) -> Maybe (Point 2 r, Line 2 r :+ l)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Line 2 r :+ l
l (Line 2 r :+ l) -> (Line 2 r :+ l) -> Maybe (Point 2 r)
forall r l.
(Ord r, Fractional r) =>
(Line 2 r :+ l) -> (Line 2 r :+ l) -> Maybe (Point 2 r)
`intersectionPoint` Line 2 r :+ l
m) ([Line 2 r :+ l] -> [(Point 2 r, Line 2 r :+ l)])
-> [Line 2 r :+ l] -> [(Point 2 r, Line 2 r :+ l)]
forall a b. (a -> b) -> a -> b
$ [Line 2 r :+ l]
ls

-- | Constructs the unbounded intersections. Reported in clockwise direction.
unBoundedParts         :: (Ord r, Fractional r)
                       => Rectangle () r
                       -> [Line 2 r :+ l]
                       -> [(Point 2 r, Maybe (Line 2 r :+ l))]
unBoundedParts :: Rectangle () r
-> [Line 2 r :+ l] -> [(Point 2 r, Maybe (Line 2 r :+ l))]
unBoundedParts Rectangle () r
rect [Line 2 r :+ l]
ls = [(Point 2 r, Maybe (Line 2 r :+ l))
tl] [(Point 2 r, Maybe (Line 2 r :+ l))]
-> [(Point 2 r, Maybe (Line 2 r :+ l))]
-> [(Point 2 r, Maybe (Line 2 r :+ l))]
forall a. Semigroup a => a -> a -> a
<> [(Point 2 r, Maybe (Line 2 r :+ l))]
t [(Point 2 r, Maybe (Line 2 r :+ l))]
-> [(Point 2 r, Maybe (Line 2 r :+ l))]
-> [(Point 2 r, Maybe (Line 2 r :+ l))]
forall a. Semigroup a => a -> a -> a
<> [(Point 2 r, Maybe (Line 2 r :+ l))
tr] [(Point 2 r, Maybe (Line 2 r :+ l))]
-> [(Point 2 r, Maybe (Line 2 r :+ l))]
-> [(Point 2 r, Maybe (Line 2 r :+ l))]
forall a. Semigroup a => a -> a -> a
<> [(Point 2 r, Maybe (Line 2 r :+ l))]
-> [(Point 2 r, Maybe (Line 2 r :+ l))]
forall a. [a] -> [a]
reverse [(Point 2 r, Maybe (Line 2 r :+ l))]
r [(Point 2 r, Maybe (Line 2 r :+ l))]
-> [(Point 2 r, Maybe (Line 2 r :+ l))]
-> [(Point 2 r, Maybe (Line 2 r :+ l))]
forall a. Semigroup a => a -> a -> a
<> [(Point 2 r, Maybe (Line 2 r :+ l))
br] [(Point 2 r, Maybe (Line 2 r :+ l))]
-> [(Point 2 r, Maybe (Line 2 r :+ l))]
-> [(Point 2 r, Maybe (Line 2 r :+ l))]
forall a. Semigroup a => a -> a -> a
<> [(Point 2 r, Maybe (Line 2 r :+ l))]
-> [(Point 2 r, Maybe (Line 2 r :+ l))]
forall a. [a] -> [a]
reverse [(Point 2 r, Maybe (Line 2 r :+ l))]
b [(Point 2 r, Maybe (Line 2 r :+ l))]
-> [(Point 2 r, Maybe (Line 2 r :+ l))]
-> [(Point 2 r, Maybe (Line 2 r :+ l))]
forall a. Semigroup a => a -> a -> a
<> [(Point 2 r, Maybe (Line 2 r :+ l))
bl] [(Point 2 r, Maybe (Line 2 r :+ l))]
-> [(Point 2 r, Maybe (Line 2 r :+ l))]
-> [(Point 2 r, Maybe (Line 2 r :+ l))]
forall a. Semigroup a => a -> a -> a
<> [(Point 2 r, Maybe (Line 2 r :+ l))]
l
  where
    sideIntersections' :: LineSegment 2 () r -> [(Point 2 r, Maybe (Line 2 r :+ l))]
sideIntersections' = ASetter
  [(Point 2 r, Line 2 r :+ l)]
  [(Point 2 r, Maybe (Line 2 r :+ l))]
  (Line 2 r :+ l)
  (Maybe (Line 2 r :+ l))
-> ((Line 2 r :+ l) -> Maybe (Line 2 r :+ l))
-> [(Point 2 r, Line 2 r :+ l)]
-> [(Point 2 r, Maybe (Line 2 r :+ l))]
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over (((Point 2 r, Line 2 r :+ l)
 -> Identity (Point 2 r, Maybe (Line 2 r :+ l)))
-> [(Point 2 r, Line 2 r :+ l)]
-> Identity [(Point 2 r, Maybe (Line 2 r :+ l))]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse(((Point 2 r, Line 2 r :+ l)
  -> Identity (Point 2 r, Maybe (Line 2 r :+ l)))
 -> [(Point 2 r, Line 2 r :+ l)]
 -> Identity [(Point 2 r, Maybe (Line 2 r :+ l))])
-> (((Line 2 r :+ l) -> Identity (Maybe (Line 2 r :+ l)))
    -> (Point 2 r, Line 2 r :+ l)
    -> Identity (Point 2 r, Maybe (Line 2 r :+ l)))
-> ASetter
     [(Point 2 r, Line 2 r :+ l)]
     [(Point 2 r, Maybe (Line 2 r :+ l))]
     (Line 2 r :+ l)
     (Maybe (Line 2 r :+ l))
forall b c a. (b -> c) -> (a -> b) -> a -> c
.((Line 2 r :+ l) -> Identity (Maybe (Line 2 r :+ l)))
-> (Point 2 r, Line 2 r :+ l)
-> Identity (Point 2 r, Maybe (Line 2 r :+ l))
forall s t a b. Field2 s t a b => Lens s t a b
_2) (Line 2 r :+ l) -> Maybe (Line 2 r :+ l)
forall a. a -> Maybe a
Just ([(Point 2 r, Line 2 r :+ l)]
 -> [(Point 2 r, Maybe (Line 2 r :+ l))])
-> (LineSegment 2 () r -> [(Point 2 r, Line 2 r :+ l)])
-> LineSegment 2 () r
-> [(Point 2 r, Maybe (Line 2 r :+ l))]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Line 2 r :+ l]
-> LineSegment 2 () r -> [(Point 2 r, Line 2 r :+ l)]
forall r l q.
(Ord r, Fractional r) =>
[Line 2 r :+ l]
-> LineSegment 2 q r -> [(Point 2 r, Line 2 r :+ l)]
sideIntersections [Line 2 r :+ l]
ls
    Sides [(Point 2 r, Maybe (Line 2 r :+ l))]
t [(Point 2 r, Maybe (Line 2 r :+ l))]
r [(Point 2 r, Maybe (Line 2 r :+ l))]
b [(Point 2 r, Maybe (Line 2 r :+ l))]
l       = LineSegment 2 () r -> [(Point 2 r, Maybe (Line 2 r :+ l))]
sideIntersections'    (LineSegment 2 () r -> [(Point 2 r, Maybe (Line 2 r :+ l))])
-> Sides (LineSegment 2 () r)
-> Sides [(Point 2 r, Maybe (Line 2 r :+ l))]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Rectangle () r -> Sides (LineSegment 2 () r)
forall r p. Num r => Rectangle p r -> Sides (LineSegment 2 p r)
sides   Rectangle () r
rect
    Corners (Point 2 r, Maybe (Line 2 r :+ l))
tl (Point 2 r, Maybe (Line 2 r :+ l))
tr (Point 2 r, Maybe (Line 2 r :+ l))
br (Point 2 r, Maybe (Line 2 r :+ l))
bl = (,Maybe (Line 2 r :+ l)
forall a. Maybe a
Nothing) (Point 2 r -> (Point 2 r, Maybe (Line 2 r :+ l)))
-> ((Point 2 r :+ ()) -> Point 2 r)
-> (Point 2 r :+ ())
-> (Point 2 r, Maybe (Line 2 r :+ l))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Point 2 r :+ ())
-> Getting (Point 2 r) (Point 2 r :+ ()) (Point 2 r) -> Point 2 r
forall s a. s -> Getting a s a -> a
^.Getting (Point 2 r) (Point 2 r :+ ()) (Point 2 r)
forall core extra core'.
Lens (core :+ extra) (core' :+ extra) core core'
core) ((Point 2 r :+ ()) -> (Point 2 r, Maybe (Line 2 r :+ l)))
-> Corners (Point 2 r :+ ())
-> Corners (Point 2 r, Maybe (Line 2 r :+ l))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Rectangle () r -> Corners (Point 2 r :+ ())
forall r p. Num r => Rectangle p r -> Corners (Point 2 r :+ p)
corners Rectangle () r
rect


-- | Links the vertices  of the outer boundary with those in the subdivision
link       :: Eq r => [(Point 2 r, a)] -> PlanarSubdivision s v (Maybe e) f r
           -> V.Vector (Point 2 r, VertexId' s, a)
link :: [(Point 2 r, a)]
-> PlanarSubdivision s v (Maybe e) f r
-> Vector (Point 2 r, VertexId' s, a)
link [(Point 2 r, a)]
vs PlanarSubdivision s v (Maybe e) f r
ps = [(Point 2 r, VertexId' s, a)] -> Vector (Point 2 r, VertexId' s, a)
forall a. [a] -> Vector a
V.fromList ([(Point 2 r, VertexId' s, a)]
 -> Vector (Point 2 r, VertexId' s, a))
-> (Maybe (CSeq ((Point 2 r, a), (Point 2 r, VertexId' s)))
    -> [(Point 2 r, VertexId' s, a)])
-> Maybe (CSeq ((Point 2 r, a), (Point 2 r, VertexId' s)))
-> Vector (Point 2 r, VertexId' s, a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (((Point 2 r, a), (Point 2 r, VertexId' s))
 -> (Point 2 r, VertexId' s, a))
-> [((Point 2 r, a), (Point 2 r, VertexId' s))]
-> [(Point 2 r, VertexId' s, a)]
forall a b. (a -> b) -> [a] -> [b]
map (\((Point 2 r
p,a
x),(Point 2 r
_,VertexId' s
y)) -> (Point 2 r
p,VertexId' s
y,a
x)) ([((Point 2 r, a), (Point 2 r, VertexId' s))]
 -> [(Point 2 r, VertexId' s, a)])
-> (Maybe (CSeq ((Point 2 r, a), (Point 2 r, VertexId' s)))
    -> [((Point 2 r, a), (Point 2 r, VertexId' s))])
-> Maybe (CSeq ((Point 2 r, a), (Point 2 r, VertexId' s)))
-> [(Point 2 r, VertexId' s, a)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CSeq ((Point 2 r, a), (Point 2 r, VertexId' s))
-> [((Point 2 r, a), (Point 2 r, VertexId' s))]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList
           (CSeq ((Point 2 r, a), (Point 2 r, VertexId' s))
 -> [((Point 2 r, a), (Point 2 r, VertexId' s))])
-> (Maybe (CSeq ((Point 2 r, a), (Point 2 r, VertexId' s)))
    -> CSeq ((Point 2 r, a), (Point 2 r, VertexId' s)))
-> Maybe (CSeq ((Point 2 r, a), (Point 2 r, VertexId' s)))
-> [((Point 2 r, a), (Point 2 r, VertexId' s))]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe (CSeq ((Point 2 r, a), (Point 2 r, VertexId' s)))
-> CSeq ((Point 2 r, a), (Point 2 r, VertexId' s))
forall a. Maybe a -> a
fromJust' (Maybe (CSeq ((Point 2 r, a), (Point 2 r, VertexId' s)))
 -> Vector (Point 2 r, VertexId' s, a))
-> Maybe (CSeq ((Point 2 r, a), (Point 2 r, VertexId' s)))
-> Vector (Point 2 r, VertexId' s, a)
forall a b. (a -> b) -> a -> b
$ ((Point 2 r, a) -> (Point 2 r, VertexId' s) -> Bool)
-> CSeq (Point 2 r, a)
-> CSeq (Point 2 r, VertexId' s)
-> Maybe (CSeq ((Point 2 r, a), (Point 2 r, VertexId' s)))
forall a b.
(a -> b -> Bool) -> CSeq a -> CSeq b -> Maybe (CSeq (a, b))
alignWith (\(Point 2 r
p,a
_) (Point 2 r
q,VertexId' s
_) -> Point 2 r
p Point 2 r -> Point 2 r -> Bool
forall a. Eq a => a -> a -> Bool
== Point 2 r
q) ([(Point 2 r, a)] -> CSeq (Point 2 r, a)
forall a. [a] -> CSeq a
CSeq.fromList [(Point 2 r, a)]
vs) CSeq (Point 2 r, VertexId' s)
vs'
  where
    vs' :: CSeq (Point 2 r, VertexId' s)
vs' = [(Point 2 r, VertexId' s)] -> CSeq (Point 2 r, VertexId' s)
forall a. [a] -> CSeq a
CSeq.fromList ([(Point 2 r, VertexId' s)] -> CSeq (Point 2 r, VertexId' s))
-> (Vector (VertexId' s) -> [(Point 2 r, VertexId' s)])
-> Vector (VertexId' s)
-> CSeq (Point 2 r, VertexId' s)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (VertexId' s -> (Point 2 r, VertexId' s))
-> [VertexId' s] -> [(Point 2 r, VertexId' s)]
forall a b. (a -> b) -> [a] -> [b]
map (\VertexId' s
v -> (PlanarSubdivision s v (Maybe e) f r
psPlanarSubdivision s v (Maybe e) f r
-> Getting
     (Point 2 r) (PlanarSubdivision s v (Maybe e) f r) (Point 2 r)
-> Point 2 r
forall s a. s -> Getting a s a -> a
^.VertexId' s
-> Lens' (PlanarSubdivision s v (Maybe e) f r) (Point 2 r)
forall k (s :: k) v e f r.
VertexId' s -> Lens' (PlanarSubdivision s v e f r) (Point 2 r)
locationOf VertexId' s
v,VertexId' s
v) ) ([VertexId' s] -> [(Point 2 r, VertexId' s)])
-> (Vector (VertexId' s) -> [VertexId' s])
-> Vector (VertexId' s)
-> [(Point 2 r, VertexId' s)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vector (VertexId' s) -> [VertexId' s]
forall a. Vector a -> [a]
V.toList
        (Vector (VertexId' s) -> CSeq (Point 2 r, VertexId' s))
-> Vector (VertexId' s) -> CSeq (Point 2 r, VertexId' s)
forall a b. (a -> b) -> a -> b
$ FaceId' s
-> PlanarSubdivision s v (Maybe e) f r -> Vector (VertexId' s)
forall k (s :: k) v e f r.
FaceId' s -> PlanarSubdivision s v e f r -> Vector (VertexId' s)
boundaryVertices (PlanarSubdivision s v (Maybe e) f r -> FaceId' s
forall k (s :: k) v e f r. PlanarSubdivision s v e f r -> FaceId' s
outerFaceId PlanarSubdivision s v (Maybe e) f r
ps) PlanarSubdivision s v (Maybe e) f r
ps
    fromJust' :: Maybe a -> a
fromJust' = a -> Maybe a -> a
forall a. a -> Maybe a -> a
fromMaybe (String -> a
forall a. HasCallStack => String -> a
error String
"Data.Geometry.Arrangement.link: fromJust")

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

makePairs :: [a] -> [(a,[a])]
makePairs :: [a] -> [(a, [a])]
makePairs = [a] -> [(a, [a])]
forall a. [a] -> [(a, [a])]
go
  where
    go :: [a] -> [(a, [a])]
go []     = []
    go (a
x:[a]
xs) = (a
x,[a]
xs) (a, [a]) -> [(a, [a])] -> [(a, [a])]
forall a. a -> [a] -> [a]
: ((a, [a]) -> (a, [a])) -> [(a, [a])] -> [(a, [a])]
forall a b. (a -> b) -> [a] -> [b]
map (([a] -> [a]) -> (a, [a]) -> (a, [a])
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:)) ([a] -> [(a, [a])]
go [a]
xs)

allPairs :: [a] -> [(a,a)]
allPairs :: [a] -> [(a, a)]
allPairs = [a] -> [(a, a)]
forall a. [a] -> [(a, a)]
go
  where
    go :: [t] -> [(t, t)]
go []     = []
    go (t
x:[t]
xs) = (t -> (t, t)) -> [t] -> [(t, t)]
forall a b. (a -> b) -> [a] -> [b]
map (t
x,) [t]
xs [(t, t)] -> [(t, t)] -> [(t, t)]
forall a. [a] -> [a] -> [a]
++ [t] -> [(t, t)]
go [t]
xs

-- | Given a predicate that tests if two elements of a CSeq match, find a
-- rotation of the seqs such at they match.
--
-- Running time: \(O(n)\)
alignWith         :: (a -> b -> Bool) -> CSeq.CSeq a -> CSeq.CSeq b
                  -> Maybe (CSeq.CSeq (a,b))
alignWith :: (a -> b -> Bool) -> CSeq a -> CSeq b -> Maybe (CSeq (a, b))
alignWith a -> b -> Bool
p CSeq a
xs CSeq b
ys = CSeq a -> CSeq b -> CSeq (a, b)
forall a b. CSeq a -> CSeq b -> CSeq (a, b)
CSeq.zipL CSeq a
xs (CSeq b -> CSeq (a, b)) -> Maybe (CSeq b) -> Maybe (CSeq (a, b))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (b -> Bool) -> CSeq b -> Maybe (CSeq b)
forall a. (a -> Bool) -> CSeq a -> Maybe (CSeq a)
CSeq.findRotateTo (a -> b -> Bool
p (CSeq a -> a
forall a. CSeq a -> a
CSeq.focus CSeq a
xs)) CSeq b
ys

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

-- | Given an Arrangement and a line in the arrangement, follow the line
-- through he arrangement.
--
traverseLine       :: (Ord r, Fractional r)
                   => Line 2 r -> Arrangement s l v (Maybe e) f r -> [Dart s]
traverseLine :: Line 2 r -> Arrangement s l v (Maybe e) f r -> [Dart s]
traverseLine Line 2 r
l Arrangement s l v (Maybe e) f r
arr = let md :: Maybe (Dart s)
md    = Line 2 r -> Arrangement s l v (Maybe e) f r -> Maybe (Dart s)
forall k (s :: k) l v e f r.
(Ord r, Fractional r) =>
Line 2 r -> Arrangement s l v (Maybe e) f r -> Maybe (Dart s)
findStart Line 2 r
l Arrangement s l v (Maybe e) f r
arr
                         dup :: b -> (b, b)
dup b
x = (b
x,b
x)
                     in [Dart s] -> (Dart s -> [Dart s]) -> Maybe (Dart s) -> [Dart s]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] ((Dart s -> Maybe (Dart s, Dart s)) -> Dart s -> [Dart s]
forall b a. (b -> Maybe (a, b)) -> b -> [a]
List.unfoldr ((Dart s -> (Dart s, Dart s))
-> Maybe (Dart s) -> Maybe (Dart s, Dart s)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Dart s -> (Dart s, Dart s)
forall b. b -> (b, b)
dup (Maybe (Dart s) -> Maybe (Dart s, Dart s))
-> (Dart s -> Maybe (Dart s)) -> Dart s -> Maybe (Dart s, Dart s)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Arrangement s l v (Maybe e) f r -> Dart s -> Maybe (Dart s)
forall k r (s :: k) l v e f.
(Ord r, Num r) =>
Arrangement s l v e f r -> Dart s -> Maybe (Dart s)
follow Arrangement s l v (Maybe e) f r
arr)) Maybe (Dart s)
md

-- | Find the starting point of the line  the arrangement
findStart       :: forall s l v e f r. (Ord r, Fractional r)
                => Line 2 r -> Arrangement s l v (Maybe e) f r -> Maybe (Dart s)
findStart :: Line 2 r -> Arrangement s l v (Maybe e) f r -> Maybe (Dart s)
findStart Line 2 r
l Arrangement s l v (Maybe e) f r
arr = do
    (Point 2 r
p,Point 2 r
_)   <- forall (ts :: [*]).
NatToInt (RIndex (Point 2 r, Point 2 r) ts) =>
CoRec Identity ts -> Maybe (Point 2 r, Point 2 r)
forall t (ts :: [*]).
NatToInt (RIndex t ts) =>
CoRec Identity ts -> Maybe t
asA @(Point 2 r, Point 2 r) (CoRec
   Identity
   '[NoIntersection, Point 2 r, (Point 2 r, Point 2 r),
     LineSegment 2 () r]
 -> Maybe (Point 2 r, Point 2 r))
-> CoRec
     Identity
     '[NoIntersection, Point 2 r, (Point 2 r, Point 2 r),
       LineSegment 2 () r]
-> Maybe (Point 2 r, Point 2 r)
forall a b. (a -> b) -> a -> b
$
                 Line 2 r
l Line 2 r
-> Boundary (Rectangle () r)
-> Intersection (Line 2 r) (Boundary (Rectangle () r))
forall g h. IsIntersectableWith g h => g -> h -> Intersection g h
`intersect` Rectangle () r -> Boundary (Rectangle () r)
forall g. g -> Boundary g
Boundary (Arrangement s l v (Maybe e) f r
arrArrangement s l v (Maybe e) f r
-> Getting
     (Rectangle () r) (Arrangement s l v (Maybe e) f r) (Rectangle () r)
-> Rectangle () r
forall s a. s -> Getting a s a -> a
^.Getting
  (Rectangle () r) (Arrangement s l v (Maybe e) f r) (Rectangle () r)
forall k (s :: k) l v e f r.
Lens' (Arrangement s l v e f r) (Rectangle () r)
boundedArea)
    (Point 2 r
_,VertexId' s
v,Maybe (Line 2 r :+ l)
_) <- Point 2 r
-> Arrangement s l v (Maybe e) f r
-> Maybe (Point 2 r, VertexId' s, Maybe (Line 2 r :+ l))
forall k r (s :: k) l v e f.
(Ord r, Fractional r) =>
Point 2 r
-> Arrangement s l v e f r
-> Maybe (Point 2 r, VertexId' s, Maybe (Line 2 r :+ l))
findStartVertex Point 2 r
p Arrangement s l v (Maybe e) f r
arr
    PlanarSubdivision s v (Maybe e) f r
-> VertexId' s -> Maybe (Dart s)
forall k (s :: k) v e f r.
PlanarSubdivision s v (Maybe e) f r
-> VertexId' s -> Maybe (Dart s)
findStartDart (Arrangement s l v (Maybe e) f r
arrArrangement s l v (Maybe e) f r
-> Getting
     (PlanarSubdivision s v (Maybe e) f r)
     (Arrangement s l v (Maybe e) f r)
     (PlanarSubdivision s v (Maybe e) f r)
-> PlanarSubdivision s v (Maybe e) f r
forall s a. s -> Getting a s a -> a
^.Getting
  (PlanarSubdivision s v (Maybe e) f r)
  (Arrangement s l v (Maybe e) f r)
  (PlanarSubdivision s v (Maybe e) f r)
forall k (s :: k) l v e f r v e f.
Lens
  (Arrangement s l v e f r)
  (Arrangement s l v e f r)
  (PlanarSubdivision s v e f r)
  (PlanarSubdivision s v e f r)
subdivision) VertexId' s
v



-- | Given a point on the boundary of the boundedArea box; find the vertex
--  this point corresponds to.
--
-- running time: \(O(\log n)\)
--
-- basically; maps every point to a tuple of the point and the side the
-- point occurs on. We then binary search to find the point we are looking
-- for.
findStartVertex       :: (Ord r, Fractional r)
                      => Point 2 r
                      -> Arrangement s l v e f r
                      -> Maybe (Point 2 r, VertexId' s, Maybe (Line 2 r :+ l))
findStartVertex :: Point 2 r
-> Arrangement s l v e f r
-> Maybe (Point 2 r, VertexId' s, Maybe (Line 2 r :+ l))
findStartVertex Point 2 r
p Arrangement s l v e f r
arr = do
    Integer
ss <- Point 2 r -> Maybe Integer
findSide Point 2 r
p
    Int
i  <- (Elem (ArrangementBoundary s l r) -> Bool)
-> ArrangementBoundary s l r
-> Maybe (Index (ArrangementBoundary s l r))
forall v.
BinarySearch v =>
(Elem v -> Bool) -> v -> Maybe (Index v)
binarySearchIdxIn (Integer -> (Point 2 r, VertexId' s, Maybe (Line 2 r :+ l)) -> Bool
pred' Integer
ss) (Arrangement s l v e f r
arrArrangement s l v e f r
-> Getting
     (ArrangementBoundary s l r)
     (Arrangement s l v e f r)
     (ArrangementBoundary s l r)
-> ArrangementBoundary s l r
forall s a. s -> Getting a s a -> a
^.Getting
  (ArrangementBoundary s l r)
  (Arrangement s l v e f r)
  (ArrangementBoundary s l r)
forall k (s :: k) l v e f r.
Lens' (Arrangement s l v e f r) (ArrangementBoundary s l r)
unboundedIntersections)
    (Point 2 r, VertexId' s, Maybe (Line 2 r :+ l))
-> Maybe (Point 2 r, VertexId' s, Maybe (Line 2 r :+ l))
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Point 2 r, VertexId' s, Maybe (Line 2 r :+ l))
 -> Maybe (Point 2 r, VertexId' s, Maybe (Line 2 r :+ l)))
-> (Point 2 r, VertexId' s, Maybe (Line 2 r :+ l))
-> Maybe (Point 2 r, VertexId' s, Maybe (Line 2 r :+ l))
forall a b. (a -> b) -> a -> b
$ Arrangement s l v e f r
arrArrangement s l v e f r
-> Getting
     (Point 2 r, VertexId' s, Maybe (Line 2 r :+ l))
     (Arrangement s l v e f r)
     (Point 2 r, VertexId' s, Maybe (Line 2 r :+ l))
-> (Point 2 r, VertexId' s, Maybe (Line 2 r :+ l))
forall s a. s -> Getting a s a -> a
^.(ArrangementBoundary s l r
 -> Const
      (Point 2 r, VertexId' s, Maybe (Line 2 r :+ l))
      (ArrangementBoundary s l r))
-> Arrangement s l v e f r
-> Const
     (Point 2 r, VertexId' s, Maybe (Line 2 r :+ l))
     (Arrangement s l v e f r)
forall k (s :: k) l v e f r.
Lens' (Arrangement s l v e f r) (ArrangementBoundary s l r)
unboundedIntersections((ArrangementBoundary s l r
  -> Const
       (Point 2 r, VertexId' s, Maybe (Line 2 r :+ l))
       (ArrangementBoundary s l r))
 -> Arrangement s l v e f r
 -> Const
      (Point 2 r, VertexId' s, Maybe (Line 2 r :+ l))
      (Arrangement s l v e f r))
-> (((Point 2 r, VertexId' s, Maybe (Line 2 r :+ l))
     -> Const
          (Point 2 r, VertexId' s, Maybe (Line 2 r :+ l))
          (Point 2 r, VertexId' s, Maybe (Line 2 r :+ l)))
    -> ArrangementBoundary s l r
    -> Const
         (Point 2 r, VertexId' s, Maybe (Line 2 r :+ l))
         (ArrangementBoundary s l r))
-> Getting
     (Point 2 r, VertexId' s, Maybe (Line 2 r :+ l))
     (Arrangement s l v e f r)
     (Point 2 r, VertexId' s, Maybe (Line 2 r :+ l))
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Traversing
  (->)
  (Const (Point 2 r, VertexId' s, Maybe (Line 2 r :+ l)))
  (ArrangementBoundary s l r)
  (ArrangementBoundary s l r)
  (Point 2 r, VertexId' s, Maybe (Line 2 r :+ l))
  (Point 2 r, VertexId' s, Maybe (Line 2 r :+ l))
-> ((Point 2 r, VertexId' s, Maybe (Line 2 r :+ l))
    -> Const
         (Point 2 r, VertexId' s, Maybe (Line 2 r :+ l))
         (Point 2 r, VertexId' s, Maybe (Line 2 r :+ l)))
-> ArrangementBoundary s l r
-> Const
     (Point 2 r, VertexId' s, Maybe (Line 2 r :+ l))
     (ArrangementBoundary s l r)
forall (p :: * -> * -> *) (f :: * -> *) s t a.
(HasCallStack, Conjoined p, Functor f) =>
Traversing p f s t a a -> Over p f s t a a
singular (Index (ArrangementBoundary s l r)
-> Traversal'
     (ArrangementBoundary s l r) (IxValue (ArrangementBoundary s l r))
forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix Int
Index (ArrangementBoundary s l r)
i)
  where
    Sides LineSegment 2 () r
t LineSegment 2 () r
r LineSegment 2 () r
b LineSegment 2 () r
l = Rectangle () r -> Sides (LineSegment 2 () r)
forall p. Rectangle p r -> Sides (LineSegment 2 p r)
sides'' (Rectangle () r -> Sides (LineSegment 2 () r))
-> Rectangle () r -> Sides (LineSegment 2 () r)
forall a b. (a -> b) -> a -> b
$ Arrangement s l v e f r
arrArrangement s l v e f r
-> Getting
     (Rectangle () r) (Arrangement s l v e f r) (Rectangle () r)
-> Rectangle () r
forall s a. s -> Getting a s a -> a
^.Getting (Rectangle () r) (Arrangement s l v e f r) (Rectangle () r)
forall k (s :: k) l v e f r.
Lens' (Arrangement s l v e f r) (Rectangle () r)
boundedArea
    sides'' :: Rectangle p r -> Sides (LineSegment 2 p r)
sides''       = (LineSegment 2 p r -> LineSegment 2 p r)
-> Sides (LineSegment 2 p r) -> Sides (LineSegment 2 p r)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(ClosedLineSegment Point 2 r :+ p
a Point 2 r :+ p
c) -> 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 ((Point 2 r :+ p) -> EndPoint (Point 2 r :+ p)
forall a. a -> EndPoint a
Closed Point 2 r :+ p
a) ((Point 2 r :+ p) -> EndPoint (Point 2 r :+ p)
forall a. a -> EndPoint a
Open Point 2 r :+ p
c)) (Sides (LineSegment 2 p r) -> Sides (LineSegment 2 p r))
-> (Rectangle p r -> Sides (LineSegment 2 p r))
-> Rectangle p r
-> Sides (LineSegment 2 p r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rectangle p r -> Sides (LineSegment 2 p r)
forall r p. Num r => Rectangle p r -> Sides (LineSegment 2 p r)
sides

    findSide :: Point 2 r -> Maybe Integer
findSide Point 2 r
q = ((Integer, LineSegment 2 () r) -> Integer)
-> Maybe (Integer, LineSegment 2 () r) -> Maybe Integer
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Integer, LineSegment 2 () r) -> Integer
forall a b. (a, b) -> a
fst (Maybe (Integer, LineSegment 2 () r) -> Maybe Integer)
-> ([(Integer, LineSegment 2 () r)]
    -> Maybe (Integer, LineSegment 2 () r))
-> [(Integer, LineSegment 2 () r)]
-> Maybe Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Integer, LineSegment 2 () r) -> Bool)
-> [(Integer, LineSegment 2 () r)]
-> Maybe (Integer, LineSegment 2 () r)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find (Point 2 r -> LineSegment 2 () r -> Bool
forall g h. IsIntersectableWith g h => g -> h -> Bool
intersects Point 2 r
q(LineSegment 2 () r -> Bool)
-> ((Integer, LineSegment 2 () r) -> LineSegment 2 () r)
-> (Integer, LineSegment 2 () r)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Integer, LineSegment 2 () r) -> LineSegment 2 () r
forall a b. (a, b) -> b
snd) ([(Integer, LineSegment 2 () r)] -> Maybe Integer)
-> [(Integer, LineSegment 2 () r)] -> Maybe Integer
forall a b. (a -> b) -> a -> b
$ [Integer]
-> [LineSegment 2 () r] -> [(Integer, LineSegment 2 () r)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Integer
1..] [LineSegment 2 () r
t,LineSegment 2 () r
r,LineSegment 2 () r
b,LineSegment 2 () r
l]

    pred' :: Integer -> (Point 2 r, VertexId' s, Maybe (Line 2 r :+ l)) -> Bool
pred' Integer
ss (Point 2 r
q,VertexId' s
_,Maybe (Line 2 r :+ l)
_) = let Just Integer
j = Point 2 r -> Maybe Integer
findSide Point 2 r
q
                           x :: Ordering
x      = (Integer, Point 2 r) -> (Integer, Point 2 r) -> Ordering
forall a a. (Num a, Ord a, Ord a) => (a, a) -> (a, a) -> Ordering
before (Integer
ss,Point 2 r
p) (Integer
j,Point 2 r
q)
                       in  Ordering
x Ordering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
== Ordering
LT Bool -> Bool -> Bool
|| Ordering
x Ordering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
== Ordering
EQ

    before :: (a, a) -> (a, a) -> Ordering
before (a
i,a
p') (a
j,a
q') = case a
i a -> a -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` a
j of
                                Ordering
LT -> Ordering
LT
                                Ordering
GT -> Ordering
GT
                                Ordering
EQ | a
i a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
2 Bool -> Bool -> Bool
|| a
i a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
3 -> a -> Down a
forall a. a -> Down a
Down a
p' Down a -> Down a -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` a -> Down a
forall a. a -> Down a
Down a
q'
                                   | Bool
otherwise        -> a
p' a -> a -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` a
q'


-- | Find the starting dart of the given vertex v. Reports a dart s.t.
-- tailOf d = v
--
-- running me: \(O(k)\) where \(k\) is the degree of the vertex
findStartDart      :: PlanarSubdivision s v (Maybe e) f r -> VertexId' s -> Maybe (Dart s)
findStartDart :: PlanarSubdivision s v (Maybe e) f r
-> VertexId' s -> Maybe (Dart s)
findStartDart PlanarSubdivision s v (Maybe e) f r
ps VertexId' s
v = (Dart s -> Bool) -> Vector (Dart s) -> Maybe (Dart s)
forall a. (a -> Bool) -> Vector a -> Maybe a
V.find (\Dart s
d -> Maybe e -> Bool
forall a. Maybe a -> Bool
isJust (Maybe e -> Bool) -> Maybe e -> Bool
forall a b. (a -> b) -> a -> b
$ PlanarSubdivision s v (Maybe e) f r
psPlanarSubdivision s v (Maybe e) f r
-> Getting
     (Maybe e) (PlanarSubdivision s v (Maybe e) f r) (Maybe e)
-> Maybe e
forall s a. s -> Getting a s a -> a
^.Dart s
-> Lens'
     (PlanarSubdivision s v (Maybe e) f r)
     (DataOf (PlanarSubdivision s v (Maybe e) f r) (Dart s))
forall g i. HasDataOf g i => i -> Lens' g (DataOf g i)
dataOf Dart s
d) (Vector (Dart s) -> Maybe (Dart s))
-> Vector (Dart s) -> Maybe (Dart s)
forall a b. (a -> b) -> a -> b
$ VertexId' s
-> PlanarSubdivision s v (Maybe e) f r -> Vector (Dart s)
forall k (s :: k) v e f r.
VertexId' s -> PlanarSubdivision s v e f r -> Vector (Dart s)
incidentEdges VertexId' s
v PlanarSubdivision s v (Maybe e) f r
ps
    -- the "real" dart is the one that has ata associated to it.


-- | Given a dart d that incoming to v (headOf d == v), find the outgoing dart
-- colinear with the incoming one. Again reports dart d' s.t. tailOf d' = v
--
-- running time: \(O(k)\), where k is the degree of the vertex d points to
follow       :: (Ord r, Num r) => Arrangement s l v e f r -> Dart s -> Maybe (Dart s)
follow :: Arrangement s l v e f r -> Dart s -> Maybe (Dart s)
follow Arrangement s l v e f r
arr Dart s
d = (Dart s -> Bool) -> Vector (Dart s) -> Maybe (Dart s)
forall a. (a -> Bool) -> Vector a -> Maybe a
V.find Dart s -> Bool
extends (Vector (Dart s) -> Maybe (Dart s))
-> Vector (Dart s) -> Maybe (Dart s)
forall a b. (a -> b) -> a -> b
$ VertexId' s -> PlanarSubdivision s v e f r -> Vector (Dart s)
forall k (s :: k) v e f r.
VertexId' s -> PlanarSubdivision s v e f r -> Vector (Dart s)
incidentEdges VertexId' s
v PlanarSubdivision s v e f r
ps
  where
    ps :: PlanarSubdivision s v e f r
ps = Arrangement s l v e f r
arrArrangement s l v e f r
-> Getting
     (PlanarSubdivision s v e f r)
     (Arrangement s l v e f r)
     (PlanarSubdivision s v e f r)
-> PlanarSubdivision s v e f r
forall s a. s -> Getting a s a -> a
^.Getting
  (PlanarSubdivision s v e f r)
  (Arrangement s l v e f r)
  (PlanarSubdivision s v e f r)
forall k (s :: k) l v e f r v e f.
Lens
  (Arrangement s l v e f r)
  (Arrangement s l v e f r)
  (PlanarSubdivision s v e f r)
  (PlanarSubdivision s v e f r)
subdivision
    v :: VertexId' s
v  = Dart s -> PlanarSubdivision s v e f r -> VertexId' s
forall k (s :: k) v e f r.
Dart s -> PlanarSubdivision s v e f r -> VertexId' s
headOf Dart s
d PlanarSubdivision s v e f r
ps
    (Point 2 r
up,Point 2 r
vp) = ASetter
  (VertexData r v, VertexData r v)
  (Point 2 r, Point 2 r)
  (VertexData r v)
  (Point 2 r)
-> (VertexData r v -> Point 2 r)
-> (VertexData r v, VertexData r v)
-> (Point 2 r, Point 2 r)
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter
  (VertexData r v, VertexData r v)
  (Point 2 r, Point 2 r)
  (VertexData r v)
  (Point 2 r)
forall (r :: * -> * -> *) a b.
Bitraversable r =>
Traversal (r a a) (r b b) a b
both (VertexData r v
-> Getting (Point 2 r) (VertexData r v) (Point 2 r) -> Point 2 r
forall s a. s -> Getting a s a -> a
^.Getting (Point 2 r) (VertexData r v) (Point 2 r)
forall r1 v r2.
Lens (VertexData r1 v) (VertexData r2 v) (Point 2 r1) (Point 2 r2)
location) ((VertexData r v, VertexData r v) -> (Point 2 r, Point 2 r))
-> (VertexData r v, VertexData r v) -> (Point 2 r, Point 2 r)
forall a b. (a -> b) -> a -> b
$ Dart s
-> PlanarSubdivision s v e f r -> (VertexData r v, VertexData r v)
forall k (s :: k) v e f r.
Dart s
-> PlanarSubdivision s v e f r -> (VertexData r v, VertexData r v)
endPointData Dart s
d PlanarSubdivision s v e f r
ps

    extends :: Dart s -> Bool
extends Dart s
d' = let wp :: Point 2 r
wp = PlanarSubdivision s v e f r
psPlanarSubdivision s v e f r
-> Getting (Point 2 r) (PlanarSubdivision s v e f r) (Point 2 r)
-> Point 2 r
forall s a. s -> Getting a s a -> a
^.VertexId' s -> Lens' (PlanarSubdivision s v e f r) (Point 2 r)
forall k (s :: k) v e f r.
VertexId' s -> Lens' (PlanarSubdivision s v e f r) (Point 2 r)
locationOf (Dart s -> PlanarSubdivision s v e f r -> VertexId' s
forall k (s :: k) v e f r.
Dart s -> PlanarSubdivision s v e f r -> VertexId' s
headOf Dart s
d' PlanarSubdivision s v e f r
ps)
                 in Dart s
d' Dart s -> Dart s -> Bool
forall a. Eq a => a -> a -> Bool
/= Dart s -> Dart s
forall k (s :: k). Dart s -> Dart s
twin Dart s
d Bool -> Bool -> Bool
&& 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
up Point 2 r
vp Point 2 r
wp CCW -> CCW -> Bool
forall a. Eq a => a -> a -> Bool
== CCW
CoLinear

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

-- TODO: we can skip the findStart by just traversing from all boundary points

-- computeFaceData :: (Arrangement s v e f r -> Dart s -> f')
--                -> Arrangement s v e f r -> V.Vertex f'
-- computeFaceData arr f = fmap fromJust . V.create $ do
--                           v <- MV.replicate (arr^.subdivision.to numFaces) Nothing
--                           mapM_ (computeFaceData' arr f v) $ arr^.inputLines
--                           pure v


-- computeFaceData' arr f v l = mapM_ (assign ) traverseLine arr l

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