{-# LANGUAGE TemplateHaskell #-}
--------------------------------------------------------------------------------
-- |
-- Module      :  Algorithms.Geometry.VisibilityPolygon.Lee
-- Copyright   :  (C) Frank Staals
-- License     :  see the LICENSE file
-- Maintainer  :  Frank Staals
--
-- \(O(n\log n)\) time algorithm to compute the visibility polygon of
-- a point inside a polygon (possibly containing holes) with \(n\)
-- vertices, or among a set of \(n\) disjoint segments. The alogirhtm
-- used is the the rotational sweepline algorithm by Lee, described
-- in:
--
-- D. T. Lee. Proximity and reachability in the plane. Report R-831, Dept. Elect.
-- Engrg., Univ. Illinois, Urbana, IL, 1978.
--
--------------------------------------------------------------------------------
module Algorithms.Geometry.VisibilityPolygon.Lee
  ( visibilityPolygon
  , visibilitySweep
  , VisibilityPolygon
  , Definer, StarShapedPolygon
  , compareAroundEndPoint
  ) where

import           Control.Lens
import           Control.Monad ((<=<))
import           Data.Bifunctor (first)
import           Data.Ext
import qualified Data.Foldable as F
import           Data.Function (on)
import           Data.Geometry.HalfLine
import           Data.Geometry.Line
import           Data.Geometry.LineSegment
import           Data.Geometry.Point
import           Data.Geometry.Polygon
import           Data.Geometry.Vector
import           Data.Intersection
import qualified Data.List as List
import qualified Data.List.Util as List
import           Data.List.NonEmpty (NonEmpty(..))
import qualified Data.List.NonEmpty as NonEmpty
import           Data.Maybe (mapMaybe, isJust)
import           Data.Ord (comparing)
import           Data.RealNumber.Rational
import           Data.Semigroup.Foldable
import qualified Data.Set as Set
import qualified Data.Set.Util as Set
import           Data.Util
import           Data.Vinyl.CoRec
import           Debug.Trace

type R = RealNumber 5

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

type StarShapedPolygon p r = SimplePolygon p r

-- | Vertices of the visibility polgyon are either original vertices
-- or defined by some vertex and an edge
type Definer p e r = Either p (Point 2 r :+ p,LineSegment 2 p r :+ e)

type VisibilityPolygon p e r = StarShapedPolygon (Definer p e r) r

-- | We either insert or delete segments
data Action a = Insert a | Delete a deriving (Int -> Action a -> ShowS
[Action a] -> ShowS
Action a -> String
(Int -> Action a -> ShowS)
-> (Action a -> String) -> ([Action a] -> ShowS) -> Show (Action a)
forall a. Show a => Int -> Action a -> ShowS
forall a. Show a => [Action a] -> ShowS
forall a. Show a => Action a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Action a] -> ShowS
$cshowList :: forall a. Show a => [Action a] -> ShowS
show :: Action a -> String
$cshow :: forall a. Show a => Action a -> String
showsPrec :: Int -> Action a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Action a -> ShowS
Show,Action a -> Action a -> Bool
(Action a -> Action a -> Bool)
-> (Action a -> Action a -> Bool) -> Eq (Action a)
forall a. Eq a => Action a -> Action a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Action a -> Action a -> Bool
$c/= :: forall a. Eq a => Action a -> Action a -> Bool
== :: Action a -> Action a -> Bool
$c== :: forall a. Eq a => Action a -> Action a -> Bool
Eq,Eq (Action a)
Eq (Action a)
-> (Action a -> Action a -> Ordering)
-> (Action a -> Action a -> Bool)
-> (Action a -> Action a -> Bool)
-> (Action a -> Action a -> Bool)
-> (Action a -> Action a -> Bool)
-> (Action a -> Action a -> Action a)
-> (Action a -> Action a -> Action a)
-> Ord (Action a)
Action a -> Action a -> Bool
Action a -> Action a -> Ordering
Action a -> Action a -> Action a
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall a. Ord a => Eq (Action a)
forall a. Ord a => Action a -> Action a -> Bool
forall a. Ord a => Action a -> Action a -> Ordering
forall a. Ord a => Action a -> Action a -> Action a
min :: Action a -> Action a -> Action a
$cmin :: forall a. Ord a => Action a -> Action a -> Action a
max :: Action a -> Action a -> Action a
$cmax :: forall a. Ord a => Action a -> Action a -> Action a
>= :: Action a -> Action a -> Bool
$c>= :: forall a. Ord a => Action a -> Action a -> Bool
> :: Action a -> Action a -> Bool
$c> :: forall a. Ord a => Action a -> Action a -> Bool
<= :: Action a -> Action a -> Bool
$c<= :: forall a. Ord a => Action a -> Action a -> Bool
< :: Action a -> Action a -> Bool
$c< :: forall a. Ord a => Action a -> Action a -> Bool
compare :: Action a -> Action a -> Ordering
$ccompare :: forall a. Ord a => Action a -> Action a -> Ordering
$cp1Ord :: forall a. Ord a => Eq (Action a)
Ord)

isInsert :: Action a -> Bool
isInsert :: Action a -> Bool
isInsert = \case
  Insert a
_ -> Bool
True
  Delete a
_ -> Bool
False

extract :: Action a -> a
extract :: Action a -> a
extract = \case
  Insert a
x -> a
x
  Delete a
x -> a
x

-- | An event corresponds to some orientation at which the set of segments
-- intersected by the ray changes (this orientation is defined by a point)
data Event p e r = Event { Event p e r -> Point 2 r :+ p
_eventVtx :: Point 2 r :+ p
                         , Event p e r -> NonEmpty (Action (LineSegment 2 p r :+ e))
_actions  :: NonEmpty (Action (LineSegment 2 p r :+ e))
                         } deriving Int -> Event p e r -> ShowS
[Event p e r] -> ShowS
Event p e r -> String
(Int -> Event p e r -> ShowS)
-> (Event p e r -> String)
-> ([Event p e r] -> ShowS)
-> Show (Event p e r)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall p e r.
(Show r, Show p, Show e) =>
Int -> Event p e r -> ShowS
forall p e r. (Show r, Show p, Show e) => [Event p e r] -> ShowS
forall p e r. (Show r, Show p, Show e) => Event p e r -> String
showList :: [Event p e r] -> ShowS
$cshowList :: forall p e r. (Show r, Show p, Show e) => [Event p e r] -> ShowS
show :: Event p e r -> String
$cshow :: forall p e r. (Show r, Show p, Show e) => Event p e r -> String
showsPrec :: Int -> Event p e r -> ShowS
$cshowsPrec :: forall p e r.
(Show r, Show p, Show e) =>
Int -> Event p e r -> ShowS
Show
makeLenses ''Event

-- | The status structure maintains the subset of segments currently
-- intersected by the ray that starts in the query point q, in order
-- of increasing distance along the ray.
type Status p e r = Set.Set (LineSegment 2 p r :+ e)



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




-- | Computes the visibility polygon of a point q in a polygon with
-- \(n\) vertices.
--
-- pre: q lies strictly inside the polygon
--
-- running time: \(O(n\log n)\)
visibilityPolygon      :: forall p t r. (Ord r, Fractional r)
                       => Point 2 r
                       -> Polygon t p r
                       -> StarShapedPolygon (Definer p () r) r
visibilityPolygon :: Point 2 r -> Polygon t p r -> StarShapedPolygon (Definer p () r) r
visibilityPolygon Point 2 r
q Polygon t p r
pg =
    [Point 2 r :+ Definer p () r]
-> StarShapedPolygon (Definer p () r) r
forall p r. (Eq r, Num r) => [Point 2 r :+ p] -> SimplePolygon p r
fromPoints ([Point 2 r :+ Definer p () r]
 -> StarShapedPolygon (Definer p () r) r)
-> (Polygon t p r -> [Point 2 r :+ Definer p () r])
-> Polygon t p r
-> StarShapedPolygon (Definer p () r) r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vector 2 r
-> Maybe (Point 2 r)
-> Point 2 r
-> [LineSegment 2 p r :+ ()]
-> [Point 2 r :+ Definer p () r]
forall p r e.
(Ord r, Fractional r) =>
Vector 2 r
-> Maybe (Point 2 r)
-> Point 2 r
-> [LineSegment 2 p r :+ e]
-> [Point 2 r :+ Definer p e r]
visibilitySweep Vector 2 r
v Maybe (Point 2 r)
forall a. Maybe a
Nothing Point 2 r
q ([LineSegment 2 p r :+ ()] -> [Point 2 r :+ Definer p () r])
-> (Polygon t p r -> [LineSegment 2 p r :+ ()])
-> Polygon t p r
-> [Point 2 r :+ Definer p () r]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LineSegment 2 p r -> LineSegment 2 p r :+ ())
-> [LineSegment 2 p r] -> [LineSegment 2 p r :+ ()]
forall a b. (a -> b) -> [a] -> [b]
map LineSegment 2 p r -> LineSegment 2 p r :+ ()
forall a. a -> a :+ ()
ext ([LineSegment 2 p r] -> [LineSegment 2 p r :+ ()])
-> (Polygon t p r -> [LineSegment 2 p r])
-> Polygon t p r
-> [LineSegment 2 p r :+ ()]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Polygon t p r -> [LineSegment 2 p r]
forall (t :: PolygonType) p r. Polygon t p r -> [LineSegment 2 p r]
closedEdges (Polygon t p r -> StarShapedPolygon (Definer p () r) r)
-> Polygon t p r -> StarShapedPolygon (Definer p () r) r
forall a b. (a -> b) -> a -> b
$ Polygon t p r
pg
  where
    v :: Vector 2 r
