{-# Language TemplateHaskell #-}
--------------------------------------------------------------------------------
-- |
-- Module      :  Data.Geometry.VerticalRayShooting.PersistentSweep
-- Copyright   :  (C) Frank Staals
-- License     :  see the LICENSE file
-- Maintainer  :  Frank Staals
--------------------------------------------------------------------------------
module Data.Geometry.VerticalRayShooting.PersistentSweep
  ( VerticalRayShootingStructure(VerticalRayShootingStructure), StatusStructure
  , leftMost, sweepStruct

  -- * Building the Data Structure
  , verticalRayShootingStructure
  -- * Querying the Data Structure
  , segmentAbove, segmentAboveOrOn
  , findSlab
  , lookupAbove, lookupAboveOrOn, searchInSlab
  , ordAt, yCoordAt
  ) where

import           Algorithms.BinarySearch (binarySearchIn)
import           Control.Lens hiding (contains, below)
import           Data.Ext
import           Data.Foldable (toList)
import           Data.Geometry.Line
import           Data.Geometry.LineSegment
import           Data.Geometry.Point
import qualified Data.List as List
import           Data.List.NonEmpty (NonEmpty(..))
import qualified Data.List.NonEmpty as NonEmpty
import           Data.Maybe (mapMaybe)
import           Data.Ord (comparing)
import           Data.Semigroup.Foldable
import qualified Data.Set as SS -- status struct
import qualified Data.Set.Util as SS
import qualified Data.Vector as V


import           Data.RealNumber.Rational

type R = RealNumber 5
--------------------------------------------------------------------------------

-- | The vertical ray shooting data structure
data VerticalRayShootingStructure p e r =
    VerticalRayShootingStructure { VerticalRayShootingStructure p e r -> r
_leftMost    :: r
                                 , VerticalRayShootingStructure p e r
-> Vector (r :+ StatusStructure p e r)
_sweepStruct :: V.Vector (r :+ StatusStructure p e r)
                                   -- ^ entry (r :+ s) means that "just" left of "r" the
                                   -- status structure is 's', i.e up to 'r'
                                 } deriving (Int -> VerticalRayShootingStructure p e r -> ShowS
[VerticalRayShootingStructure p e r] -> ShowS
VerticalRayShootingStructure p e r -> String
(Int -> VerticalRayShootingStructure p e r -> ShowS)
-> (VerticalRayShootingStructure p e r -> String)
-> ([VerticalRayShootingStructure p e r] -> ShowS)
-> Show (VerticalRayShootingStructure 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 -> VerticalRayShootingStructure p e r -> ShowS
forall p e r.
(Show r, Show p, Show e) =>
[VerticalRayShootingStructure p e r] -> ShowS
forall p e r.
(Show r, Show p, Show e) =>
VerticalRayShootingStructure p e r -> String
showList :: [VerticalRayShootingStructure p e r] -> ShowS
$cshowList :: forall p e r.
(Show r, Show p, Show e) =>
[VerticalRayShootingStructure p e r] -> ShowS
show :: VerticalRayShootingStructure p e r -> String
$cshow :: forall p e r.
(Show r, Show p, Show e) =>
VerticalRayShootingStructure p e r -> String
showsPrec :: Int -> VerticalRayShootingStructure p e r -> ShowS
$cshowsPrec :: forall p e r.
(Show r, Show p, Show e) =>
Int -> VerticalRayShootingStructure p e r -> ShowS
Show,VerticalRayShootingStructure p e r
-> VerticalRayShootingStructure p e r -> Bool
(VerticalRayShootingStructure p e r
 -> VerticalRayShootingStructure p e r -> Bool)
-> (VerticalRayShootingStructure p e r
    -> VerticalRayShootingStructure p e r -> Bool)
-> Eq (VerticalRayShootingStructure p e r)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall p e r.
(Eq r, Eq p, Eq e) =>
VerticalRayShootingStructure p e r
-> VerticalRayShootingStructure p e r -> Bool
/= :: VerticalRayShootingStructure p e r
-> VerticalRayShootingStructure p e r -> Bool
$c/= :: forall p e r.
(Eq r, Eq p, Eq e) =>
VerticalRayShootingStructure p e r
-> VerticalRayShootingStructure p e r -> Bool
== :: VerticalRayShootingStructure p e r
-> VerticalRayShootingStructure p e r -> Bool
$c== :: forall p e r.
(Eq r, Eq p, Eq e) =>
VerticalRayShootingStructure p e r
-> VerticalRayShootingStructure p e r -> Bool
Eq)

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

makeLensesWith (lensRules&generateUpdateableOptics .~ False) ''VerticalRayShootingStructure

--------------------------------------------------------------------------------
-- * Building the DS

-- | Given a set of \(n\) interiorly pairwise disjoint *closed* segments,
-- compute a vertical ray shooting data structure.  (i.e. the
-- endpoints of the segments may coincide).
--
-- pre: no vertical segments
--
-- running time: \(O(n\log n)\).
-- space: \(O(n\log n)\).
verticalRayShootingStructure   :: (Ord r, Fractional r, Foldable1 t)
                               => t (LineSegment 2 p r :+ e)
                               -> VerticalRayShootingStructure p e r
verticalRayShootingStructure :: t (LineSegment 2 p r :+ e) -> VerticalRayShootingStructure p e r
verticalRayShootingStructure t (LineSegment 2 p r :+ e)
ss = r
-> Vector (r :+ StatusStructure p e r)
-> VerticalRayShootingStructure p e r
forall p e r.
r
-> Vector (r :+ StatusStructure p e r)
-> VerticalRayShootingStructure p e r
VerticalRayShootingStructure (Event p e r -> r
forall p e r. Event p e r -> r
eventX Event p e r
e) (NonEmpty (Event p e r) -> Vector (r :+ StatusStructure p e r)
forall p e.
NonEmpty (Event p e r) -> Vector (r :+ StatusStructure p e r)
sweep' NonEmpty (Event p e r)
events)
  where
    events :: NonEmpty (Event p e r)
events@(Event p e r
e :| [Event p e r]
_) = (NonEmpty (Event p e r) -> Event p e r)
-> NonEmpty (NonEmpty (Event p e r)) -> NonEmpty (Event p e r)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap NonEmpty (Event p e r) -> Event p e r
forall p e r. NonEmpty (Event p e r) -> Event p e r
combine
                    (NonEmpty (NonEmpty (Event p e r)) -> NonEmpty (Event p e r))
-> (t (LineSegment 2 p r :+ e)
    -> NonEmpty (NonEmpty (Event p e r)))
-> t (LineSegment 2 p r :+ e)
-> NonEmpty (Event p e r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Event p e r -> r)
-> NonEmpty (Event p e r) -> NonEmpty (NonEmpty (Event p e r))
forall b a.
Ord b =>
(a -> b) -> NonEmpty a -> NonEmpty (NonEmpty a)
NonEmpty.groupAllWith1 Event p e r -> r
forall p e r. Event p e r -> r
eventX
                    (NonEmpty (Event p e r) -> NonEmpty (NonEmpty (Event p e r)))
-> (t (LineSegment 2 p r :+ e) -> NonEmpty (Event p e r))
-> t (LineSegment 2 p r :+ e)
-> NonEmpty (NonEmpty (Event p e r))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((LineSegment 2 p r :+ e) -> NonEmpty (Event p e r))
-> NonEmpty (LineSegment 2 p r :+ e) -> NonEmpty (Event p e r)
forall (t :: * -> *) m a.
(Foldable1 t, Semigroup m) =>
(a -> m) -> t a -> m
foldMap1 (LineSegment 2 p r :+ e) -> NonEmpty (Event p e r)
forall r p e.
Ord r =>
(LineSegment 2 p r :+ e) -> NonEmpty (Event p e r)
toEvents
                    (NonEmpty (LineSegment 2 p r :+ e) -> NonEmpty (Event p e r))
-> (t (LineSegment 2 p r :+ e)
    -> NonEmpty (LineSegment 2 p r :+ e))
-> t (LineSegment 2 p r :+ e)
-> NonEmpty (Event p e r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [LineSegment 2 p r :+ e] -> NonEmpty (LineSegment 2 p r :+ e)
forall a. [a] -> NonEmpty a
NonEmpty.fromList -- precondition guarantees that this is safe
                    ([LineSegment 2 p r :+ e] -> NonEmpty (LineSegment 2 p r :+ e))
-> (t (LineSegment 2 p r :+ e) -> [LineSegment 2 p r :+ e])
-> t (LineSegment 2 p r :+ e)
-> NonEmpty (LineSegment 2 p r :+ e)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((LineSegment 2 p r :+ e) -> Maybe (LineSegment 2 p r :+ e))
-> [LineSegment 2 p r :+ e] -> [LineSegment 2 p r :+ e]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (LineSegment 2 p r :+ e) -> Maybe (LineSegment 2 p r :+ e)
forall (d :: Nat) core a (point :: Nat -> * -> *) extra.
(ImplicitPeano (Peano d), HasStart core, Ord a,
 ArityPeano (Peano (FromPeano (Peano d))),
 KnownNat (FromPeano (Peano d)), KnownNat d, AsAPoint point,
 HasEnd core, StartCore core ~ EndCore core,
 StartCore core ~ point d a, StartExtra core ~ EndExtra core,
 (1 <=? d) ~ 'True, EndCore core ~ point d a,
 Peano (FromPeano (Peano d) + 1)
 ~ 'S (Peano (FromPeano (Peano d)))) =>
(core :+ extra) -> Maybe (core :+ extra)
reOrient ([LineSegment 2 p r :+ e] -> [LineSegment 2 p r :+ e])
-> (t (LineSegment 2 p r :+ e) -> [LineSegment 2 p r :+ e])
-> t (LineSegment 2 p r :+ e)
-> [LineSegment 2 p r :+ e]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t (LineSegment 2 p r :+ e) -> [LineSegment 2 p r :+ e]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList
                    (t (LineSegment 2 p r :+ e) -> NonEmpty (Event p e r))
-> t (LineSegment 2 p r :+ e) -> NonEmpty (Event p e r)
forall a b. (a -> b) -> a -> b
$ t (LineSegment 2 p r :+ e)
ss
    sweep' :: NonEmpty (Event p e r) -> Vector (r :+ StatusStructure p e r)
sweep' = [r :+ StatusStructure p e r] -> Vector (r :+ StatusStructure p e r)
forall a. [a] -> Vector a
V.fromList ([r :+ StatusStructure p e r]
 -> Vector (r :+ StatusStructure p e r))
-> (NonEmpty (Event p e r) -> [r :+ StatusStructure p e r])
-> NonEmpty (Event p e r)
-> Vector (r :+ StatusStructure p e r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty (r :+ StatusStructure p e r)
-> [r :+ StatusStructure p e r]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (NonEmpty (r :+ StatusStructure p e r)
 -> [r :+ StatusStructure p e r])
-> (NonEmpty (Event p e r)
    -> NonEmpty (r :+ StatusStructure p e r))
-> NonEmpty (Event p e r)
-> [r :+ StatusStructure p e r]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty (Event p e r) -> NonEmpty (r :+ StatusStructure p e r)
forall r p e.
(Ord r, Fractional r) =>
NonEmpty (Event p e r) -> NonEmpty (r :+ StatusStructure p e r)
sweep

    reOrient :: (core :+ extra) -> Maybe (core :+ extra)
reOrient s' :: core :+ extra
s'@(core
s :+ extra
z) = case (core
score -> Getting a core a -> a
forall s a. s -> Getting a s a -> a
^.((point d a :+ EndExtra core)
 -> Const a (point d a :+ EndExtra core))
-> core -> Const a core
forall t. HasStart t => Lens' t (StartCore t :+ StartExtra t)
start(((point d a :+ EndExtra core)
  -> Const a (point d a :+ EndExtra core))
 -> core -> Const a core)
-> ((a -> Const a a)
    -> (point d a :+ EndExtra core)
    -> Const a (point d a :+ EndExtra core))
-> Getting a core a
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(point d a -> Const a (point d a))
-> (point d a :+ EndExtra core)
-> Const a (point d a :+ EndExtra core)
forall core extra core'.
Lens (core :+ extra) (core' :+ extra) core core'
core((point d a -> Const a (point d a))
 -> (point d a :+ EndExtra core)
 -> Const a (point d a :+ EndExtra core))
-> ((a -> Const a a) -> point d a -> Const a (point d a))
-> (a -> Const a a)
-> (point d a :+ EndExtra core)
-> Const a (point d a :+ EndExtra core)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(a -> Const a a) -> point d a -> Const a (point d a)
forall (d :: Nat) (point :: Nat -> * -> *) r.
(1 <= d, Arity d, AsAPoint point) =>
Lens' (point d r) r
xCoord) a -> a -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` (core
score -> Getting a core a -> a
forall s a. s -> Getting a s a -> a
^.((point d a :+ EndExtra core)
 -> Const a (point d a :+ EndExtra core))
-> core -> Const a core
forall t. HasEnd t => Lens' t (EndCore t :+ EndExtra t)
end(((point d a :+ EndExtra core)
  -> Const a (point d a :+ EndExtra core))
 -> core -> Const a core)
-> ((a -> Const a a)
    -> (point d a :+ EndExtra core)
    -> Const a (point d a :+ EndExtra core))
-> Getting a core a
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(point d a -> Const a (point d a))
-> (point d a :+ EndExtra core)
-> Const a (point d a :+ EndExtra core)
forall core extra core'.
Lens (core :+ extra) (core' :+ extra) core core'
core((point d a -> Const a (point d a))
 -> (point d a :+ EndExtra core)
 -> Const a (point d a :+ EndExtra core))
-> ((a -> Const a a) -> point d a -> Const a (point d a))
-> (a -> Const a a)
-> (point d a :+ EndExtra core)
-> Const a (point d a :+ EndExtra core)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(a -> Const a a) -> point d a -> Const a (point d a)
forall (d :: Nat) (point :: Nat -> * -> *) r.
(1 <= d, Arity d, AsAPoint point) =>
Lens' (point d r) r
xCoord) of
                             Ordering
LT -> (core :+ extra) -> Maybe (core :+ extra)
forall a. a -> Maybe a
Just core :+ extra
s'
                             Ordering
GT -> let s'' :: core
s'' = core
score -> (core -> core) -> core
forall a b. a -> (a -> b) -> b
&((StartCore core :+ StartExtra core)
 -> Identity (StartCore core :+ StartExtra core))
-> core -> Identity core
forall t. HasStart t => Lens' t (StartCore t :+ StartExtra t)
start (((StartCore core :+ StartExtra core)
  -> Identity (StartCore core :+ StartExtra core))
 -> core -> Identity core)
-> (StartCore core :+ StartExtra core) -> core -> core
forall s t a b. ASetter s t a b -> b -> s -> t
.~ (core
score
-> Getting
     (StartCore core :+ StartExtra core)
     core
     (StartCore core :+ StartExtra core)
-> StartCore core :+ StartExtra core
forall s a. s -> Getting a s a -> a
^.Getting
  (StartCore core :+ StartExtra core)
  core
  (StartCore core :+ StartExtra core)
forall t. HasEnd t => Lens' t (EndCore t :+ EndExtra t)
end) -- flip the segment
                                              core -> (core -> core) -> core
forall a b. a -> (a -> b) -> b
&((EndCore core :+ EndExtra core)
 -> Identity (EndCore core :+ EndExtra core))
-> core -> Identity core
forall t. HasEnd t => Lens' t (EndCore t :+ EndExtra t)
end   (((EndCore core :+ EndExtra core)
  -> Identity (EndCore core :+ EndExtra core))
 -> core -> Identity core)
-> (EndCore core :+ EndExtra core) -> core -> core
forall s t a b. ASetter s t a b -> b -> s -> t
.~ (core
score
-> Getting
     (EndCore core :+ EndExtra core)
     core
     (EndCore core :+ EndExtra core)
-> EndCore core :+ EndExtra core
forall s a. s -> Getting a s a -> a
^.Getting
  (EndCore core :+ EndExtra core)
  core
  (EndCore core :+ EndExtra core)
forall t. HasStart t => Lens' t (StartCore t :+ StartExtra t)
start)
                                   in (core :+ extra) -> Maybe (core :+ extra)
forall a. a -> Maybe a
Just ((core :+ extra) -> Maybe (core :+ extra))
-> (core :+ extra) -> Maybe (core :+ extra)
forall a b. (a -> b) -> a -> b
$ core
s'' core -> extra -> core :+ extra
forall core extra. core -> extra -> core :+ extra
:+ extra
z
                             Ordering
EQ -> Maybe (core :+ extra)
forall a. Maybe a
Nothing -- precondition says this won't happen, but kill
                                           -- them anyway

-- | Given a bunch of events happening at the same time, merge them into a single event
-- where we apply all actions.
combine                    :: NonEmpty (Event p e r) -> Event p e r
combine :: NonEmpty (Event p e r) -> Event p e r
combine es :: NonEmpty (Event p e r)
es@((r
x :+ NonEmpty (Action (LineSegment 2 p r :+ e))
_) :| [Event p e r]
_) = r
x r -> NonEmpty (Action (LineSegment 2 p r :+ e)) -> Event p e r
forall core extra. core -> extra -> core :+ extra
:+ (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 -> NonEmpty (Action (LineSegment 2 p r :+ e))
forall p e r.
Event p e r -> NonEmpty (Action (LineSegment 2 p r :+ e))
eventActions NonEmpty (Event p e r)
es

-- | Given a line segment construct the two events; i.e. when we
-- insert it and when we delete it.
toEvents                           :: Ord r => LineSegment 2 p r :+ e -> NonEmpty (Event p e r)
toEvents :: (LineSegment 2 p r :+ e) -> NonEmpty (Event p e r)
toEvents s :: LineSegment 2 p r :+ e
s@(LineSegment' Point 2 r :+ p
p Point 2 r :+ p
q :+ e
_) = [Event p e r] -> NonEmpty (Event p e r)
forall a. [a] -> NonEmpty a
NonEmpty.fromList [ (Point 2 r :+ p
p(Point 2 r :+ p) -> Getting r (Point 2 r :+ p) r -> r
forall s a. s -> Getting a s a -> a
^.(Point 2 r -> Const r (Point 2 r))
-> (Point 2 r :+ p) -> Const r (Point 2 r :+ p)
forall core extra core'.
Lens (core :+ extra) (core' :+ extra) core core'
core((Point 2 r -> Const r (Point 2 r))
 -> (Point 2 r :+ p) -> Const r (Point 2 r :+ p))
-> ((r -> Const r r) -> Point 2 r -> Const r (Point 2 r))
-> Getting r (Point 2 r :+ p) r
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(r -> Const r r) -> Point 2 r -> Const r (Point 2 r)
forall (d :: Nat) (point :: Nat -> * -> *) r.
(1 <= d, Arity d, AsAPoint point) =>
Lens' (point d r) r
xCoord) r -> NonEmpty (Action (LineSegment 2 p r :+ e)) -> Event p e r
forall core extra. core -> extra -> core :+ extra
:+ (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
:| []
                                                       , (Point 2 r :+ p
q(Point 2 r :+ p) -> Getting r (Point 2 r :+ p) r -> r
forall s a. s -> Getting a s a -> a
^.(Point 2 r -> Const r (Point 2 r))
-> (Point 2 r :+ p) -> Const r (Point 2 r :+ p)
forall core extra core'.
Lens (core :+ extra) (core' :+ extra) core core'
core((Point 2 r -> Const r (Point 2 r))
 -> (Point 2 r :+ p) -> Const r (Point 2 r :+ p))
-> ((r -> Const r r) -> Point 2 r -> Const r (Point 2 r))
-> Getting r (Point 2 r :+ p) r
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(r -> Const r r) -> Point 2 r -> Const r (Point 2 r)
forall (d :: Nat) (point :: Nat -> * -> *) r.
(1 <= d, Arity d, AsAPoint point) =>
Lens' (point d r) r
xCoord) r -> NonEmpty (Action (LineSegment 2 p r :+ e)) -> Event p e r
forall core extra. core -> extra -> core :+ extra
:+ (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
:| []
                                                       ]

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

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)

{- HLINT ignore "Avoid lambda using `infix`" -}
interpret :: Action a -> (a -> a -> Ordering) -> SS.Set a -> SS.Set a
interpret :: Action a -> (a -> a -> Ordering) -> Set a -> Set a
interpret = \case
  Insert a
s -> \a -> a -> Ordering
cmp -> (a -> a -> Ordering) -> a -> Set a -> Set a
forall a. (a -> a -> Ordering) -> a -> Set a -> Set a
SS.insertBy    a -> a -> Ordering
cmp a
s
  Delete a
s -> \a -> a -> Ordering
cmp -> (a -> a -> Ordering) -> a -> Set a -> Set a
forall a. (a -> a -> Ordering) -> a -> Set a -> Set a
SS.deleteAllBy a -> a -> Ordering
cmp a
s


type Event p e r = r :+ NonEmpty (Action (LineSegment 2 p r :+ e))

eventX :: Event p e r -> r
eventX :: Event p e r -> r
eventX = Getting r (Event p e r) r -> Event p e r -> r
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting r (Event p e r) r
forall core extra core'.
Lens (core :+ extra) (core' :+ extra) core core'
core

eventActions :: Event p e r -> NonEmpty (Action (LineSegment 2 p r :+ e))
eventActions :: Event p e r -> NonEmpty (Action (LineSegment 2 p r :+ e))
eventActions = Getting
  (NonEmpty (Action (LineSegment 2 p r :+ e)))
  (Event p e r)
  (NonEmpty (Action (LineSegment 2 p r :+ e)))
-> Event p e r -> NonEmpty (Action (LineSegment 2 p r :+ e))
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting
  (NonEmpty (Action (LineSegment 2 p r :+ e)))
  (Event p e r)
  (NonEmpty (Action (LineSegment 2 p r :+ e)))
forall core extra extra'.
Lens (core :+ extra) (core :+ extra') extra extra'
extra

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

-- | Runs the sweep building the data structure from left to right.
sweep    :: (Ord r, Fractional r)
         => NonEmpty (Event p e r) -> NonEmpty (r :+ StatusStructure p e r)
sweep :: NonEmpty (Event p e r) -> NonEmpty (r :+ StatusStructure p e r)
sweep NonEmpty (Event p e r)
es = [r :+ StatusStructure p e r]
-> NonEmpty (r :+ StatusStructure p e r)
forall a. [a] -> NonEmpty a
NonEmpty.fromList
         ([r :+ StatusStructure p e r]
 -> NonEmpty (r :+ StatusStructure p e r))
-> ([(Event p e r, Event p e r)] -> [r :+ StatusStructure p e r])
-> [(Event p e r, Event p e r)]
-> NonEmpty (r :+ StatusStructure p e r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StatusStructure p e r, [r :+ StatusStructure p e r])
-> [r :+ StatusStructure p e r]
forall a b. (a, b) -> b
snd ((StatusStructure p e r, [r :+ StatusStructure p e r])
 -> [r :+ StatusStructure p e r])
-> ([(Event p e r, Event p e r)]
    -> (StatusStructure p e r, [r :+ StatusStructure p e r]))
-> [(Event p e r, Event p e r)]
-> [r :+ StatusStructure p e r]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StatusStructure p e r
 -> (Event p e r, Event p e r)
 -> (StatusStructure p e r, r :+ StatusStructure p e r))
-> StatusStructure p e r
-> [(Event p e r, Event p e r)]
-> (StatusStructure p e r, [r :+ StatusStructure p e r])
forall (t :: * -> *) a b c.
Traversable t =>
(a -> b -> (a, c)) -> a -> t b -> (a, t c)
List.mapAccumL StatusStructure p e r
-> (Event p e r, Event p e r)
-> (StatusStructure p e r, r :+ StatusStructure p e r)
forall core p e.
(Ord core, Fractional core) =>
StatusStructure p e core
-> (Event p e core, Event p e core)
-> (StatusStructure p e core, core :+ StatusStructure p e core)
h StatusStructure p e r
forall a. Set a
SS.empty
         ([(Event p e r, Event p e r)]
 -> NonEmpty (r :+ StatusStructure p e r))
-> [(Event p e r, Event p e r)]
-> NonEmpty (r :+ StatusStructure p e r)
forall a b. (a -> b) -> a -> b
$ [Event p e r] -> [Event p e r] -> [(Event p e r, Event p e r)]
forall a b. [a] -> [b] -> [(a, b)]
zip (NonEmpty (Event p e r) -> [Event p e r]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty (Event p e r)
es) (NonEmpty (Event p e r) -> [Event p e r]
forall a. NonEmpty a -> [a]
NonEmpty.tail NonEmpty (Event p e r)
es)
  where
    h :: StatusStructure p e core
-> (Event p e core, Event p e core)
-> (StatusStructure p e core, core :+ StatusStructure p e core)
h StatusStructure p e core
ss (Event p e core, Event p e core)
evts = let core
x :+ StatusStructure p e core
ss' = StatusStructure p e core
-> (Event p e core, Event p e core)
-> core :+ StatusStructure p e core
forall r p e.
(Ord r, Fractional r) =>
StatusStructure p e r
-> (Event p e r, Event p e r) -> r :+ StatusStructure p e r
handle StatusStructure p e core
ss (Event p e core, Event p e core)
evts in (StatusStructure p e core
ss',core
x core
-> StatusStructure p e core -> core :+ StatusStructure p e core
forall core extra. core -> extra -> core :+ extra
:+ StatusStructure p e core
ss')

-- | Given the current status structure (for left of the next event
-- 'l'), and the next two events (l,r); essentially defining the slab
-- between l and r, we construct the status structure for in the slab (l,r).
-- returns the right boundary and this status structure.
handle                :: (Ord r, Fractional r)
                      => StatusStructure p e r
                      -> (Event p e r, Event p e r)
                      -> r :+ StatusStructure p e r
handle :: StatusStructure p e r
-> (Event p e r, Event p e r) -> r :+ StatusStructure p e r
handle StatusStructure p e r
ss ( r
l :+ NonEmpty (Action (LineSegment 2 p r :+ e))
acts
          , r
r :+ NonEmpty (Action (LineSegment 2 p r :+ e))
_)   = let mid :: r
mid               = (r
lr -> r -> r
forall a. Num a => a -> a -> a
+r
r)r -> r -> r
forall a. Fractional a => a -> a -> a
/r
2
                            runActionAt :: r
-> Action (LineSegment 2 p r :+ e)
-> Set (LineSegment 2 p r :+ e)
-> Set (LineSegment 2 p r :+ e)
runActionAt r
x Action (LineSegment 2 p r :+ e)
act = Action (LineSegment 2 p r :+ e)
-> ((LineSegment 2 p r :+ e)
    -> (LineSegment 2 p r :+ e) -> Ordering)
-> Set (LineSegment 2 p r :+ e)
-> Set (LineSegment 2 p r :+ e)
forall a. Action a -> (a -> a -> Ordering) -> Set a -> Set a
interpret Action (LineSegment 2 p r :+ e)
act (r
-> (LineSegment 2 p r :+ e) -> (LineSegment 2 p r :+ e) -> Ordering
forall r p e.
(Fractional r, Ord r) =>
r -> Compare (LineSegment 2 p r :+ e)
ordAt r
x)
                        in r
r r -> StatusStructure p e r -> r :+ StatusStructure p e r
forall core extra. core -> extra -> core :+ extra
:+ (Action (LineSegment 2 p r :+ e)
 -> StatusStructure p e r -> StatusStructure p e r)
-> StatusStructure p e r
-> NonEmpty (Action (LineSegment 2 p r :+ e))
-> StatusStructure p e r
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (r
-> Action (LineSegment 2 p r :+ e)
-> StatusStructure p e r
-> StatusStructure p e r
forall r p e.
(Fractional r, Ord r) =>
r
-> Action (LineSegment 2 p r :+ e)
-> Set (LineSegment 2 p r :+ e)
-> Set (LineSegment 2 p r :+ e)
runActionAt r
mid) StatusStructure p e r
ss (NonEmpty (Action (LineSegment 2 p r :+ e))
-> NonEmpty (Action (LineSegment 2 p r :+ e))
forall a. NonEmpty (Action a) -> NonEmpty (Action a)
orderActs NonEmpty (Action (LineSegment 2 p r :+ e))
acts)
                           -- run deletions first

-- | orders the actions to put insertions first and then all deletions
orderActs      :: NonEmpty (Action a) -> NonEmpty (Action a)
orderActs :: NonEmpty (Action a) -> NonEmpty (Action a)
orderActs NonEmpty (Action a)
acts = let ([Action a]
dels,[Action a]
ins) = (Action a -> Bool)
-> NonEmpty (Action a) -> ([Action a], [Action a])
forall a. (a -> Bool) -> NonEmpty a -> ([a], [a])
NonEmpty.partition (\case
                                                         Delete a
_ -> Bool
True
                                                         Insert a
_ -> Bool
False
                                                     ) NonEmpty (Action a)
acts
                 in [Action a] -> NonEmpty (Action a)
forall a. [a] -> NonEmpty a
NonEmpty.fromList ([Action a] -> NonEmpty (Action a))
-> [Action a] -> NonEmpty (Action a)
forall a b. (a -> b) -> a -> b
$ [Action a]
ins [Action a] -> [Action a] -> [Action a]
forall a. Semigroup a => a -> a -> a
<> [Action a]
dels


--------------------------------------------------------------------------------
-- * Querying the DS

-- | Find the segment vertically strictly above query point q, if it
-- exists.
--
-- \(O(\log n)\)
segmentAbove      :: (Ord r, Num r) => Point 2 r -> VerticalRayShootingStructure p e r
                  -> Maybe (LineSegment 2 p r :+ e)
segmentAbove :: Point 2 r
-> VerticalRayShootingStructure p e r
-> Maybe (LineSegment 2 p r :+ e)
segmentAbove Point 2 r
q VerticalRayShootingStructure p e r
ds = Point 2 r
-> VerticalRayShootingStructure p e r
-> Maybe (StatusStructure p e r)
forall r p e.
Ord r =>
Point 2 r
-> VerticalRayShootingStructure p e r
-> Maybe (StatusStructure p e r)
findSlab Point 2 r
q VerticalRayShootingStructure p e r
ds Maybe (StatusStructure p e r)
-> (StatusStructure p e r -> Maybe (LineSegment 2 p r :+ e))
-> Maybe (LineSegment 2 p r :+ e)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Point 2 r
-> StatusStructure p e r -> Maybe (LineSegment 2 p r :+ e)
forall r p e.
(Ord r, Num r) =>
Point 2 r
-> StatusStructure p e r -> Maybe (LineSegment 2 p r :+ e)
lookupAbove Point 2 r
q

-- | Find the segment vertically query point q, if it exists.
--
-- \(O(\log n)\)
segmentAboveOrOn      :: (Ord r, Num r)
                      => Point 2 r -> VerticalRayShootingStructure p e r
                      -> Maybe (LineSegment 2 p r :+ e)
segmentAboveOrOn :: Point 2 r
-> VerticalRayShootingStructure p e r
-> Maybe (LineSegment 2 p r :+ e)
segmentAboveOrOn Point 2 r
q VerticalRayShootingStructure p e r
ds = Point 2 r
-> VerticalRayShootingStructure p e r
-> Maybe (StatusStructure p e r)
forall r p e.
Ord r =>
Point 2 r
-> VerticalRayShootingStructure p e r
-> Maybe (StatusStructure p e r)
findSlab Point 2 r
q VerticalRayShootingStructure p e r
ds Maybe (StatusStructure p e r)
-> (StatusStructure p e r -> Maybe (LineSegment 2 p r :+ e))
-> Maybe (LineSegment 2 p r :+ e)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Point 2 r
-> StatusStructure p e r -> Maybe (LineSegment 2 p r :+ e)
forall r p e.
(Ord r, Num r) =>
Point 2 r
-> StatusStructure p e r -> Maybe (LineSegment 2 p r :+ e)
lookupAboveOrOn Point 2 r
q



-- | Given a query point, find the (data structure of the) slab containing the query point
--
-- \(O(\log n)\)
findSlab :: Ord r
         => Point 2 r -> VerticalRayShootingStructure p e r -> Maybe (StatusStructure p e r)
findSlab :: Point 2 r
-> VerticalRayShootingStructure p e r
-> Maybe (StatusStructure p e r)
findSlab Point 2 r
q VerticalRayShootingStructure p e r
ds | Point 2 r
qPoint 2 r -> Getting r (Point 2 r) r -> r
forall s a. s -> Getting a s a -> a
^.Getting r (Point 2 r) r
forall (d :: Nat) (point :: Nat -> * -> *) r.
(1 <= d, Arity d, AsAPoint point) =>
Lens' (point d r) r
xCoord r -> r -> Bool
forall a. Ord a => a -> a -> Bool
< VerticalRayShootingStructure p e r
dsVerticalRayShootingStructure p e r
-> Getting r (VerticalRayShootingStructure p e r) r -> r
forall s a. s -> Getting a s a -> a
^.Getting r (VerticalRayShootingStructure p e r) r
forall p e r. Getter (VerticalRayShootingStructure p e r) r
leftMost = Maybe (StatusStructure p e r)
forall a. Maybe a
Nothing
              | Bool
otherwise                = Getting
  (StatusStructure p e r)
  (r :+ StatusStructure p e r)
  (StatusStructure p e r)
-> (r :+ StatusStructure p e r) -> StatusStructure p e r
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting
  (StatusStructure p e r)
  (r :+ StatusStructure p e r)
  (StatusStructure p e r)
forall core extra extra'.
Lens (core :+ extra) (core :+ extra') extra extra'
extra
                                        ((r :+ StatusStructure p e r) -> StatusStructure p e r)
-> Maybe (r :+ StatusStructure p e r)
-> Maybe (StatusStructure p e r)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Elem (Vector (r :+ StatusStructure p e r)) -> Bool)
-> Vector (r :+ StatusStructure p e r)
-> Maybe (Elem (Vector (r :+ StatusStructure p e r)))
forall v. BinarySearch v => (Elem v -> Bool) -> v -> Maybe (Elem v)
binarySearchIn (Point 2 r
q `leftOf `) (VerticalRayShootingStructure p e r
dsVerticalRayShootingStructure p e r
-> Getting
     (Vector (r :+ StatusStructure p e r))
     (VerticalRayShootingStructure p e r)
     (Vector (r :+ StatusStructure p e r))
-> Vector (r :+ StatusStructure p e r)
forall s a. s -> Getting a s a -> a
^.Getting
  (Vector (r :+ StatusStructure p e r))
  (VerticalRayShootingStructure p e r)
  (Vector (r :+ StatusStructure p e r))
forall p e r.
Getter
  (VerticalRayShootingStructure p e r)
  (Vector (r :+ StatusStructure p e r))
sweepStruct)
  where
    point d a
q' leftOf :: point d a -> (a :+ extra) -> Bool
`leftOf` (a
r :+ extra
_) = point d a
q'point d a -> Getting a (point d a) a -> a
forall s a. s -> Getting a s a -> a
^.Getting a (point d a) a
forall (d :: Nat) (point :: Nat -> * -> *) r.
(1 <= d, Arity d, AsAPoint point) =>
Lens' (point d r) r
xCoord a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
r

--------------------------------------------------------------------------------
-- * Querying in a single slab

-- | Finds the segment containing or above the query point 'q'
--
-- \(O(\log n)\)
lookupAboveOrOn   :: (Ord r, Num r)
                  => Point 2 r -> StatusStructure p e r -> Maybe (LineSegment 2 p r :+ e)
lookupAboveOrOn :: Point 2 r
-> StatusStructure p e r -> Maybe (LineSegment 2 p r :+ e)
lookupAboveOrOn Point 2 r
q = (Line 2 r -> Bool)
-> StatusStructure p e r -> Maybe (LineSegment 2 p r :+ e)
forall r p e.
Num r =>
(Line 2 r -> Bool)
-> StatusStructure p e r -> Maybe (LineSegment 2 p r :+ e)
searchInSlab (Bool -> Bool
not (Bool -> Bool) -> (Line 2 r -> Bool) -> Line 2 r -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Point 2 r
q Point 2 r -> Line 2 r -> Bool
forall r. (Ord r, Num r) => Point 2 r -> Line 2 r -> Bool
`liesAbove`))

-- | Finds the first segment strictly above q
--
-- \(O(\log n)\)
lookupAbove   :: (Ord r, Num r)
              => Point 2 r -> StatusStructure p e r -> Maybe (LineSegment 2 p r :+ e)
lookupAbove :: Point 2 r
-> StatusStructure p e r -> Maybe (LineSegment 2 p r :+ e)
lookupAbove Point 2 r
q = (Line 2 r -> Bool)
-> StatusStructure p e r -> Maybe (LineSegment 2 p r :+ e)
forall r p e.
Num r =>
(Line 2 r -> Bool)
-> StatusStructure p e r -> Maybe (LineSegment 2 p r :+ e)
searchInSlab (Point 2 r
q Point 2 r -> Line 2 r -> Bool
forall r. (Ord r, Num r) => Point 2 r -> Line 2 r -> Bool
`liesBelow`)

-- | generic searching function
searchInSlab   :: Num r => (Line 2 r -> Bool)
               -> StatusStructure p e r -> Maybe (LineSegment 2 p r :+ e)
searchInSlab :: (Line 2 r -> Bool)
-> StatusStructure p e r -> Maybe (LineSegment 2 p r :+ e)
searchInSlab Line 2 r -> Bool
p = (Elem (StatusStructure p e r) -> Bool)
-> StatusStructure p e r -> Maybe (Elem (StatusStructure p e r))
forall v. BinarySearch v => (Elem v -> Bool) -> v -> Maybe (Elem v)
binarySearchIn (Line 2 r -> Bool
p (Line 2 r -> Bool)
-> ((LineSegment 2 p r :+ e) -> Line 2 r)
-> (LineSegment 2 p r :+ e)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LineSegment 2 p r -> Line 2 r
forall t.
HasSupportingLine t =>
t -> Line (Dimension t) (NumType t)
supportingLine (LineSegment 2 p r -> Line 2 r)
-> ((LineSegment 2 p r :+ e) -> LineSegment 2 p r)
-> (LineSegment 2 p r :+ e)
-> Line 2 r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting
  (LineSegment 2 p r) (LineSegment 2 p r :+ e) (LineSegment 2 p r)
-> (LineSegment 2 p r :+ e) -> LineSegment 2 p r
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view 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)


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

type Compare a = a -> a -> Ordering

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


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