v = (Point 2 r -> Point 2 r -> Vector 2 r)
-> (Point 2 r, Point 2 r) -> Vector 2 r
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (Point 2 r -> Point 2 r -> Point 2 r -> Vector 2 r
forall r.
Fractional r =>
Point 2 r -> Point 2 r -> Point 2 r -> Vector 2 r
startingDirection Point 2 r
q) ((Point 2 r, Point 2 r) -> Vector 2 r)
-> (Polygon t p r -> (Point 2 r, Point 2 r))
-> Polygon t p r
-> Vector 2 r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Point 2 r -> NonEmpty (Point 2 r :+ p) -> (Point 2 r, Point 2 r)
forall r p.
(Ord r, Num r) =>
Point 2 r -> NonEmpty (Point 2 r :+ p) -> (Point 2 r, Point 2 r)
consecutive Point 2 r
q (NonEmpty (Point 2 r :+ p) -> (Point 2 r, Point 2 r))
-> (Polygon t p r -> NonEmpty (Point 2 r :+ p))
-> Polygon t p r
-> (Point 2 r, Point 2 r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Polygon t p r -> NonEmpty (Point 2 r :+ p)
forall (t :: PolygonType) p r.
Polygon t p r -> NonEmpty (Point 2 r :+ p)
polygonVertices (Polygon t p r -> Vector 2 r) -> Polygon t p r -> Vector 2 r
forall a b. (a -> b) -> a -> b
$ Polygon t p r
pg























-- | Computes the visibility polgyon from a vertex
visibilityPolygonFromVertex      :: forall p t r. (Ord r, Fractional r, Show r, Show p)
                                 => Polygon t p r
                                 -> Int -- ^ from the i^th vertex on the outer boundary
                                 -> VisibilityPolygon p () r
visibilityPolygonFromVertex :: Polygon t p r -> Int -> VisibilityPolygon p () r
visibilityPolygonFromVertex Polygon t p r
pg Int
i =
    [Point 2 r :+ Definer p () r] -> VisibilityPolygon p () r
forall p r. (Eq r, Num r) => [Point 2 r :+ p] -> SimplePolygon p r
fromPoints ([Point 2 r :+ Definer p () r] -> VisibilityPolygon p () r)
-> ([LineSegment 2 p r] -> [Point 2 r :+ Definer p () r])
-> [LineSegment 2 p r]
-> VisibilityPolygon p () r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vector 2 r
-> Maybe (Point 2 r)
-> Point 2 r
-> [LineSegment 2 p r :+ ()]
-> [Point 2 r :+ Definer p () r]
forall p r e.
(Ord r, Fractional r) =>
Vector 2 r
-> Maybe (Point 2 r)
-> Point 2 r
-> [LineSegment 2 p r :+ e]
-> [Point 2 r :+ Definer p e r]
visibilitySweep Vector 2 r
sv (Point 2 r -> Maybe (Point 2 r)
forall a. a -> Maybe a
Just Point 2 r
w) Point 2 r
v ([LineSegment 2 p r :+ ()] -> [Point 2 r :+ Definer p () r])
-> ([LineSegment 2 p r] -> [LineSegment 2 p r :+ ()])
-> [LineSegment 2 p r]
-> [Point 2 r :+ Definer p () r]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LineSegment 2 p r -> LineSegment 2 p r :+ ())
-> [LineSegment 2 p r] -> [LineSegment 2 p r :+ ()]
forall a b. (a -> b) -> [a] -> [b]
map LineSegment 2 p r -> LineSegment 2 p r :+ ()
forall a. a -> a :+ ()
ext ([LineSegment 2 p r] -> VisibilityPolygon p () r)
-> [LineSegment 2 p r] -> VisibilityPolygon p () r
forall a b. (a -> b) -> a -> b
$ [LineSegment 2 p r]
segs
  where
    (Point 2 r
v :+ p
_) = Polygon t p r
pgPolygon t p r
-> Getting (Point 2 r :+ p) (Polygon t p r) (Point 2 r :+ p)
-> Point 2 r :+ p
forall s a. s -> Getting a s a -> a
^.Int -> Getter (Polygon t p r) (Point 2 r :+ p)
forall (t :: PolygonType) p r.
Int -> Getter (Polygon t p r) (Point 2 r :+ p)
outerVertex Int
i
    (Point 2 r
w :+ p
_) = Polygon t p r
pgPolygon t p r
-> Getting (Point 2 r :+ p) (Polygon t p r) (Point 2 r :+ p)
-> Point 2 r :+ p
forall s a. s -> Getting a s a -> a
^.Int -> Getter (Polygon t p r) (Point 2 r :+ p)
forall (t :: PolygonType) p r.
Int -> Getter (Polygon t p r) (Point 2 r :+ p)
outerVertex (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)
    (Point 2 r
u :+ p
_)  = Polygon t p r
pgPolygon t p r
-> Getting (Point 2 r :+ p) (Polygon t p r) (Point 2 r :+ p)
-> Point 2 r :+ p
forall s a. s -> Getting a s a -> a
^.Int -> Getter (Polygon t p r) (Point 2 r :+ p)
forall (t :: PolygonType) p r.
Int -> Getter (Polygon t p r) (Point 2 r :+ p)
outerVertex (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)

    -- rotates the polygon so that u becomes the focus, and gets all
    -- other vertices. Takes the next CCW vertex around v, starting
    -- form the direction indicated by v.
    z :: Point 2 r
z = let Point 2 r :+ p
u' :| [Point 2 r :+ p]
rest = String -> NonEmpty (Point 2 r :+ p) -> NonEmpty (Point 2 r :+ p)
forall b a. (Show b, Show a) => a -> b -> b
traceShowIdWith String
"vertices"
                       (NonEmpty (Point 2 r :+ p) -> NonEmpty (Point 2 r :+ p))
-> NonEmpty (Point 2 r :+ p) -> NonEmpty (Point 2 r :+ p)
forall a b. (a -> b) -> a -> b
$  Polygon t p r -> NonEmpty (Point 2 r :+ p)
forall (t :: PolygonType) p r.
Polygon t p r -> NonEmpty (Point 2 r :+ p)
polygonVertices (Polygon t p r -> NonEmpty (Point 2 r :+ p))
-> Polygon t p r -> NonEmpty (Point 2 r :+ p)
forall a b. (a -> b) -> a -> b
$ Polygon t p r
pgPolygon t p r -> (Polygon t p r -> Polygon t p r) -> Polygon t p r
forall a b. a -> (a -> b) -> b
&(SimplePolygon p r -> Identity (SimplePolygon p r))
-> Polygon t p r -> Identity (Polygon t p r)
forall (t :: PolygonType) p r.
Lens' (Polygon t p r) (SimplePolygon p r)
outerBoundary ((SimplePolygon p r -> Identity (SimplePolygon p r))
 -> Polygon t p r -> Identity (Polygon t p r))
-> (SimplePolygon p r -> SimplePolygon p r)
-> Polygon t p r
-> Polygon t p r
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ Int -> SimplePolygon p r -> SimplePolygon p r
forall p r. Int -> SimplePolygon p r -> SimplePolygon p r
rotateRight (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
        in String -> Point 2 r -> Point 2 r
forall b a. (Show b, Show a) => a -> b -> b
traceShowIdWith String
"z" (Point 2 r -> Point 2 r) -> Point 2 r -> Point 2 r
forall a b. (a -> b) -> a -> b
$ Vector 2 r -> Point 2 r -> [Point 2 r :+ p] -> Point 2 r
forall r p.
(Ord r, Num r) =>
Vector 2 r -> Point 2 r -> [Point 2 r :+ p] -> Point 2 r
consecutiveFrom (Point 2 r
u Point 2 r -> Point 2 r -> Diff (Point 2) r
forall (p :: * -> *) a. (Affine p, Num a) => p a -> p a -> Diff p a
.-. Point 2 r
v) Point 2 r
v ([Point 2 r :+ p] -> [Point 2 r :+ p]
forall a. [a] -> [a]
List.init [Point 2 r :+ p]
rest)
           -- the last vertex in rest is v; so kill that

    sv :: Vector 2 r
sv = Point 2 r -> Point 2 r -> Point 2 r -> Vector 2 r
forall r.
Fractional r =>
Point 2 r -> Point 2 r -> Point 2 r -> Vector 2 r
startingDirection Point 2 r
v Point 2 r
u Point 2 r
z

    segs :: [LineSegment 2 p r]
segs = (LineSegment 2 (SP Int p) r -> LineSegment 2 p r)
-> [LineSegment 2 (SP Int p) r] -> [LineSegment 2 p r]
forall a b. (a -> b) -> [a] -> [b]
map ((SP Int p -> p) -> LineSegment 2 (SP Int p) r -> LineSegment 2 p r
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (SP Int p -> Getting p (SP Int p) p -> p
forall s a. s -> Getting a s a -> a
^.Getting p (SP Int p) p
forall s t a b. Field2 s t a b => Lens s t a b
_2))
         ([LineSegment 2 (SP Int p) r] -> [LineSegment 2 p r])
-> (Polygon t (SP Int p) r -> [LineSegment 2 (SP Int p) r])
-> Polygon t (SP Int p) r
-> [LineSegment 2 p r]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LineSegment 2 (SP Int p) r -> Bool)
-> [LineSegment 2 (SP Int p) r] -> [LineSegment 2 (SP Int p) r]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> (LineSegment 2 (SP Int p) r -> Bool)
-> LineSegment 2 (SP Int p) r
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> LineSegment 2 (SP Int p) r -> Bool
forall a r. Int -> LineSegment 2 (SP Int a) r -> Bool
incidentTo Int
i)
         ([LineSegment 2 (SP Int p) r] -> [LineSegment 2 (SP Int p) r])
-> (Polygon t (SP Int p) r -> [LineSegment 2 (SP Int p) r])
-> Polygon t (SP Int p) r
-> [LineSegment 2 (SP Int p) r]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Polygon t (SP Int p) r -> [LineSegment 2 (SP Int p) r]
forall (t :: PolygonType) p r. Polygon t p r -> [LineSegment 2 p r]
closedEdges (Polygon t (SP Int p) r -> [LineSegment 2 p r])
-> Polygon t (SP Int p) r -> [LineSegment 2 p r]
forall a b. (a -> b) -> a -> b
$ Polygon t p r -> Polygon t (SP Int p) r
forall (t :: PolygonType) p r.
Polygon t p r -> Polygon t (SP Int p) r
numberVertices Polygon t p r
pg

visibilityPolygonFromVertex' :: Point 2 r
-> Vector 2 r
-> Maybe (Point 2 r)
-> [LineSegment 2 p r :+ e]
-> [Point 2 r :+ Definer p e r]
visibilityPolygonFromVertex' Point 2 r
q Vector 2 r
sv Maybe (Point 2 r)
mt [LineSegment 2 p r :+ e]
segs = Point 2 r
-> Status p e r -> [Event p e r] -> [Point 2 r :+ Definer p e r]
forall (t :: * -> *) r p e.
(Foldable t, Ord r, Fractional r) =>
Point 2 r
-> Status p e r -> t (Event p e r) -> [Point 2 r :+ Definer p e r]
sweep Point 2 r
q Status p e r
statusStruct (String -> [Event p e r] -> [Event p e r]
forall b a. (Show b, Show a) => a -> b -> b
traceShowIdWith String
"events" [Event p e r]
events)
  where
    v :: a
v      = a
forall a. HasCallStack => a
undefined

    -- lazily test if the segment intersects the initial ray
    segs' :: [LineSegment 2 p r :+ (Maybe r, e)]
segs'  = Point 2 r
-> HalfLine 2 r
-> [LineSegment 2 p r :+ e]
-> [LineSegment 2 p r :+ (Maybe r, e)]
forall r p b.
(Ord r, Fractional r) =>
Point 2 r
-> HalfLine 2 r
-> [LineSegment 2 p r :+ b]
-> [LineSegment 2 p r :+ (Maybe r, b)]
labelWithDistances Point 2 r
q HalfLine 2 r
initialRay [LineSegment 2 p r :+ e]
segs

    events :: [Event p e r]
events = Point 2 r
-> Vector 2 r
-> ([Event p e r] -> [Event p e r])
-> [LineSegment 2 p r :+ (Maybe r, e)]
-> [Event p e r]
forall r (t :: * -> *) p1 e1 p2 e2.
(Ord r, Num r, Foldable t) =>
Point 2 r
-> Vector 2 r
-> ([Event p1 e1 r] -> [Event p2 e2 r])
-> t (LineSegment 2 p1 r :+ (Maybe r, e1))
-> [Event p2 e2 r]
computeEvents Point 2 r
q Vector 2 r
sv (Point 2 r
-> Vector 2 r
-> Maybe (Point 2 r)
-> [Event p e r]
-> [Event p e r]
forall r a e.
(Ord r, Num r) =>
Point 2 r
-> Vector 2 r
-> Maybe (Point 2 r)
-> [Event a e r]
-> [Event a e r]
untilEnd Point 2 r
q Vector 2 r
sv Maybe (Point 2 r)
mt) [LineSegment 2 p r :+ (Maybe r, e)]
segs'
        -- take only until the end of the range (if defined)

    initialRay :: HalfLine 2 r
initialRay = String -> HalfLine 2 r -> HalfLine 2 r
forall b a. (Show b, Show a) => a -> b -> b
traceShowIdWith String
"ray" (HalfLine 2 r -> HalfLine 2 r) -> HalfLine 2 r -> HalfLine 2 r
forall a b. (a -> b) -> a -> b
$ Point 2 r -> Vector 2 r -> HalfLine 2 r
forall (d :: Nat) r. Point d r -> Vector d r -> HalfLine d r
HalfLine Point 2 r
q Vector 2 r
sv
    statusStruct :: Status p e r
statusStruct = String -> Status p e r -> Status p e r
forall b a. (Show b, Show a) => a -> b -> b
traceShowIdWith String
"initialSS" (Status p e r -> Status p e r) -> Status p e r -> Status p e r
forall a b. (a -> b) -> a -> b
$ [LineSegment 2 p r :+ (Maybe r, e)] -> Status p e r
forall r p e.
(Ord r, Fractional r) =>
[LineSegment 2 p r :+ (Maybe r, e)] -> Status p e r
mkInitialSS [LineSegment 2 p r :+ (Maybe r, e)]
segs'


-- | Test if the line segment is incident to a point with the given
-- index.
incidentTo     :: Int -> LineSegment 2 (SP Int a) r -> Bool
incidentTo :: Int -> LineSegment 2 (SP Int a) r -> Bool
incidentTo Int
i LineSegment 2 (SP Int a) r
s = LineSegment 2 (SP Int a) r
sLineSegment 2 (SP Int a) r
-> Getting Int (LineSegment 2 (SP Int a) r) Int -> Int
forall s a. s -> Getting a s a -> a
^.((Point 2 r :+ SP Int a) -> Const Int (Point 2 r :+ SP Int a))
-> LineSegment 2 (SP Int a) r
-> Const Int (LineSegment 2 (SP Int a) r)
forall t. HasStart t => Lens' t (StartCore t :+ StartExtra t)
start(((Point 2 r :+ SP Int a) -> Const Int (Point 2 r :+ SP Int a))
 -> LineSegment 2 (SP Int a) r
 -> Const Int (LineSegment 2 (SP Int a) r))
-> ((Int -> Const Int Int)
    -> (Point 2 r :+ SP Int a) -> Const Int (Point 2 r :+ SP Int a))
-> Getting Int (LineSegment 2 (SP Int a) r) Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(SP Int a -> Const Int (SP Int a))
-> (Point 2 r :+ SP Int a) -> Const Int (Point 2 r :+ SP Int a)
forall core extra extra'.
Lens (core :+ extra) (core :+ extra') extra extra'
extra((SP Int a -> Const Int (SP Int a))
 -> (Point 2 r :+ SP Int a) -> Const Int (Point 2 r :+ SP Int a))
-> ((Int -> Const Int Int) -> SP Int a -> Const Int (SP Int a))
-> (Int -> Const Int Int)
-> (Point 2 r :+ SP Int a)
-> Const Int (Point 2 r :+ SP Int a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Int -> Const Int Int) -> SP Int a -> Const Int (SP Int a)
forall s t a b. Field1 s t a b => Lens s t a b
_1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
i Bool -> Bool -> Bool
|| LineSegment 2 (SP Int a) r
sLineSegment 2 (SP Int a) r
-> Getting Int (LineSegment 2 (SP Int a) r) Int -> Int
forall s a. s -> Getting a s a -> a
^.((Point 2 r :+ SP Int a) -> Const Int (Point 2 r :+ SP Int a))
-> LineSegment 2 (SP Int a) r
-> Const Int (LineSegment 2 (SP Int a) r)
forall t. HasEnd t => Lens' t (EndCore t :+ EndExtra t)
end(((Point 2 r :+ SP Int a) -> Const Int (Point 2 r :+ SP Int a))
 -> LineSegment 2 (SP Int a) r
 -> Const Int (LineSegment 2 (SP Int a) r))
-> ((Int -> Const Int Int)
    -> (Point 2 r :+ SP Int a) -> Const Int (Point 2 r :+ SP Int a))
-> Getting Int (LineSegment 2 (SP Int a) r) Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(SP Int a -> Const Int (SP Int a))
-> (Point 2 r :+ SP Int a) -> Const Int (Point 2 r :+ SP Int a)
forall core extra extra'.
Lens (core :+ extra) (core :+ extra') extra extra'
extra((SP Int a -> Const Int (SP Int a))
 -> (Point 2 r :+ SP Int a) -> Const Int (Point 2 r :+ SP Int a))
-> ((Int -> Const Int Int) -> SP Int a -> Const Int (SP Int a))
-> (Int -> Const Int Int)
-> (Point 2 r :+ SP Int a)
-> Const Int (Point 2 r :+ SP Int a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Int -> Const Int Int) -> SP Int a -> Const Int (SP Int a)
forall s t a b. Field1 s t a b => Lens s t a b
_1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
i









-- | computes a (partial) visibility polygon of a set of \(n\)
-- disjoint segments. The input segments are allowed to share
-- endpoints, but no intersections or no endpoints in the interior of
-- other segments. The input vector indicates the starting direction,
-- the Maybe point indicates up to which point/dicrection (CCW) of the
-- starting vector we should compute the visibility polygon.
--
-- pre : - all line segments are considered closed.
--       - no singleton linesegments exactly pointing away from q.
--       - for every orientattion the visibility is blocked somewhere, i.e.
--            no rays starting in the query point q that are disjoint from all segments.
--       - no vertices at staring direction sv
--
-- running time: \(O(n\log n)\)
visibilitySweep              :: forall p r e. (Ord r, Fractional r)
                             => Vector 2 r -- ^ starting direction of the sweep
                             -> Maybe (Point 2 r)
                             -- ^ -- point indicating the last point to sweep to
                             -> Point 2 r -- ^ the point form which we compute the visibility polgyon
                             -> [LineSegment 2 p r :+ e]
                             -> [Point 2 r :+ Definer p e r]
visibilitySweep :: Vector 2 r
-> Maybe (Point 2 r)
-> Point 2 r
-> [LineSegment 2 p r :+ e]
-> [Point 2 r :+ Definer p e r]
visibilitySweep Vector 2 r
sv Maybe (Point 2 r)
mt Point 2 r
q [LineSegment 2 p r :+ e]
segs = Point 2 r
-> Status p e r -> [Event p e r] -> [Point 2 r :+ Definer p e r]
forall (t :: * -> *) r p e.
(Foldable t, Ord r, Fractional r) =>
Point 2 r
-> Status p e r -> t (Event p e r) -> [Point 2 r :+ Definer p e r]
sweep Point 2 r
q Status p e r
statusStruct [Event p e r]
events
  where
    -- lazily test if the segment intersects the initial ray
    segs' :: [LineSegment 2 p r :+ (Maybe r, e)]
segs'  = Point 2 r
-> HalfLine 2 r
-> [LineSegment 2 p r :+ e]
-> [LineSegment 2 p r :+ (Maybe r, e)]
forall r p b.
(Ord r, Fractional r) =>
Point 2 r
-> HalfLine 2 r
-> [LineSegment 2 p r :+ b]
-> [LineSegment 2 p r :+ (Maybe r, b)]
labelWithDistances Point 2 r
q HalfLine 2 r
initialRay [LineSegment 2 p r :+ e]
segs
    events :: [Event p e r]
events = Point 2 r
-> Vector 2 r
-> ([Event p e r] -> [Event p e r])
-> [LineSegment 2 p r :+ (Maybe r, e)]
-> [Event p e r]
forall r (t :: * -> *) p1 e1 p2 e2.
(Ord r, Num r, Foldable t) =>
Point 2 r
-> Vector 2 r
-> ([Event p1 e1 r] -> [Event p2 e2 r])
-> t (LineSegment 2 p1 r :+ (Maybe r, e1))
-> [Event p2 e2 r]
computeEvents Point 2 r
q Vector 2 r
sv (Point 2 r
-> Vector 2 r
-> Maybe (Point 2 r)
-> [Event p e r]
-> [Event p e r]
forall r a e.
(Ord r, Num r) =>
Point 2 r
-> Vector 2 r
-> Maybe (Point 2 r)
-> [Event a e r]
-> [Event a e r]
untilEnd Point 2 r
q Vector 2 r
sv Maybe (Point 2 r)
mt) [LineSegment 2 p r :+ (Maybe r, e)]
segs'

    initialRay :: HalfLine 2 r
initialRay = Point 2 r -> Vector 2 r -> HalfLine 2 r
forall (d :: Nat) r. Point d r -> Vector d r -> HalfLine d r
HalfLine Point 2 r
q Vector 2 r
sv
    statusStruct :: Status p e r
statusStruct = [LineSegment 2 p r :+ (Maybe r, e)] -> Status p e r
forall r p e.
(Ord r, Fractional r) =>
[LineSegment 2 p r :+ (Maybe r, e)] -> Status p e r
mkInitialSS [LineSegment 2 p r :+ (Maybe r, e)]
segs'

-- | Take until the ending point if defined. We can use that the list
-- of events appears in sorted order in the cyclic orientation around
-- the query point q
untilEnd      :: (Ord r, Num r)
              => Point 2 r -- ^ query point
              -> Vector 2 r -- ^ starting direction
              -> Maybe (Point 2 r) -- ^ possible ending point
              -> [Event a e r] -> [Event a e r]
untilEnd :: Point 2 r
-> Vector 2 r
-> Maybe (Point 2 r)
-> [Event a e r]
-> [Event a e r]
untilEnd Point 2 r
q Vector 2 r
sv = \case
  Maybe (Point 2 r)
Nothing -> [Event a e r] -> [Event a e r]
forall a. a -> a
id
  Just Point 2 r
t  -> (Event a e r -> Bool) -> [Event a e r] -> [Event a e r]
forall a. (a -> Bool) -> [a] -> [a]
List.takeWhile (\Event a e r
e -> Vector 2 r
-> (Point 2 r :+ ())
-> (Point 2 r :+ a)
-> (Point 2 r :+ ())
-> Ordering
forall r c a b.
(Ord r, Num r) =>
Vector 2 r
-> (Point 2 r :+ c)
-> (Point 2 r :+ a)
-> (Point 2 r :+ b)
-> Ordering
ccwCmpAroundWith' Vector 2 r
sv (Point 2 r -> Point 2 r :+ ()
forall a. a -> a :+ ()
ext Point 2 r
q) (Event a e r
eEvent a e r
-> Getting (Point 2 r :+ a) (Event a e r) (Point 2 r :+ a)
-> Point 2 r :+ a
forall s a. s -> Getting a s a -> a
^.Getting (Point 2 r :+ a) (Event a e r) (Point 2 r :+ a)
forall p e r. Lens' (Event p e r) (Point 2 r :+ p)
eventVtx) (Point 2 r -> Point 2 r :+ ()
forall a. a -> a :+ ()
ext Point 2 r
t) Ordering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
== Ordering
LT)

-- | Runs the actual sweep
sweep                :: (Foldable t, Ord r, Fractional r)
                     => Point 2 r    -- ^ query point
                     -> Status p e r -- ^ initial status structure
                     -> t (Event p e r) -- ^ events to handle
                     -> [Point 2 r :+ Definer p e r]
sweep :: Point 2 r
-> Status p e r -> t (Event p e r) -> [Point 2 r :+ Definer p e r]
sweep Point 2 r
q Status p e r
statusStruct = (Status p e r, [Point 2 r :+ Definer p e r])
-> [Point 2 r :+ Definer p e r]
forall a b. (a, b) -> b
snd ((Status p e r, [Point 2 r :+ Definer p e r])
 -> [Point 2 r :+ Definer p e r])
-> (t (Event p e r)
    -> (Status p e r, [Point 2 r :+ Definer p e r]))
-> t (Event p e r)
-> [Point 2 r :+ Definer p e r]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Status p e r, [Point 2 r :+ Definer p e r])
 -> Event p e r -> (Status p e r, [Point 2 r :+ Definer p e r]))
-> (Status p e r, [Point 2 r :+ Definer p e r])
-> t (Event p e r)
-> (Status p e r, [Point 2 r :+ Definer p e r])
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' (Point 2 r
-> (Status p e r, [Point 2 r :+ Definer p e r])
-> Event p e r
-> (Status p e r, [Point 2 r :+ Definer p e r])
forall r p e.
(Ord r, Fractional r) =>
Point 2 r
-> (Status p e r, [Point 2 r :+ Definer p e r])
-> Event p e r
-> (Status p e r, [Point 2 r :+ Definer p e r])
handleEvent Point 2 r
q) (Status p e r
statusStruct,[])


-- | Computes the events in the sweep
computeEvents                :: (Ord r, Num r, Foldable t)
                             => Point 2 r -- ^ query point
                             -> Vector 2 r -- ^ starting direction
                             -> ([Event p1 e1 r] -> [Event p2 e2 r]) -- ^ until where to take the vents
                             -> t (LineSegment 2 p1 r :+ (Maybe r, e1))
                             -> [Event p2 e2 r]
computeEvents :: Point 2 r
-> Vector 2 r
-> ([Event p1 e1 r] -> [Event p2 e2 r])
-> t (LineSegment 2 p1 r :+ (Maybe r, e1))
-> [Event p2 e2 r]
computeEvents Point 2 r
q Vector 2 r
sv [Event p1 e1 r] -> [Event p2 e2 r]
takeUntil =
     (NonEmpty (Event p2 e2 r) -> Event p2 e2 r)
-> [NonEmpty (Event p2 e2 r)] -> [Event p2 e2 r]
forall a b. (a -> b) -> [a] -> [b]
map (Point 2 r -> NonEmpty (Event p2 e2 r) -> Event p2 e2 r
forall r p e.
(Ord r, Num r) =>
Point 2 r -> NonEmpty (Event p e r) -> Event p e r
combine Point 2 r
q)
   ([NonEmpty (Event p2 e2 r)] -> [Event p2 e2 r])
-> (t (LineSegment 2 p1 r :+ (Maybe r, e1))
    -> [NonEmpty (Event p2 e2 r)])
-> t (LineSegment 2 p1 r :+ (Maybe r, e1))
-> [Event p2 e2 r]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Event p2 e2 r -> Event p2 e2 r -> Ordering)
-> [Event p2 e2 r] -> [NonEmpty (Event p2 e2 r)]
forall a. (a -> a -> Ordering) -> [a] -> [NonEmpty a]
List.groupBy' (\Event p2 e2 r
a Event p2 e2 r
b -> Vector 2 r
-> (Point 2 r :+ ())
-> (Point 2 r :+ p2)
-> (Point 2 r :+ p2)
-> Ordering
forall r c a b.
(Ord r, Num r) =>
Vector 2 r
-> (Point 2 r :+ c)
-> (Point 2 r :+ a)
-> (Point 2 r :+ b)
-> Ordering
ccwCmpAroundWith' Vector 2 r
sv (Point 2 r -> Point 2 r :+ ()
forall a. a -> a :+ ()
ext Point 2 r
q) (Event p2 e2 r
aEvent p2 e2 r
-> Getting (Point 2 r :+ p2) (Event p2 e2 r) (Point 2 r :+ p2)
-> Point 2 r :+ p2
forall s a. s -> Getting a s a -> a
^.Getting (Point 2 r :+ p2) (Event p2 e2 r) (Point 2 r :+ p2)
forall p e r. Lens' (Event p e r) (Point 2 r :+ p)
eventVtx) (Event p2 e2 r
bEvent p2 e2 r
-> Getting (Point 2 r :+ p2) (Event p2 e2 r) (Point 2 r :+ p2)
-> Point 2 r :+ p2
forall s a. s -> Getting a s a -> a
^.Getting (Point 2 r :+ p2) (Event p2 e2 r) (Point 2 r :+ p2)
forall p e r. Lens' (Event p e r) (Point 2 r :+ p)
eventVtx))
   ([Event p2 e2 r] -> [NonEmpty (Event p2 e2 r)])
-> (t (LineSegment 2 p1 r :+ (Maybe r, e1)) -> [Event p2 e2 r])
-> t (LineSegment 2 p1 r :+ (Maybe r, e1))
-> [NonEmpty (Event p2 e2 r)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Event p1 e1 r] -> [Event p2 e2 r]
takeUntil
   ([Event p1 e1 r] -> [Event p2 e2 r])
-> (t (LineSegment 2 p1 r :+ (Maybe r, e1)) -> [Event p1 e1 r])
-> t (LineSegment 2 p1 r :+ (Maybe r, e1))
-> [Event p2 e2 r]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Event p1 e1 r -> Event p1 e1 r -> Ordering)
-> [Event p1 e1 r] -> [Event p1 e1 r]
forall a. (a -> a -> Ordering) -> [a] -> [a]
List.sortBy ((Point 2 r :+ p1) -> (Point 2 r :+ p1) -> Ordering
cmp ((Point 2 r :+ p1) -> (Point 2 r :+ p1) -> Ordering)
-> (Event p1 e1 r -> Point 2 r :+ p1)
-> Event p1 e1 r
-> Event p1 e1 r
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (Event p1 e1 r
-> Getting (Point 2 r :+ p1) (Event p1 e1 r) (Point 2 r :+ p1)
-> Point 2 r :+ p1
forall s a. s -> Getting a s a -> a
^.Getting (Point 2 r :+ p1) (Event p1 e1 r) (Point 2 r :+ p1)
forall p e r. Lens' (Event p e r) (Point 2 r :+ p)
eventVtx))
   ([Event p1 e1 r] -> [Event p1 e1 r])
-> (t (LineSegment 2 p1 r :+ (Maybe r, e1)) -> [Event p1 e1 r])
-> t (LineSegment 2 p1 r :+ (Maybe r, e1))
-> [Event p1 e1 r]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((LineSegment 2 p1 r :+ (Maybe r, e1)) -> [Event p1 e1 r])
-> t (LineSegment 2 p1 r :+ (Maybe r, e1)) -> [Event p1 e1 r]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Vector 2 r
-> Point 2 r
-> (LineSegment 2 p1 r :+ (Maybe r, e1))
-> [Event p1 e1 r]
forall r p e.
(Ord r, Num r) =>
Vector 2 r
-> Point 2 r
-> (LineSegment 2 p r :+ (Maybe r, e))
-> [Event p e r]
mkEvent Vector 2 r
sv Point 2 r
q)
  where
    cmp :: (Point 2 r :+ p1) -> (Point 2 r :+ p1) -> Ordering
cmp = Vector 2 r
-> (Point 2 r :+ ())
-> (Point 2 r :+ p1)
-> (Point 2 r :+ p1)
-> Ordering
forall r c a b.
(Ord r, Num r) =>
Vector 2 r
-> (Point 2 r :+ c)
-> (Point 2 r :+ a)
-> (Point 2 r :+ b)
-> Ordering
ccwCmpAroundWith' Vector 2 r
sv (Point 2 r -> Point 2 r :+ ()
forall a. a -> a :+ ()
ext Point 2 r
q) ((Point 2 r :+ p1) -> (Point 2 r :+ p1) -> Ordering)
-> ((Point 2 r :+ p1) -> (Point 2 r :+ p1) -> Ordering)
-> (Point 2 r :+ p1)
-> (Point 2 r :+ p1)
-> Ordering
forall a. Semigroup a => a -> a -> a
<> (Point 2 r :+ ())
-> (Point 2 r :+ p1) -> (Point 2 r :+ p1) -> Ordering
forall r (d :: Nat) c p q.
(Ord r, Num r, Arity d) =>
(Point d r :+ c)
-> (Point d r :+ p) -> (Point d r :+ q) -> Ordering
cmpByDistanceTo' (Point 2 r -> Point 2 r :+ ()
forall a. a -> a :+ ()
ext Point 2 r
q)

-- | Given multiple events happening at the same orientation, combine
-- them into a single event.
combine      :: (Ord r, Num r) => Point 2 r -> NonEmpty (Event p e r) -> Event p e r
combine :: Point 2 r -> NonEmpty (Event p e r) -> Event p e r
combine Point 2 r
q NonEmpty (Event p e r)
es = (Point 2 r :+ p)
-> NonEmpty (Action (LineSegment 2 p r :+ e)) -> Event p e r
forall p e r.
(Point 2 r :+ p)
-> NonEmpty (Action (LineSegment 2 p r :+ e)) -> Event p e r
Event Point 2 r :+ p
p NonEmpty (Action (LineSegment 2 p r :+ e))
acts
  where
    acts :: NonEmpty (Action (LineSegment 2 p r :+ e))
acts = (Event p e r -> NonEmpty (Action (LineSegment 2 p r :+ e)))
-> NonEmpty (Event p e r)
-> NonEmpty (Action (LineSegment 2 p r :+ e))
forall (t :: * -> *) m a.
(Foldable1 t, Semigroup m) =>
(a -> m) -> t a -> m
foldMap1 (Event p e r
-> Getting
     (NonEmpty (Action (LineSegment 2 p r :+ e)))
     (Event p e r)
     (NonEmpty (Action (LineSegment 2 p r :+ e)))
-> NonEmpty (Action (LineSegment 2 p r :+ e))
forall s a. s -> Getting a s a -> a
^.Getting
  (NonEmpty (Action (LineSegment 2 p r :+ e)))
  (Event p e r)
  (NonEmpty (Action (LineSegment 2 p r :+ e)))
forall p e r e.
Lens
  (Event p e r)
  (Event p e r)
  (NonEmpty (Action (LineSegment 2 p r :+ e)))
  (NonEmpty (Action (LineSegment 2 p r :+ e)))
actions) NonEmpty (Event p e r)
es
    p :: Point 2 r :+ p
p    = ((Point 2 r :+ p) -> (Point 2 r :+ p) -> Ordering)
-> NonEmpty (Point 2 r :+ p) -> Point 2 r :+ p
forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
F.minimumBy ((Point 2 r :+ ())
-> (Point 2 r :+ p) -> (Point 2 r :+ p) -> Ordering
forall r (d :: Nat) c p q.
(Ord r, Num r, Arity d) =>
(Point d r :+ c)
-> (Point d r :+ p) -> (Point d r :+ q) -> Ordering
cmpByDistanceTo' (Point 2 r -> Point 2 r :+ ()
forall a. a -> a :+ ()
ext Point 2 r
q)) (NonEmpty (Point 2 r :+ p) -> Point 2 r :+ p)
-> (NonEmpty (Event p e r) -> NonEmpty (Point 2 r :+ p))
-> NonEmpty (Event p e r)
-> Point 2 r :+ p
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Event p e r -> Point 2 r :+ p)
-> NonEmpty (Event p e r) -> NonEmpty (Point 2 r :+ p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Event p e r
-> Getting (Point 2 r :+ p) (Event p e r) (Point 2 r :+ p)
-> Point 2 r :+ p
forall s a. s -> Getting a s a -> a
^.Getting (Point 2 r :+ p) (Event p e r) (Point 2 r :+ p)
forall p e r. Lens' (Event p e r) (Point 2 r :+ p)
eventVtx) (NonEmpty (Event p e r) -> Point 2 r :+ p)
-> NonEmpty (Event p e r) -> Point 2 r :+ p
forall a b. (a -> b) -> a -> b
$ NonEmpty (Event p e r)
es

-- | Constructs the at most two events resulting from this segement.
mkEvent                                      :: (Ord r, Num r)
                                             => Vector 2 r -- ^ starting direction
                                             -> Point 2 r  -- ^ query point
                                             -> LineSegment 2 p r :+ (Maybe r, e)
                                             -> [Event p e r]
mkEvent :: Vector 2 r
-> Point 2 r
-> (LineSegment 2 p r :+ (Maybe r, e))
-> [Event p e r]
mkEvent Vector 2 r
sv Point 2 r
q (s :: LineSegment 2 p r
s@(LineSegment' Point 2 r :+ p
u Point 2 r :+ p
v) :+ (Maybe r
d,e
e)) = case (Point 2 r :+ p) -> (Point 2 r :+ p) -> Ordering
cmp Point 2 r :+ p
u Point 2 r :+ p
v of
                                                 Ordering
LT -> [ (Point 2 r :+ p)
-> NonEmpty (Action (LineSegment 2 p r :+ e)) -> Event p e r
forall p e r.
(Point 2 r :+ p)
-> NonEmpty (Action (LineSegment 2 p r :+ e)) -> Event p e r
Event Point 2 r :+ p
u NonEmpty (Action (LineSegment 2 p r :+ e))
insert
                                                       , (Point 2 r :+ p)
-> NonEmpty (Action (LineSegment 2 p r :+ e)) -> Event p e r
forall p e r.
(Point 2 r :+ p)
-> NonEmpty (Action (LineSegment 2 p r :+ e)) -> Event p e r
Event Point 2 r :+ p
v NonEmpty (Action (LineSegment 2 p r :+ e))
delete
                                                       ]
                                                 Ordering
GT -> [ (Point 2 r :+ p)
-> NonEmpty (Action (LineSegment 2 p r :+ e)) -> Event p e r
forall p e r.
(Point 2 r :+ p)
-> NonEmpty (Action (LineSegment 2 p r :+ e)) -> Event p e r
Event Point 2 r :+ p
v NonEmpty (Action (LineSegment 2 p r :+ e))
insert
                                                       , (Point 2 r :+ p)
-> NonEmpty (Action (LineSegment 2 p r :+ e)) -> Event p e r
forall p e r.
(Point 2 r :+ p)
-> NonEmpty (Action (LineSegment 2 p r :+ e)) -> Event p e r
Event Point 2 r :+ p
u NonEmpty (Action (LineSegment 2 p r :+ e))
delete
                                                       ]
                                                 Ordering
EQ -> [] -- zero length segment, just skip
  where
    cmp :: (Point 2 r :+ p) -> (Point 2 r :+ p) -> Ordering
cmp = Vector 2 r
-> (Point 2 r :+ ())
-> (Point 2 r :+ p)
-> (Point 2 r :+ p)
-> Ordering
forall r c a b.
(Ord r, Num r) =>
Vector 2 r
-> (Point 2 r :+ c)
-> (Point 2 r :+ a)
-> (Point 2 r :+ b)
-> Ordering
ccwCmpAroundWith' Vector 2 r
sv (Point 2 r -> Point 2 r :+ ()
forall a. a -> a :+ ()
ext Point 2 r
q) ((Point 2 r :+ p) -> (Point 2 r :+ p) -> Ordering)
-> ((Point 2 r :+ p) -> (Point 2 r :+ p) -> Ordering)
-> (Point 2 r :+ p)
-> (Point 2 r :+ p)
-> Ordering
forall a. Semigroup a => a -> a -> a
<> (Point 2 r :+ ())
-> (Point 2 r :+ p) -> (Point 2 r :+ p) -> Ordering
forall r (d :: Nat) c p q.
(Ord r, Num r, Arity d) =>
(Point d r :+ c)
-> (Point d r :+ p) -> (Point d r :+ q) -> Ordering
cmpByDistanceTo' (Point 2 r -> Point 2 r :+ ()
forall a. a -> a :+ ()
ext Point 2 r
q)
    s' :: LineSegment 2 p r :+ e
s'  = LineSegment 2 p r
s LineSegment 2 p r -> e -> LineSegment 2 p r :+ e
forall core extra. core -> extra -> core :+ extra
:+ e
e

    insert :: NonEmpty (Action (LineSegment 2 p r :+ e))
insert = (if Maybe r -> Bool
forall a. Maybe a -> Bool
isJust Maybe r
d then (LineSegment 2 p r :+ e) -> Action (LineSegment 2 p r :+ e)
forall a. a -> Action a
Delete LineSegment 2 p r :+ e
s' else (LineSegment 2 p r :+ e) -> Action (LineSegment 2 p r :+ e)
forall a. a -> Action a
Insert LineSegment 2 p r :+ e
s') Action (LineSegment 2 p r :+ e)
-> [Action (LineSegment 2 p r :+ e)]
-> NonEmpty (Action (LineSegment 2 p r :+ e))
forall a. a -> [a] -> NonEmpty a
:| []
    delete :: NonEmpty (Action (LineSegment 2 p r :+ e))
delete = (if Maybe r -> Bool
forall a. Maybe a -> Bool
isJust Maybe r
d then (LineSegment 2 p r :+ e) -> Action (LineSegment 2 p r :+ e)
forall a. a -> Action a
Insert LineSegment 2 p r :+ e
s' else (LineSegment 2 p r :+ e) -> Action (LineSegment 2 p r :+ e)
forall a. a -> Action a
Delete LineSegment 2 p r :+ e
s') Action (LineSegment 2 p r :+ e)
-> [Action (LineSegment 2 p r :+ e)]
-> NonEmpty (Action (LineSegment 2 p r :+ e))
forall a. a -> [a] -> NonEmpty a
:| []


-- | Handles an event, computes the new status structure and output polygon.
handleEvent                                  :: (Ord r, Fractional r)
                                             => Point 2 r
                                             -> (Status p e r, [Point 2 r :+ Definer p e r])
                                             -> Event p e r
                                             -> (Status p e r, [Point 2 r :+ Definer p e r])
handleEvent :: Point 2 r
-> (Status p e r, [Point 2 r :+ Definer p e r])
-> Event p e r
-> (Status p e r, [Point 2 r :+ Definer p e r])
handleEvent Point 2 r
q (Status p e r
ss,[Point 2 r :+ Definer p e r]
out) (Event (Point 2 r
p :+ p
z) NonEmpty (Action (LineSegment 2 p r :+ e))
acts) = (Status p e r
ss', [Point 2 r :+ Definer p e r]
newVtx [Point 2 r :+ Definer p e r]
-> [Point 2 r :+ Definer p e r] -> [Point 2 r :+ Definer p e r]
forall a. Semigroup a => a -> a -> a
<> [Point 2 r :+ Definer p e r]
out)
  where
    ([LineSegment 2 p r :+ e]
ins,[LineSegment 2 p r :+ e]
dels) = ([Action (LineSegment 2 p r :+ e)] -> [LineSegment 2 p r :+ e])
-> ([Action (LineSegment 2 p r :+ e)] -> [LineSegment 2 p r :+ e])
-> ([Action (LineSegment 2 p r :+ e)],
    [Action (LineSegment 2 p r :+ e)])
-> ([LineSegment 2 p r :+ e], [LineSegment 2 p r :+ e])
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap ((Action (LineSegment 2 p r :+ e) -> LineSegment 2 p r :+ e)
-> [Action (LineSegment 2 p r :+ e)] -> [LineSegment 2 p r :+ e]
forall a b. (a -> b) -> [a] -> [b]
map Action (LineSegment 2 p r :+ e) -> LineSegment 2 p r :+ e
forall a. Action a -> a
extract) ((Action (LineSegment 2 p r :+ e) -> LineSegment 2 p r :+ e)
-> [Action (LineSegment 2 p r :+ e)] -> [LineSegment 2 p r :+ e]
forall a b. (a -> b) -> [a] -> [b]
map Action (LineSegment 2 p r :+ e) -> LineSegment 2 p r :+ e
forall a. Action a -> a
extract) (([Action (LineSegment 2 p r :+ e)],
  [Action (LineSegment 2 p r :+ e)])
 -> ([LineSegment 2 p r :+ e], [LineSegment 2 p r :+ e]))
-> (NonEmpty (Action (LineSegment 2 p r :+ e))
    -> ([Action (LineSegment 2 p r :+ e)],
        [Action (LineSegment 2 p r :+ e)]))
-> NonEmpty (Action (LineSegment 2 p r :+ e))
-> ([LineSegment 2 p r :+ e], [LineSegment 2 p r :+ e])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Action (LineSegment 2 p r :+ e) -> Bool)
-> NonEmpty (Action (LineSegment 2 p r :+ e))
-> ([Action (LineSegment 2 p r :+ e)],
    [Action (LineSegment 2 p r :+ e)])
forall a. (a -> Bool) -> NonEmpty a -> ([a], [a])
NonEmpty.partition Action (LineSegment 2 p r :+ e) -> Bool
forall a. Action a -> Bool
isInsert (NonEmpty (Action (LineSegment 2 p r :+ e))
 -> ([LineSegment 2 p r :+ e], [LineSegment 2 p r :+ e]))
-> NonEmpty (Action (LineSegment 2 p r :+ e))
-> ([LineSegment 2 p r :+ e], [LineSegment 2 p r :+ e])
forall a b. (a -> b) -> a -> b
$ NonEmpty (Action (LineSegment 2 p r :+ e))
acts

    ss' :: Status p e r
ss' = (Status p e r -> [LineSegment 2 p r :+ e] -> Status p e r)
-> [LineSegment 2 p r :+ e] -> Status p e r -> Status p e r
forall a b c. (a -> b -> c) -> b -> a -> c
flip (((LineSegment 2 p r :+ e) -> Status p e r -> Status p e r)
-> Status p e r -> [LineSegment 2 p r :+ e] -> Status p e r
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Point 2 r
-> Point 2 r
-> (LineSegment 2 p r :+ e)
-> Status p e r
-> Status p e r
forall r p e.
(Ord r, Fractional r) =>
Point 2 r
-> Point 2 r
-> (LineSegment 2 p r :+ e)
-> Status p e r
-> Status p e r
insertAt Point 2 r
q Point 2 r
p)) [LineSegment 2 p r :+ e]
ins
        (Status p e r -> Status p e r)
-> (Status p e r -> Status p e r) -> Status p e r -> Status p e r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Status p e r -> [LineSegment 2 p r :+ e] -> Status p e r)
-> [LineSegment 2 p r :+ e] -> Status p e r -> Status p e r
forall a b c. (a -> b -> c) -> b -> a -> c
flip (((LineSegment 2 p r :+ e) -> Status p e r -> Status p e r)
-> Status p e r -> [LineSegment 2 p r :+ e] -> Status p e r
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Point 2 r
-> Point 2 r
-> (LineSegment 2 p r :+ e)
-> Status p e r
-> Status p e r
forall r p e.
(Ord r, Fractional r) =>
Point 2 r
-> Point 2 r
-> (LineSegment 2 p r :+ e)
-> Status p e r
-> Status p e r
deleteAt Point 2 r
q Point 2 r
p)) [LineSegment 2 p r :+ e]
dels
        (Status p e r -> Status p e r) -> Status p e r -> Status p e r
forall a b. (a -> b) -> a -> b
$ Status p e r
ss

    newVtx :: [Point 2 r :+ Definer p e r]
newVtx = let (Point 2 r
a :+ LineSegment 2 p r :+ e
sa) = Point 2 r
-> Point 2 r
-> Status p e r
-> Point 2 r :+ (LineSegment 2 p r :+ e)
forall p r e.
(Ord r, Fractional r) =>
Point 2 r
-> Point 2 r
-> Status p e r
-> Point 2 r :+ (LineSegment 2 p r :+ e)
firstHitAt' Point 2 r
q Point 2 r
p Status p e r
ss
                 (Point 2 r
b :+ LineSegment 2 p r :+ e
sb) = Point 2 r
-> Point 2 r
-> Status p e r
-> Point 2 r :+ (LineSegment 2 p r :+ e)
forall p r e.
(Ord r, Fractional r) =>
Point 2 r
-> Point 2 r
-> Status p e r
-> Point 2 r :+ (LineSegment 2 p r :+ e)
firstHitAt' Point 2 r
q Point 2 r
p Status p e r
ss'
                 ae :: p
ae        = Point 2 r -> (LineSegment 2 p r :+ e) -> p
forall (d :: Nat) r p extra.
(ImplicitPeano (Peano d), Eq r,
 ArityPeano (Peano (FromPeano (Peano d))),
 KnownNat (FromPeano (Peano d)), KnownNat d,
 Peano (FromPeano (Peano d) + 1)
 ~ 'S (Peano (FromPeano (Peano d)))) =>
Point d r -> (LineSegment d p r :+ extra) -> p
valOf Point 2 r
a LineSegment 2 p r :+ e
sa
                 be :: p
be        = Point 2 r -> (LineSegment 2 p r :+ e) -> p
forall (d :: Nat) r p extra.
(ImplicitPeano (Peano d), Eq r,
 ArityPeano (Peano (FromPeano (Peano d))),
 KnownNat (FromPeano (Peano d)), KnownNat d,
 Peano (FromPeano (Peano d) + 1)
 ~ 'S (Peano (FromPeano (Peano d)))) =>
Point d r -> (LineSegment d p r :+ extra) -> p
valOf Point 2 r
b LineSegment 2 p r :+ e
sb
             in case (Point 2 r
a Point 2 r -> Point 2 r -> Bool
forall a. Eq a => a -> a -> Bool
/= Point 2 r
b, Point 2 r
a Point 2 r -> Point 2 r -> Bool
forall a. Eq a => a -> a -> Bool
== Point 2 r
p) of
                  (Bool
True, Bool
_)     -> -- new window of the output polygon discovered
                                   -- figure out who is the closest vertex, (the reflex vtx)
                                   -- and add the appropriate two vertices
                    case Point 2 r -> Point 2 r -> r
forall r (d :: Nat).
(Num r, Arity d) =>
Point d r -> Point d r -> r
squaredEuclideanDist Point 2 r
q Point 2 r
a r -> r -> Bool
forall a. Ord a => a -> a -> Bool
< Point 2 r -> Point 2 r -> r
forall r (d :: Nat).
(Num r, Arity d) =>
Point d r -> Point d r -> r
squaredEuclideanDist Point 2 r
q Point 2 r
b of
                      Bool
True  -> [ Point 2 r
b Point 2 r -> Definer p e r -> Point 2 r :+ Definer p e r
forall core extra. core -> extra -> core :+ extra
:+ (Point 2 r :+ p, LineSegment 2 p r :+ e) -> Definer p e r
forall a b. b -> Either a b
Right (Point 2 r
a Point 2 r -> p -> Point 2 r :+ p
forall core extra. core -> extra -> core :+ extra
:+ p
ae, LineSegment 2 p r :+ e
sb)
                               , Point 2 r
a Point 2 r -> Definer p e r -> Point 2 r :+ Definer p e r
forall core extra. core -> extra -> core :+ extra
:+ p -> Definer p e r
forall a b. a -> Either a b
Left  p
ae  -- a must be a vertex!
                               ]
                      Bool
False -> [ Point 2 r
b Point 2 r -> Definer p e r -> Point 2 r :+ Definer p e r
forall core extra. core -> extra -> core :+ extra
:+ p -> Definer p e r
forall a b. a -> Either a b
Left  p
be
                               , Point 2 r
a Point 2 r -> Definer p e r -> Point 2 r :+ Definer p e r
forall core extra. core -> extra -> core :+ extra
:+ (Point 2 r :+ p, LineSegment 2 p r :+ e) -> Definer p e r
forall a b. b -> Either a b
Right (Point 2 r
b Point 2 r -> p -> Point 2 r :+ p
forall core extra. core -> extra -> core :+ extra
:+ p
be, LineSegment 2 p r :+ e
sa)
                               ]
                  (Bool
False,Bool
True)  -> [ Point 2 r
p Point 2 r -> Definer p e r -> Point 2 r :+ Definer p e r
forall core extra. core -> extra -> core :+ extra
:+ p -> Definer p e r
forall a b. a -> Either a b
Left p
z]
                    -- sweeping over a regular vertex of the visibility polygon
                  (Bool
False,Bool
False) -> []    -- sweeping over a vertex not in output

    valOf :: Point d r -> (LineSegment d p r :+ extra) -> p
valOf Point d r
a (LineSegment' (Point d r
b :+ p
be) (Point d r
_ :+ p
ce) :+ extra
_ ) | Point d r
a Point d r -> Point d r -> Bool
forall a. Eq a => a -> a -> Bool
== Point d r
b    = p
be
                                                     | Bool
otherwise = p
ce



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

-- | Given two points q and p, and a status structure retrieve the
-- first segment in the status structure intersected by the ray from q
-- through p.
--
-- pre: all segments in the status structure should intersect the ray
--      from q through p (in a point), in that order.
--
-- running time: \(O(\log n)\)
firstHitAt     :: forall p r e. (Ord r, Fractional r)
               => Point 2 r -> Point 2 r
               -> Status p e r
               -> Maybe (Point 2 r :+ LineSegment 2 p r :+ e)
firstHitAt :: Point 2 r
-> Point 2 r
-> Status p e r
-> Maybe (Point 2 r :+ (LineSegment 2 p r :+ e))
firstHitAt Point 2 r
q Point 2 r
p = (LineSegment 2 p r :+ e)
-> Maybe (Point 2 r :+ (LineSegment 2 p r :+ e))
computeIntersectionPoint ((LineSegment 2 p r :+ e)
 -> Maybe (Point 2 r :+ (LineSegment 2 p r :+ e)))
-> (Status p e r -> Maybe (LineSegment 2 p r :+ e))
-> Status p e r
-> Maybe (Point 2 r :+ (LineSegment 2 p r :+ e))
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Status p e r -> Maybe (LineSegment 2 p r :+ e)
forall a. Set a -> Maybe a
Set.lookupMin
  where
    computeIntersectionPoint :: (LineSegment 2 p r :+ e)
-> Maybe (Point 2 r :+ (LineSegment 2 p r :+ e))
computeIntersectionPoint LineSegment 2 p r :+ e
s = (Point 2 r -> Point 2 r :+ (LineSegment 2 p r :+ e))
-> Maybe (Point 2 r)
-> Maybe (Point 2 r :+ (LineSegment 2 p r :+ e))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Point 2 r
-> (LineSegment 2 p r :+ e)
-> Point 2 r :+ (LineSegment 2 p r :+ e)
forall core extra. core -> extra -> core :+ extra
:+ LineSegment 2 p r :+ e
s) (Maybe (Point 2 r)
 -> Maybe (Point 2 r :+ (LineSegment 2 p r :+ e)))
-> (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 :+ (LineSegment 2 p r :+ e))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 :+ (LineSegment 2 p r :+ e)))
-> CoRec Identity '[NoIntersection, Point 2 r, Line 2 r]
-> Maybe (Point 2 r :+ (LineSegment 2 p r :+ e))
forall a b. (a -> b) -> a -> b
$ LineSegment 2 p r
-> Line
     (Dimension (LineSegment 2 p r)) (NumType (LineSegment 2 p r))
forall t.
HasSupportingLine t =>
t -> Line (Dimension t) (NumType t)
supportingLine (LineSegment 2 p r :+ e
s(LineSegment 2 p r :+ e)
-> Getting
     (LineSegment 2 p r) (LineSegment 2 p r :+ e) (LineSegment 2 p r)
-> LineSegment 2 p r
forall s a. s -> Getting a s a -> a
^.Getting
  (LineSegment 2 p r) (LineSegment 2 p r :+ e) (LineSegment 2 p r)
forall core extra core'.
Lens (core :+ extra) (core' :+ extra) core core'
core) 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` Point 2 r -> Point 2 r -> Line 2 r
forall r (d :: Nat).
(Num r, Arity d) =>
Point d r -> Point d r -> Line d r
lineThrough Point 2 r
p Point 2 r
q

-- | Given two points q and p, and a status structure retrieve the
-- first segment in the status structure intersected by the ray from q
-- through p.
--
-- pre: - all segments in the status structure should intersect the ray
--        from q through p (in a point), in that order.
--      - the status structure is non-empty
--
-- running time: \(O(\log n)\)
firstHitAt'        :: forall p r e. (Ord r, Fractional r)
                  => Point 2 r -> Point 2 r
                  -> Status p e r
                  -> Point 2 r :+ LineSegment 2 p r :+ e
firstHitAt' :: Point 2 r
-> Point 2 r
-> Status p e r
-> Point 2 r :+ (LineSegment 2 p r :+ e)
firstHitAt' Point 2 r
q Point 2 r
p Status p e r
s = case Point 2 r
-> Point 2 r
-> Status p e r
-> Maybe (Point 2 r :+ (LineSegment 2 p r :+ e))
forall p r e.
(Ord r, Fractional r) =>
Point 2 r
-> Point 2 r
-> Status p e r
-> Maybe (Point 2 r :+ (LineSegment 2 p r :+ e))
firstHitAt Point 2 r
q Point 2 r
p Status p e r
s of
                      Just Point 2 r :+ (LineSegment 2 p r :+ e)
x  -> Point 2 r :+ (LineSegment 2 p r :+ e)
x
                      Maybe (Point 2 r :+ (LineSegment 2 p r :+ e))
Nothing -> String -> Point 2 r :+ (LineSegment 2 p r :+ e)
forall a. HasCallStack => String -> a
error String
"firstHitAt: precondition failed!"

--------------------------------------------------------------------------------
-- * Status Structure Operations

-- | Insert a new segment into the status structure, depending on the
-- (distance from q to to the) intersection point with the ray from q
-- through p
--
-- pre: all segments in the status structure should intersect the ray
--      from q through p, in that order.
--
-- \(O(\log n)\)
insertAt     :: (Ord r, Fractional r)
             => Point 2 r -> Point 2 r -> LineSegment 2 p r :+ e
             -> Status p e r -> Status p e r
insertAt :: Point 2 r
-> Point 2 r
-> (LineSegment 2 p r :+ e)
-> Status p e r
-> Status p e r
insertAt Point 2 r
q Point 2 r
p = ((LineSegment 2 p r :+ e) -> (LineSegment 2 p r :+ e) -> Ordering)
-> (LineSegment 2 p r :+ e) -> Status p e r -> Status p e r
forall a. (a -> a -> Ordering) -> a -> Set a -> Set a
Set.insertBy (Point 2 r
-> Point 2 r
-> (LineSegment 2 p r :+ e)
-> (LineSegment 2 p r :+ e)
-> Ordering
forall p r e.
(Ord r, Fractional r) =>
Point 2 r
-> Point 2 r
-> (LineSegment 2 p r :+ e)
-> (LineSegment 2 p r :+ e)
-> Ordering
compareByDistanceToAt Point 2 r
q Point 2 r
p ((LineSegment 2 p r :+ e) -> (LineSegment 2 p r :+ e) -> Ordering)
-> ((LineSegment 2 p r :+ e)
    -> (LineSegment 2 p r :+ e) -> Ordering)
-> (LineSegment 2 p r :+ e)
-> (LineSegment 2 p r :+ e)
-> Ordering
forall a. Semigroup a => a -> a -> a
<> ((LineSegment 2 p r :+ e) -> (LineSegment 2 p r :+ e) -> Ordering)
-> (LineSegment 2 p r :+ e) -> (LineSegment 2 p r :+ e) -> Ordering
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Point 2 r
-> (LineSegment 2 p r :+ e) -> (LineSegment 2 p r :+ e) -> Ordering
forall p r e.
(Ord r, Fractional r) =>
Point 2 r
-> (LineSegment 2 p r :+ e) -> (LineSegment 2 p r :+ e) -> Ordering
compareAroundEndPoint Point 2 r
q))
  -- if two segments have the same distance, they must share and endpoint
  -- so we use the CCW ordering around this common endpoint to determine
  -- the order.

-- | Delete a segment from the status structure, depending on the
-- (distance from q to to the) intersection point with the ray from q
-- through p
--
-- pre: all segments in the status structure should intersect the ray
--      from q through p, in that order.
--
-- \(O(\log n)\)
deleteAt     :: (Ord r, Fractional r)
             => Point 2 r -> Point 2 r -> LineSegment 2 p r :+ e
             -> Status p e r -> Status p e r
deleteAt :: Point 2 r
-> Point 2 r
-> (LineSegment 2 p r :+ e)
-> Status p e r
-> Status p e r
deleteAt Point 2 r
q Point 2 r
p = ((LineSegment 2 p r :+ e) -> (LineSegment 2 p r :+ e) -> Ordering)
-> (LineSegment 2 p r :+ e) -> Status p e r -> Status p e r
forall a. (a -> a -> Ordering) -> a -> Set a -> Set a
Set.deleteAllBy (Point 2 r
-> Point 2 r
-> (LineSegment 2 p r :+ e)
-> (LineSegment 2 p r :+ e)
-> Ordering
forall p r e.
(Ord r, Fractional r) =>
Point 2 r
-> Point 2 r
-> (LineSegment 2 p r :+ e)
-> (LineSegment 2 p r :+ e)
-> Ordering
compareByDistanceToAt Point 2 r
q Point 2 r
p ((LineSegment 2 p r :+ e) -> (LineSegment 2 p r :+ e) -> Ordering)
-> ((LineSegment 2 p r :+ e)
    -> (LineSegment 2 p r :+ e) -> Ordering)
-> (LineSegment 2 p r :+ e)
-> (LineSegment 2 p r :+ e)
-> Ordering
forall a. Semigroup a => a -> a -> a
<> Point 2 r
-> (LineSegment 2 p r :+ e) -> (LineSegment 2 p r :+ e) -> Ordering
forall p r e.
(Ord r, Fractional r) =>
Point 2 r
-> (LineSegment 2 p r :+ e) -> (LineSegment 2 p r :+ e) -> Ordering
compareAroundEndPoint Point 2 r
q)
  -- if two segments have the same distance, we use the ccw order around their common
  -- (end) point.

-- FIXME: If there are somehow segmetns that would continue at p as
-- well, they are also deleted.


-- | Given a list of line segments, each labeled with the distance
-- from their intersection point with the initial ray to the query
-- point, build the initial status structure.
mkInitialSS :: forall r p e. (Ord r, Fractional r)
            => [ LineSegment 2 p r :+ (Maybe r, e)] -> Status p e r
mkInitialSS :: [LineSegment 2 p r :+ (Maybe r, e)] -> Status p e r
mkInitialSS = ((r :+ (LineSegment 2 p r :+ e)) -> LineSegment 2 p r :+ e)
-> Set (r :+ (LineSegment 2 p r :+ e)) -> Status p e r
forall a b. (a -> b) -> Set a -> Set b
Set.mapMonotonic ((r :+ (LineSegment 2 p r :+ e))
-> Getting
     (LineSegment 2 p r :+ e)
     (r :+ (LineSegment 2 p r :+ e))
     (LineSegment 2 p r :+ e)
-> LineSegment 2 p r :+ e
forall s a. s -> Getting a s a -> a
^.Getting
  (LineSegment 2 p r :+ e)
  (r :+ (LineSegment 2 p r :+ e))
  (LineSegment 2 p r :+ e)
forall core extra extra'.
Lens (core :+ extra) (core :+ extra') extra extra'
extra)
            (Set (r :+ (LineSegment 2 p r :+ e)) -> Status p e r)
-> ([LineSegment 2 p r :+ (Maybe r, e)]
    -> Set (r :+ (LineSegment 2 p r :+ e)))
-> [LineSegment 2 p r :+ (Maybe r, e)]
-> Status p e r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((r :+ (LineSegment 2 p r :+ e))
 -> Set (r :+ (LineSegment 2 p r :+ e))
 -> Set (r :+ (LineSegment 2 p r :+ e)))
-> Set (r :+ (LineSegment 2 p r :+ e))
-> [r :+ (LineSegment 2 p r :+ e)]
-> Set (r :+ (LineSegment 2 p r :+ e))
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (((r :+ (LineSegment 2 p r :+ e))
 -> (r :+ (LineSegment 2 p r :+ e)) -> Ordering)
-> (r :+ (LineSegment 2 p r :+ e))
-> Set (r :+ (LineSegment 2 p r :+ e))
-> Set (r :+ (LineSegment 2 p r :+ e))
forall a. (a -> a -> Ordering) -> a -> Set a -> Set a
Set.insertBy (((r :+ (LineSegment 2 p r :+ e))
  -> (r :+ (LineSegment 2 p r :+ e)) -> Ordering)
 -> (r :+ (LineSegment 2 p r :+ e))
 -> Set (r :+ (LineSegment 2 p r :+ e))
 -> Set (r :+ (LineSegment 2 p r :+ e)))
-> ((r :+ (LineSegment 2 p r :+ e))
    -> (r :+ (LineSegment 2 p r :+ e)) -> Ordering)
-> (r :+ (LineSegment 2 p r :+ e))
-> Set (r :+ (LineSegment 2 p r :+ e))
-> Set (r :+ (LineSegment 2 p r :+ e))
forall a b. (a -> b) -> a -> b
$ ((r :+ (LineSegment 2 p r :+ e)) -> r)
-> (r :+ (LineSegment 2 p r :+ e))
-> (r :+ (LineSegment 2 p r :+ e))
-> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing ((r :+ (LineSegment 2 p r :+ e))
-> Getting r (r :+ (LineSegment 2 p r :+ e)) r -> r
forall s a. s -> Getting a s a -> a
^.Getting r (r :+ (LineSegment 2 p r :+ e)) r
forall core extra core'.
Lens (core :+ extra) (core' :+ extra) core core'
core)) Set (r :+ (LineSegment 2 p r :+ e))
forall a. Set a
Set.empty
            ([r :+ (LineSegment 2 p r :+ e)]
 -> Set (r :+ (LineSegment 2 p r :+ e)))
-> ([LineSegment 2 p r :+ (Maybe r, e)]
    -> [r :+ (LineSegment 2 p r :+ e)])
-> [LineSegment 2 p r :+ (Maybe r, e)]
-> Set (r :+ (LineSegment 2 p r :+ e))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((LineSegment 2 p r :+ (Maybe r, e))
 -> Maybe (r :+ (LineSegment 2 p r :+ e)))
-> [LineSegment 2 p r :+ (Maybe r, e)]
-> [r :+ (LineSegment 2 p r :+ e)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\(LineSegment 2 p r
s :+ (Maybe r
md,e
e)) -> (r -> (LineSegment 2 p r :+ e) -> r :+ (LineSegment 2 p r :+ e)
forall core extra. core -> extra -> core :+ extra
:+ (LineSegment 2 p r
s LineSegment 2 p r -> e -> LineSegment 2 p r :+ e
forall core extra. core -> extra -> core :+ extra
:+ e
e)) (r -> r :+ (LineSegment 2 p r :+ e))
-> Maybe r -> Maybe (r :+ (LineSegment 2 p r :+ e))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe r
md)

-- | Given q, the initial ray, and a segment s, computes if the
-- segment intersects the initial, rightward ray starting in q, and if
-- so returns the (squared) distance from q to that point together
-- with the segment.
initialIntersection         :: forall r p. (Ord r, Fractional r)
                            => Point 2 r -> HalfLine 2 r -> LineSegment 2 p r
                            -> Maybe r
initialIntersection :: Point 2 r -> HalfLine 2 r -> LineSegment 2 p r -> Maybe r
initialIntersection Point 2 r
q HalfLine 2 r
ray LineSegment 2 p r
s =
    case 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, LineSegment 2 () r]
 -> Maybe (Point 2 r))
-> CoRec Identity '[NoIntersection, Point 2 r, LineSegment 2 () r]
-> Maybe (Point 2 r)
forall a b. (a -> b) -> a -> b
$ LineSegment 2 () r
seg LineSegment 2 () r
-> HalfLine 2 r -> Intersection (LineSegment 2 () r) (HalfLine 2 r)
forall g h. IsIntersectableWith g h => g -> h -> Intersection g h
`intersect` HalfLine 2 r
ray of
      Maybe (Point 2 r)
Nothing -> Maybe r
forall a. Maybe a
Nothing
      Just Point 2 r
z  -> r -> Maybe r
forall a. a -> Maybe a
Just (r -> Maybe r) -> r -> Maybe r
forall a b. (a -> b) -> a -> b
$ Point 2 r -> Point 2 r -> r
forall r (d :: Nat).
(Num r, Arity d) =>
Point d r -> Point d r -> r
squaredEuclideanDist Point 2 r
q Point 2 r
z
  where
    seg :: LineSegment 2 () r
seg = (p -> ()) -> LineSegment 2 p r -> LineSegment 2 () r
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (() -> p -> ()
forall a b. a -> b -> a
const ()) LineSegment 2 p r
s

-- | Labels the segments with the distance from q to their
-- intersection point with the ray.
labelWithDistances       :: (Ord r, Fractional r)
                         => Point 2 r -> HalfLine 2 r -> [LineSegment 2 p r :+ b]
                         -> [LineSegment 2 p r :+ (Maybe r, b)]
labelWithDistances :: Point 2 r
-> HalfLine 2 r
-> [LineSegment 2 p r :+ b]
-> [LineSegment 2 p r :+ (Maybe r, b)]
labelWithDistances Point 2 r
q HalfLine 2 r
ray = ((LineSegment 2 p r :+ b) -> LineSegment 2 p r :+ (Maybe r, b))
-> [LineSegment 2 p r :+ b] -> [LineSegment 2 p r :+ (Maybe r, b)]
forall a b. (a -> b) -> [a] -> [b]
map (\(LineSegment 2 p r
s :+ b
e) -> LineSegment 2 p r
s LineSegment 2 p r
-> (Maybe r, b) -> LineSegment 2 p r :+ (Maybe r, b)
forall core extra. core -> extra -> core :+ extra
:+ (Point 2 r -> HalfLine 2 r -> LineSegment 2 p r -> Maybe r
forall r p.
(Ord r, Fractional r) =>
Point 2 r -> HalfLine 2 r -> LineSegment 2 p r -> Maybe r
initialIntersection Point 2 r
q HalfLine 2 r
ray LineSegment 2 p r
s, b
e))

--------------------------------------------------------------------------------
-- * Comparators for the rotating ray

-- | Given two points q and p, and two segments a and b that are guaranteed to
-- intersect the ray from q through p once, order the segments by their
-- intersection point
compareByDistanceToAt     :: forall p r e. (Ord r, Fractional r)
                          => Point 2 r -> Point 2 r
                          -> LineSegment 2 p r :+ e
                          -> LineSegment 2 p r :+ e
                          -> Ordering
compareByDistanceToAt :: Point 2 r
-> Point 2 r
-> (LineSegment 2 p r :+ e)
-> (LineSegment 2 p r :+ e)
-> Ordering
compareByDistanceToAt Point 2 r
q Point 2 r
p = ((LineSegment 2 p r :+ e) -> Maybe r)
-> (LineSegment 2 p r :+ e) -> (LineSegment 2 p r :+ e) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (LineSegment 2 p r :+ e) -> Maybe r
f
  where
    f :: (LineSegment 2 p r :+ e) -> Maybe r
f (LineSegment 2 p r
s :+ e
_) = (Point 2 r -> r) -> Maybe (Point 2 r) -> Maybe r
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Point 2 r -> Point 2 r -> r
forall r (d :: Nat).
(Num r, Arity d) =>
Point d r -> Point d r -> r
squaredEuclideanDist Point 2 r
q)
               (Maybe (Point 2 r) -> Maybe r)
-> (CoRec Identity '[NoIntersection, Point 2 r, Line 2 r]
    -> Maybe (Point 2 r))
-> CoRec Identity '[NoIntersection, Point 2 r, Line 2 r]
-> Maybe r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 r)
-> CoRec Identity '[NoIntersection, Point 2 r, Line 2 r] -> Maybe r
forall a b. (a -> b) -> a -> b
$ LineSegment 2 p r
-> Line
     (Dimension (LineSegment 2 p r)) (NumType (LineSegment 2 p r))
forall t.
HasSupportingLine t =>
t -> Line (Dimension t) (NumType t)
supportingLine LineSegment 2 p r
s 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` Point 2 r -> Point 2 r -> Line 2 r
forall r (d :: Nat).
(Num r, Arity d) =>
Point d r -> Point d r -> Line d r
lineThrough Point 2 r
p Point 2 r
q

-- | Given two segments that share an endpoint, order them by their
-- order around this common endpoint. I.e. if uv and uw share endpoint
-- u we uv is considered smaller iff v is smaller than w in the
-- counterclockwise order around u (treating the direction from q to
-- the common endpoint as zero).
compareAroundEndPoint  :: forall p r e. (Ord r, Fractional r)
                       => Point 2 r
                       -> LineSegment 2 p r :+ e
                       -> LineSegment 2 p r :+ e
                       -> Ordering
compareAroundEndPoint :: Point 2 r
-> (LineSegment 2 p r :+ e) -> (LineSegment 2 p r :+ e) -> Ordering
compareAroundEndPoint Point 2 r
q
                      (LineSegment' Point 2 r :+ p
a Point 2 r :+ p
b :+ e
_)
                      (LineSegment' Point 2 r :+ p
s Point 2 r :+ p
t :+ e
_)
    -- traceshow ("comapreAroundEndPoint ", sa, sb) False = undefined
    | Point 2 r :+ p
a(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 -> Point 2 r -> Bool
forall a. Eq a => a -> a -> Bool
== Point 2 r :+ p
s(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 = Vector 2 r
-> (Point 2 r :+ p)
-> (Point 2 r :+ p)
-> (Point 2 r :+ p)
-> Ordering
forall r c a b.
(Ord r, Num r) =>
Vector 2 r
-> (Point 2 r :+ c)
-> (Point 2 r :+ a)
-> (Point 2 r :+ b)
-> Ordering
ccwCmpAroundWith' (Point 2 r :+ p
a(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 -> Point 2 r -> Diff (Point 2) r
forall (p :: * -> *) a. (Affine p, Num a) => p a -> p a -> Diff p a
.-. Point 2 r
q) Point 2 r :+ p
a Point 2 r :+ p
b Point 2 r :+ p
t
    | Point 2 r :+ p
a(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 -> Point 2 r -> Bool
forall a. Eq a => a -> a -> Bool
== Point 2 r :+ p
t(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 = Vector 2 r
-> (Point 2 r :+ p)
-> (Point 2 r :+ p)
-> (Point 2 r :+ p)
-> Ordering
forall r c a b.
(Ord r, Num r) =>
Vector 2 r
-> (Point 2 r :+ c)
-> (Point 2 r :+ a)
-> (Point 2 r :+ b)
-> Ordering
ccwCmpAroundWith' (Point 2 r :+ p
a(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 -> Point 2 r -> Diff (Point 2) r
forall (p :: * -> *) a. (Affine p, Num a) => p a -> p a -> Diff p a
.-. Point 2 r
q) Point 2 r :+ p
a Point 2 r :+ p
b Point 2 r :+ p
s
    | Point 2 r :+ p
b(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 -> Point 2 r -> Bool
forall a. Eq a => a -> a -> Bool
== Point 2 r :+ p
s(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 = Vector 2 r
-> (Point 2 r :+ p)
-> (Point 2 r :+ p)
-> (Point 2 r :+ p)
-> Ordering
forall r c a b.
(Ord r, Num r) =>
Vector 2 r
-> (Point 2 r :+ c)
-> (Point 2 r :+ a)
-> (Point 2 r :+ b)
-> Ordering
ccwCmpAroundWith' (Point 2 r :+ p
b(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 -> Point 2 r -> Diff (Point 2) r
forall (p :: * -> *) a. (Affine p, Num a) => p a -> p a -> Diff p a
.-. Point 2 r
q) Point 2 r :+ p
b Point 2 r :+ p
a Point 2 r :+ p
t
    | Point 2 r :+ p
b(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 -> Point 2 r -> Bool
forall a. Eq a => a -> a -> Bool
== Point 2 r :+ p
t(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 = Vector 2 r
-> (Point 2 r :+ p)
-> (Point 2 r :+ p)
-> (Point 2 r :+ p)
-> Ordering
forall r c a b.
(Ord r, Num r) =>
Vector 2 r
-> (Point 2 r :+ c)
-> (Point 2 r :+ a)
-> (Point 2 r :+ b)
-> Ordering
ccwCmpAroundWith' (Point 2 r :+ p
b(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 -> Point 2 r -> Diff (Point 2) r
forall (p :: * -> *) a. (Affine p, Num a) => p a -> p a -> Diff p a
.-. Point 2 r
q) Point 2 r :+ p
b Point 2 r :+ p
a Point 2 r :+ p
s
    | Bool
otherwise          = String -> Ordering
forall a. HasCallStack => String -> a
error String
"compareAroundEndPoint: precondition failed!"

--------------------------------------------------------------------------------
-- * Helper functions for polygon operations

-- | Given q, and two consecutive points u and v, Computes a direction
-- for the initial ray, i.e. a "generic" ray that does not go through
-- any vertices.
startingDirection       :: Fractional r => Point 2 r -> Point 2 r -> Point 2 r -> Vector 2 r
startingDirection :: Point 2 r -> Point 2 r -> Point 2 r -> Vector 2 r
startingDirection Point 2 r
q Point 2 r
u Point 2 r
w = Point 2 r
v Point 2 r -> Point 2 r -> Diff (Point 2) r
forall (p :: * -> *) a. (Affine p, Num a) => p a -> p a -> Diff p a
.-. Point 2 r
q
  where
    v :: Point 2 r
v = Point 2 r
u Point 2 r -> Diff (Point 2) r -> Point 2 r
forall (p :: * -> *) a. (Affine p, Num a) => p a -> Diff p a -> p a
.+^ ((Point 2 r
w Point 2 r -> Point 2 r -> Diff (Point 2) r
forall (p :: * -> *) a. (Affine p, Num a) => p a -> p a -> Diff p a
.-. Point 2 r
u) Vector 2 r -> r -> Vector 2 r
forall (f :: * -> *) a.
(Functor f, Fractional a) =>
f a -> a -> f a
^/ r
2) -- point in the middle between u and w
        -- note: the segment between u and w could pass on the wrong side of q
        -- (i.e. so that does not "cover" the CCW but the CW range between u and w)
        -- however, in that case there is apparently nothing on the CCW side opposite
        -- to v, as u and w are supposed to be the first two events. This means the
        -- precondition does not hold.

-- | finds two consecutive vertices in the clockwise order around the
-- given point q. I.e. there are no other points in between the two
-- returned points.
consecutive                   :: (Ord r, Num r) => Point 2 r -> NonEmpty (Point 2 r :+ p)
                              -> (Point 2 r, Point 2 r)
consecutive :: Point 2 r -> NonEmpty (Point 2 r :+ p) -> (Point 2 r, Point 2 r)
consecutive Point 2 r
q ((Point 2 r
p :+ p
_):|[Point 2 r :+ p]
pts) = (Point 2 r
p,Vector 2 r -> Point 2 r -> [Point 2 r :+ p] -> Point 2 r
forall r p.
(Ord r, Num r) =>
Vector 2 r -> Point 2 r -> [Point 2 r :+ p] -> Point 2 r
consecutiveFrom (Point 2 r
p Point 2 r -> Point 2 r -> Diff (Point 2) r
forall (p :: * -> *) a. (Affine p, Num a) => p a -> p a -> Diff p a
.-. Point 2 r
q) Point 2 r
q [Point 2 r :+ p]
pts)

-- | pre: input list is non-empty
consecutiveFrom     :: (Ord r, Num r)
                    => Vector 2 r -- ^ starting vector
                    -> Point 2 r -- ^ query point
                    -> [Point 2 r :+ p] -> Point 2 r
consecutiveFrom :: Vector 2 r -> Point 2 r -> [Point 2 r :+ p] -> Point 2 r
consecutiveFrom Vector 2 r
v Point 2 r
q = 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 ((Point 2 r :+ p) -> Point 2 r)
-> ([Point 2 r :+ p] -> Point 2 r :+ p)
-> [Point 2 r :+ p]
-> Point 2 r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Point 2 r :+ p) -> (Point 2 r :+ p) -> Ordering)
-> [Point 2 r :+ p] -> Point 2 r :+ p
forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
List.minimumBy (Vector 2 r
-> (Point 2 r :+ ())
-> (Point 2 r :+ p)
-> (Point 2 r :+ p)
-> Ordering
forall r c a b.
(Ord r, Num r) =>
Vector 2 r
-> (Point 2 r :+ c)
-> (Point 2 r :+ a)
-> (Point 2 r :+ b)
-> Ordering
ccwCmpAroundWith' Vector 2 r
v (Point 2 r -> Point 2 r :+ ()
forall a. a -> a :+ ()
ext Point 2 r
q))

-- | Gets the edges of the polygon as closed line segments.
closedEdges :: Polygon t p r -> [LineSegment 2 p r]
closedEdges :: Polygon t p r -> [LineSegment 2 p r]
closedEdges = (LineSegment 2 p r -> LineSegment 2 p r)
-> [LineSegment 2 p r] -> [LineSegment 2 p r]
forall a b. (a -> b) -> [a] -> [b]
map LineSegment 2 p r -> LineSegment 2 p r
forall (d :: Nat) p r. LineSegment d p r -> LineSegment d p r
asClosed ([LineSegment 2 p r] -> [LineSegment 2 p r])
-> (Polygon t p r -> [LineSegment 2 p r])
-> Polygon t p r
-> [LineSegment 2 p r]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Polygon t p r -> [LineSegment 2 p r]
forall (t :: PolygonType) p r. Polygon t p r -> [LineSegment 2 p r]
listEdges
  where
    asClosed :: LineSegment d p r -> LineSegment d p r
asClosed (LineSegment' Point d r :+ p
u Point d r :+ p
v) = (Point d r :+ p) -> (Point d r :+ p) -> LineSegment d p r
forall (d :: Nat) r p.
(Point d r :+ p) -> (Point d r :+ p) -> LineSegment d p r
ClosedLineSegment Point d r :+ p
u Point d r :+ p
v


--------------------------------------------------------------------------------
-- * Generic Helper functions



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

test :: StarShapedPolygon (Definer Int () R) R
test :: StarShapedPolygon (Definer Int () R) R
test = Point 2 R
-> Polygon 'Simple Int R -> StarShapedPolygon (Definer Int () R) R
forall p (t :: PolygonType) r.
(Ord r, Fractional r) =>
Point 2 r -> Polygon t p r -> StarShapedPolygon (Definer p () r) r
visibilityPolygon Point 2 R
forall (d :: Nat) r. (Arity d, Num r) => Point d r
origin Polygon 'Simple Int R
testPg

testVtx :: StarShapedPolygon (Definer Int () R) R
testVtx = Polygon 'Simple Int R
-> Int -> StarShapedPolygon (Definer Int () R) R
forall p (t :: PolygonType) r.
(Ord r, Fractional r, Show r, Show p) =>
Polygon t p r -> Int -> VisibilityPolygon p () r
visibilityPolygonFromVertex Polygon 'Simple Int R
testPg Int
0

testPg :: SimplePolygon Int R
testPg :: Polygon 'Simple Int R
testPg = [Point 2 R :+ Int] -> Polygon 'Simple Int R
forall p r. (Eq r, Num r) => [Point 2 r :+ p] -> SimplePolygon p r
fromPoints ([Point 2 R :+ Int] -> Polygon 'Simple Int R)
-> [Point 2 R :+ Int] -> Polygon 'Simple Int R
forall a b. (a -> b) -> a -> b
$ (Point 2 R -> Int -> Point 2 R :+ Int)
-> [Point 2 R] -> [Int] -> [Point 2 R :+ Int]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Point 2 R -> Int -> Point 2 R :+ Int
forall core extra. core -> extra -> core :+ extra
(:+) [ R -> R -> Point 2 R
forall r. r -> r -> Point 2 r
Point2 R
3    R
1
                                   , R -> R -> Point 2 R
forall r. r -> r -> Point 2 r
Point2 R
3    R
2
                                   , R -> R -> Point 2 R
forall r. r -> r -> Point 2 r
Point2 R
4    R
2
                                   , R -> R -> Point 2 R
forall r. r -> r -> Point 2 r
Point2 R
2    R
4
                                   , R -> R -> Point 2 R
forall r. r -> r -> Point 2 r
Point2 (-R
1) R
4
                                   , R -> R -> Point 2 R
forall r. r -> r -> Point 2 r
Point2 R
1    R
2
                                   , R -> R -> Point 2 R
forall r. r -> r -> Point 2 r
Point2 (-R
3) (-R
1)
                                   , R -> R -> Point 2 R
forall r. r -> r -> Point 2 r
Point2 R
4    (-R
1)
                                   ] [Int
1..]

testPg2 :: SimplePolygon Int R
testPg2 :: Polygon 'Simple Int R
testPg2 = [Point 2 R :+ Int] -> Polygon 'Simple Int R
forall p r. (Eq r, Num r) => [Point 2 r :+ p] -> SimplePolygon p r
fromPoints ([Point 2 R :+ Int] -> Polygon 'Simple Int R)
-> [Point 2 R :+ Int] -> Polygon 'Simple Int R
forall a b. (a -> b) -> a -> b
$ (Point 2 R -> Int -> Point 2 R :+ Int)
-> [Point 2 R] -> [Int] -> [Point 2 R :+ Int]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Point 2 R -> Int -> Point 2 R :+ Int
forall core extra. core -> extra -> core :+ extra
(:+) [ R -> R -> Point 2 R
forall r. r -> r -> Point 2 r
Point2 R
3    R
1
                                    , R -> R -> Point 2 R
forall r. r -> r -> Point 2 r
Point2 R
3    R
2
                                    , R -> R -> Point 2 R
forall r. r -> r -> Point 2 r
Point2 R
4    R
2
                                    , R -> R -> Point 2 R
forall r. r -> r -> Point 2 r
Point2 R
2    R
4
                                    , R -> R -> Point 2 R
forall r. r -> r -> Point 2 r
Point2 (-R
1) R
4
                                    , R -> R -> Point 2 R
forall r. r -> r -> Point 2 r
Point2 R
1    R
2.1
                                    , R -> R -> Point 2 R
forall r. r -> r -> Point 2 r
Point2 (-R
3) (-R
1)
                                    , R -> R -> Point 2 R
forall r. r -> r -> Point 2 r
Point2 R
4    (-R
1)
                                    ] [Int
1..]



traceShowIdWith :: a -> b -> b
traceShowIdWith a
x b
y = (String, b) -> b -> b
forall a b. Show a => a -> b -> b
traceShow (a -> String
forall a. Show a => a -> String
show a
x,b
y) b
y