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

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

import           Control.Lens hiding (contains, below)
import           Data.Foldable (toList)
import qualified Data.List as List
import           Data.List.NonEmpty (NonEmpty(..))
import qualified Data.List.NonEmpty as NonEmpty
import           Data.Semigroup.Foldable
import qualified Data.Set as SS -- status struct
import qualified Data.Vector as V
import           HGeometry.Algorithms.BinarySearch (binarySearchFirstIn)
import           HGeometry.Ext
import           HGeometry.Line.PointAndVector
import           HGeometry.LineSegment
import           HGeometry.Point
import           HGeometry.Properties
import qualified HGeometry.Set.Util as SS

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

-- | The vertical ray shooting data structure
type VerticalRayShootingStructure lineSegment =
  VerticalRayShootingStructure' (NumType lineSegment) lineSegment

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

-- | The status structure
type StatusStructure lineSegment = SS.Set lineSegment

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   :: ( LineSegment_ lineSegment point
                                  , Point_ point 2 r
                                  , Ord r, Fractional r, Foldable1 f)
                               => f lineSegment
                               -> VerticalRayShootingStructure lineSegment
verticalRayShootingStructure :: forall lineSegment point r (f :: * -> *).
(LineSegment_ lineSegment point, Point_ point 2 r, Ord r,
 Fractional r, Foldable1 f) =>
f lineSegment -> VerticalRayShootingStructure lineSegment
verticalRayShootingStructure f lineSegment
ss = NumType point
-> Vector (NumType point :+ StatusStructure lineSegment)
-> VerticalRayShootingStructure' (NumType point) lineSegment
forall r lineSegment.
r
-> Vector (r :+ StatusStructure lineSegment)
-> VerticalRayShootingStructure' r lineSegment
VerticalRayShootingStructure (Event (NumType point) lineSegment -> NumType point
forall r lineSegment. Event r lineSegment -> r
eventX Event (NumType point) lineSegment
e) (NonEmpty
  (Event (NumType (IxValue (EndPointOf lineSegment))) lineSegment)
-> Vector
     (NumType (IxValue (EndPointOf lineSegment))
      :+ StatusStructure lineSegment)
sweep' NonEmpty (Event (NumType point) lineSegment)
NonEmpty
  (Event (NumType (IxValue (EndPointOf lineSegment))) lineSegment)
events)
  where
    events :: NonEmpty (Event (NumType point) lineSegment)
events@(Event (NumType point) lineSegment
e :| [Event (NumType point) lineSegment]
_) = (NonEmpty (Event (NumType point) lineSegment)
 -> Event (NumType point) lineSegment)
-> NonEmpty (NonEmpty (Event (NumType point) lineSegment))
-> NonEmpty (Event (NumType point) lineSegment)
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap NonEmpty (Event (NumType point) lineSegment)
-> Event (NumType point) lineSegment
forall r lineSegment.
NonEmpty (Event r lineSegment) -> Event r lineSegment
combine
                    (NonEmpty (NonEmpty (Event (NumType point) lineSegment))
 -> NonEmpty (Event (NumType point) lineSegment))
-> (f lineSegment
    -> NonEmpty (NonEmpty (Event (NumType point) lineSegment)))
-> f lineSegment
-> NonEmpty (Event (NumType point) lineSegment)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Event (NumType point) lineSegment -> NumType point)
-> NonEmpty (Event (NumType point) lineSegment)
-> NonEmpty (NonEmpty (Event (NumType point) lineSegment))
forall b a.
Ord b =>
(a -> b) -> NonEmpty a -> NonEmpty (NonEmpty a)
NonEmpty.groupAllWith1 Event (NumType point) lineSegment -> NumType point
forall r lineSegment. Event r lineSegment -> r
eventX
                    (NonEmpty (Event (NumType point) lineSegment)
 -> NonEmpty (NonEmpty (Event (NumType point) lineSegment)))
-> (f lineSegment -> NonEmpty (Event (NumType point) lineSegment))
-> f lineSegment
-> NonEmpty (NonEmpty (Event (NumType point) lineSegment))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (lineSegment -> NonEmpty (Event (NumType point) lineSegment))
-> f lineSegment -> NonEmpty (Event (NumType point) lineSegment)
forall m a. Semigroup m => (a -> m) -> f a -> m
forall (t :: * -> *) m a.
(Foldable1 t, Semigroup m) =>
(a -> m) -> t a -> m
foldMap1 (lineSegment -> NonEmpty (Event (NumType point) lineSegment)
forall {p} {p} {s}.
(NumType p ~ NumType p,
 Assert
   (OrdCond (CmpNat 1 (Dimension p)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 1 (Dimension p)) 'True 'True 'False)
   (TypeError ...),
 HasStart s p, HasEnd s p, Point_ p (Dimension p) (NumType p),
 Point_ p (Dimension p) (NumType p)) =>
s -> NonEmpty (NumType p :+ NonEmpty (Action s))
toEvents (lineSegment -> NonEmpty (Event (NumType point) lineSegment))
-> (lineSegment -> lineSegment)
-> lineSegment
-> NonEmpty (Event (NumType point) lineSegment)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. lineSegment -> lineSegment
forall lineSegment point (d :: Natural) r.
(LineSegment_ lineSegment point, Point_ point d r, 1 <= d,
 Ord r) =>
lineSegment -> lineSegment
orientLR)
                    (f lineSegment -> NonEmpty (Event (NumType point) lineSegment))
-> f lineSegment -> NonEmpty (Event (NumType point) lineSegment)
forall a b. (a -> b) -> a -> b
$ f lineSegment
ss
    sweep' :: NonEmpty
  (Event (NumType (IxValue (EndPointOf lineSegment))) lineSegment)
-> Vector
     (NumType (IxValue (EndPointOf lineSegment))
      :+ StatusStructure lineSegment)
sweep' = [NumType (IxValue (EndPointOf lineSegment))
 :+ StatusStructure lineSegment]
-> Vector
     (NumType (IxValue (EndPointOf lineSegment))
      :+ StatusStructure lineSegment)
forall a. [a] -> Vector a
V.fromList ([NumType (IxValue (EndPointOf lineSegment))
  :+ StatusStructure lineSegment]
 -> Vector
      (NumType (IxValue (EndPointOf lineSegment))
       :+ StatusStructure lineSegment))
-> (NonEmpty
      (Event (NumType (IxValue (EndPointOf lineSegment))) lineSegment)
    -> [NumType (IxValue (EndPointOf lineSegment))
        :+ StatusStructure lineSegment])
-> NonEmpty
     (Event (NumType (IxValue (EndPointOf lineSegment))) lineSegment)
-> Vector
     (NumType (IxValue (EndPointOf lineSegment))
      :+ StatusStructure lineSegment)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty
  (NumType (IxValue (EndPointOf lineSegment))
   :+ StatusStructure lineSegment)
-> [NumType (IxValue (EndPointOf lineSegment))
    :+ StatusStructure lineSegment]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (NonEmpty
   (NumType (IxValue (EndPointOf lineSegment))
    :+ StatusStructure lineSegment)
 -> [NumType (IxValue (EndPointOf lineSegment))
     :+ StatusStructure lineSegment])
-> (NonEmpty
      (Event (NumType (IxValue (EndPointOf lineSegment))) lineSegment)
    -> NonEmpty
         (NumType (IxValue (EndPointOf lineSegment))
          :+ StatusStructure lineSegment))
-> NonEmpty
     (Event (NumType (IxValue (EndPointOf lineSegment))) lineSegment)
-> [NumType (IxValue (EndPointOf lineSegment))
    :+ StatusStructure lineSegment]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty
  (Event (NumType (IxValue (EndPointOf lineSegment))) lineSegment)
-> NonEmpty
     (NumType (IxValue (EndPointOf lineSegment))
      :+ StatusStructure lineSegment)
forall lineSegment point r.
(LineSegment_ lineSegment point, Point_ point 2 r, Ord r,
 Fractional r) =>
NonEmpty (Event r lineSegment)
-> NonEmpty (r :+ StatusStructure lineSegment)
sweep

    toEvents :: s -> NonEmpty (NumType p :+ NonEmpty (Action s))
toEvents s
seg = [NumType p :+ NonEmpty (Action s)]
-> NonEmpty (NumType p :+ NonEmpty (Action s))
forall a. HasCallStack => [a] -> NonEmpty a
NonEmpty.fromList [ (s
segs -> Getting (NumType p) s (NumType p) -> NumType p
forall s a. s -> Getting a s a -> a
^.(p -> Const (NumType p) p) -> s -> Const (NumType p) s
forall seg p. HasStart seg p => Lens' seg p
Lens' s p
start((p -> Const (NumType p) p) -> s -> Const (NumType p) s)
-> ((NumType p -> Const (NumType p) (NumType p))
    -> p -> Const (NumType p) p)
-> Getting (NumType p) s (NumType p)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(NumType p -> Const (NumType p) (NumType p))
-> p -> Const (NumType p) p
forall (d :: Natural) point r.
(1 <= d, Point_ point d r) =>
IndexedLens' Int point r
IndexedLens' Int p (NumType p)
xCoord) NumType p
-> NonEmpty (Action s) -> NumType p :+ NonEmpty (Action s)
forall core extra. core -> extra -> core :+ extra
:+ s -> Action s
forall a. a -> Action a
Insert s
seg Action s -> [Action s] -> NonEmpty (Action s)
forall a. a -> [a] -> NonEmpty a
:| []
                                     , (s
segs -> Getting (NumType p) s (NumType p) -> NumType p
forall s a. s -> Getting a s a -> a
^.(p -> Const (NumType p) p) -> s -> Const (NumType p) s
forall seg p. HasEnd seg p => Lens' seg p
Lens' s p
end((p -> Const (NumType p) p) -> s -> Const (NumType p) s)
-> ((NumType p -> Const (NumType p) (NumType p))
    -> p -> Const (NumType p) p)
-> Getting (NumType p) s (NumType p)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(NumType p -> Const (NumType p) (NumType p))
-> p -> Const (NumType p) p
forall (d :: Natural) point r.
(1 <= d, Point_ point d r) =>
IndexedLens' Int point r
IndexedLens' Int p (NumType p)
xCoord)   NumType p
-> NonEmpty (Action s) -> NumType p :+ NonEmpty (Action s)
forall core extra. core -> extra -> core :+ extra
:+ s -> Action s
forall a. a -> Action a
Delete s
seg Action s -> [Action s] -> NonEmpty (Action s)
forall a. a -> [a] -> NonEmpty a
:| []
                                     ]


-- | Given a bunch of events happening at the same time, merge them into a single event
-- where we apply all actions.
combine                    :: NonEmpty (Event r lineSegment) -> Event r lineSegment
combine :: forall r lineSegment.
NonEmpty (Event r lineSegment) -> Event r lineSegment
combine es :: NonEmpty (Event r lineSegment)
es@((r
x :+ NonEmpty (Action lineSegment)
_) :| [Event r lineSegment]
_) = r
x r -> NonEmpty (Action lineSegment) -> Event r lineSegment
forall core extra. core -> extra -> core :+ extra
:+ (Event r lineSegment -> NonEmpty (Action lineSegment))
-> NonEmpty (Event r lineSegment) -> NonEmpty (Action lineSegment)
forall m a. Semigroup m => (a -> m) -> NonEmpty a -> m
forall (t :: * -> *) m a.
(Foldable1 t, Semigroup m) =>
(a -> m) -> t a -> m
foldMap1 Event r lineSegment -> NonEmpty (Action lineSegment)
forall r lineSegment.
Event r lineSegment -> NonEmpty (Action lineSegment)
eventActions NonEmpty (Event r lineSegment)
es

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

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
$cshowsPrec :: forall a. Show a => Int -> Action a -> ShowS
showsPrec :: Int -> Action a -> ShowS
$cshow :: forall a. Show a => Action a -> String
show :: Action a -> String
$cshowList :: forall a. Show a => [Action a] -> ShowS
showList :: [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
$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
/= :: 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 :: forall a. 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


-- | An event; i.e. an x coordinate together with a bunch of actions.
type Event r lineSegment = r :+ NonEmpty (Action lineSegment)

-- | The x-coordinate at which an event happens
eventX :: Event r lineSegment -> r
eventX :: forall r lineSegment. Event r lineSegment -> r
eventX = Getting r (r :+ NonEmpty (Action lineSegment)) r
-> (r :+ NonEmpty (Action lineSegment)) -> r
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting r (r :+ NonEmpty (Action lineSegment)) r
forall core extra core' (f :: * -> *).
Functor f =>
(core -> f core') -> (core :+ extra) -> f (core' :+ extra)
core

-- | The actions at a particular event
eventActions :: Event r lineSegment -> NonEmpty (Action lineSegment)
eventActions :: forall r lineSegment.
Event r lineSegment -> NonEmpty (Action lineSegment)
eventActions = Getting
  (NonEmpty (Action lineSegment))
  (r :+ NonEmpty (Action lineSegment))
  (NonEmpty (Action lineSegment))
-> (r :+ NonEmpty (Action lineSegment))
-> NonEmpty (Action lineSegment)
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting
  (NonEmpty (Action lineSegment))
  (r :+ NonEmpty (Action lineSegment))
  (NonEmpty (Action lineSegment))
forall core extra extra' (f :: * -> *).
Functor f =>
(extra -> f extra') -> (core :+ extra) -> f (core :+ extra')
extra

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

-- | Runs the sweep building the data structure from left to right.
sweep    :: ( LineSegment_ lineSegment point, Point_ point 2 r
            , Ord r, Fractional r
            )
         => NonEmpty (Event r lineSegment) -> NonEmpty (r :+ StatusStructure lineSegment)
sweep :: forall lineSegment point r.
(LineSegment_ lineSegment point, Point_ point 2 r, Ord r,
 Fractional r) =>
NonEmpty (Event r lineSegment)
-> NonEmpty (r :+ StatusStructure lineSegment)
sweep NonEmpty (Event r lineSegment)
es = [r :+ StatusStructure lineSegment]
-> NonEmpty (r :+ StatusStructure lineSegment)
forall a. HasCallStack => [a] -> NonEmpty a
NonEmpty.fromList
         ([r :+ StatusStructure lineSegment]
 -> NonEmpty (r :+ StatusStructure lineSegment))
-> ([(Event r lineSegment, Event r lineSegment)]
    -> [r :+ StatusStructure lineSegment])
-> [(Event r lineSegment, Event r lineSegment)]
-> NonEmpty (r :+ StatusStructure lineSegment)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StatusStructure lineSegment, [r :+ StatusStructure lineSegment])
-> [r :+ StatusStructure lineSegment]
forall a b. (a, b) -> b
snd ((StatusStructure lineSegment, [r :+ StatusStructure lineSegment])
 -> [r :+ StatusStructure lineSegment])
-> ([(Event r lineSegment, Event r lineSegment)]
    -> (StatusStructure lineSegment,
        [r :+ StatusStructure lineSegment]))
-> [(Event r lineSegment, Event r lineSegment)]
-> [r :+ StatusStructure lineSegment]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StatusStructure lineSegment
 -> (Event r lineSegment, Event r lineSegment)
 -> (StatusStructure lineSegment, r :+ StatusStructure lineSegment))
-> StatusStructure lineSegment
-> [(Event r lineSegment, Event r lineSegment)]
-> (StatusStructure lineSegment,
    [r :+ StatusStructure lineSegment])
forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
List.mapAccumL StatusStructure lineSegment
-> (Event r lineSegment, Event r lineSegment)
-> (StatusStructure lineSegment, r :+ StatusStructure lineSegment)
StatusStructure lineSegment
-> (Event (NumType (IxValue (EndPointOf lineSegment))) lineSegment,
    Event (NumType (IxValue (EndPointOf lineSegment))) lineSegment)
-> (StatusStructure lineSegment,
    NumType (IxValue (EndPointOf lineSegment))
    :+ StatusStructure lineSegment)
forall {lineSegment}.
(Dimension lineSegment ~ 2,
 Dimension (IxValue (EndPointOf lineSegment)) ~ 2,
 Ord (NumType (IxValue (EndPointOf lineSegment))),
 Fractional (NumType (IxValue (EndPointOf lineSegment))),
 LineSegment_ lineSegment (IxValue (EndPointOf lineSegment)),
 Point_
   (IxValue (EndPointOf lineSegment))
   2
   (NumType (IxValue (EndPointOf lineSegment)))) =>
StatusStructure lineSegment
-> (Event (NumType (IxValue (EndPointOf lineSegment))) lineSegment,
    Event (NumType (IxValue (EndPointOf lineSegment))) lineSegment)
-> (StatusStructure lineSegment,
    NumType (IxValue (EndPointOf lineSegment))
    :+ StatusStructure lineSegment)
h StatusStructure lineSegment
forall a. Set a
SS.empty
         ([(Event r lineSegment, Event r lineSegment)]
 -> NonEmpty (r :+ StatusStructure lineSegment))
-> [(Event r lineSegment, Event r lineSegment)]
-> NonEmpty (r :+ StatusStructure lineSegment)
forall a b. (a -> b) -> a -> b
$ [Event r lineSegment]
-> [Event r lineSegment]
-> [(Event r lineSegment, Event r lineSegment)]
forall a b. [a] -> [b] -> [(a, b)]
zip (NonEmpty (Event r lineSegment) -> [Event r lineSegment]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty (Event r lineSegment)
es) (NonEmpty (Event r lineSegment) -> [Event r lineSegment]
forall a. NonEmpty a -> [a]
NonEmpty.tail NonEmpty (Event r lineSegment)
es)
  where
    h :: StatusStructure lineSegment
-> (Event (NumType (IxValue (EndPointOf lineSegment))) lineSegment,
    Event (NumType (IxValue (EndPointOf lineSegment))) lineSegment)
-> (StatusStructure lineSegment,
    NumType (IxValue (EndPointOf lineSegment))
    :+ StatusStructure lineSegment)
h StatusStructure lineSegment
ss (Event (NumType (IxValue (EndPointOf lineSegment))) lineSegment,
 Event (NumType (IxValue (EndPointOf lineSegment))) lineSegment)
evts = let NumType (IxValue (EndPointOf lineSegment))
x :+ StatusStructure lineSegment
ss' = StatusStructure lineSegment
-> (Event (NumType (IxValue (EndPointOf lineSegment))) lineSegment,
    Event (NumType (IxValue (EndPointOf lineSegment))) lineSegment)
-> NumType (IxValue (EndPointOf lineSegment))
   :+ StatusStructure lineSegment
forall r lineSegment point.
(Ord r, Fractional r, LineSegment_ lineSegment point,
 Point_ point 2 r) =>
StatusStructure lineSegment
-> (Event r lineSegment, Event r lineSegment)
-> r :+ StatusStructure lineSegment
handle StatusStructure lineSegment
ss (Event (NumType (IxValue (EndPointOf lineSegment))) lineSegment,
 Event (NumType (IxValue (EndPointOf lineSegment))) lineSegment)
evts in (StatusStructure lineSegment
ss',NumType (IxValue (EndPointOf lineSegment))
x NumType (IxValue (EndPointOf lineSegment))
-> StatusStructure lineSegment
-> NumType (IxValue (EndPointOf lineSegment))
   :+ StatusStructure lineSegment
forall core extra. core -> extra -> core :+ extra
:+ StatusStructure lineSegment
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, LineSegment_ lineSegment point, Point_ point 2 r)
                      => StatusStructure lineSegment
                      -> (Event r lineSegment, Event r lineSegment)
                      -> r :+ StatusStructure lineSegment
handle :: forall r lineSegment point.
(Ord r, Fractional r, LineSegment_ lineSegment point,
 Point_ point 2 r) =>
StatusStructure lineSegment
-> (Event r lineSegment, Event r lineSegment)
-> r :+ StatusStructure lineSegment
handle StatusStructure lineSegment
ss ( r
l :+ NonEmpty (Action lineSegment)
acts
          , r
r :+ NonEmpty (Action lineSegment)
_)   = 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 :: NumType (IxValue (EndPointOf a)) -> Action a -> Set a -> Set a
runActionAt NumType (IxValue (EndPointOf a))
x Action a
act = Action a -> (a -> a -> Ordering) -> Set a -> Set a
forall a. Action a -> (a -> a -> Ordering) -> Set a -> Set a
interpret Action a
act (NumType (IxValue (EndPointOf a)) -> a -> a -> Ordering
forall r lineSegment point.
(Num r, Ord r, LineSegment_ lineSegment point, Point_ point 2 r) =>
r -> lineSegment -> lineSegment -> Ordering
ordAtX NumType (IxValue (EndPointOf a))
x)
                        in r
r r
-> StatusStructure lineSegment -> r :+ StatusStructure lineSegment
forall core extra. core -> extra -> core :+ extra
:+ (Action lineSegment
 -> StatusStructure lineSegment -> StatusStructure lineSegment)
-> StatusStructure lineSegment
-> NonEmpty (Action lineSegment)
-> StatusStructure lineSegment
forall a b. (a -> b -> b) -> b -> NonEmpty a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (NumType (IxValue (EndPointOf lineSegment))
-> Action lineSegment
-> StatusStructure lineSegment
-> StatusStructure lineSegment
forall {a}.
(Dimension a ~ 2, Dimension (IxValue (EndPointOf a)) ~ 2,
 Num (NumType (IxValue (EndPointOf a))),
 Ord (NumType (IxValue (EndPointOf a))),
 LineSegment_ a (IxValue (EndPointOf a)),
 Point_
   (IxValue (EndPointOf a)) 2 (NumType (IxValue (EndPointOf a)))) =>
NumType (IxValue (EndPointOf a)) -> Action a -> Set a -> Set a
runActionAt r
NumType (IxValue (EndPointOf lineSegment))
mid) StatusStructure lineSegment
ss (NonEmpty (Action lineSegment) -> NonEmpty (Action lineSegment)
forall a. NonEmpty (Action a) -> NonEmpty (Action a)
orderActs NonEmpty (Action lineSegment)
acts)
                           -- run deletions first

-- | orders the actions to put insertions first and then all deletions
orderActs      :: NonEmpty (Action a) -> NonEmpty (Action a)
orderActs :: forall a. 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. HasCallStack => [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      :: ( LineSegment_ lineSegment point, Point_ point 2 r
                     , Point_ queryPoint 2 r
                     , Ord r, Num r, HasSupportingLine lineSegment
                     ) => queryPoint -> VerticalRayShootingStructure lineSegment
                  -> Maybe lineSegment
segmentAbove :: forall lineSegment point r queryPoint.
(LineSegment_ lineSegment point, Point_ point 2 r,
 Point_ queryPoint 2 r, Ord r, Num r,
 HasSupportingLine lineSegment) =>
queryPoint
-> VerticalRayShootingStructure lineSegment -> Maybe lineSegment
segmentAbove queryPoint
q VerticalRayShootingStructure lineSegment
ds = queryPoint
-> VerticalRayShootingStructure lineSegment
-> Maybe (StatusStructure lineSegment)
forall lineSegment point r queryPoint.
(LineSegment_ lineSegment point, Point_ point 2 r,
 Point_ queryPoint 2 r, Ord r, Num r,
 HasSupportingLine lineSegment) =>
queryPoint
-> VerticalRayShootingStructure lineSegment
-> Maybe (StatusStructure lineSegment)
findSlab queryPoint
q VerticalRayShootingStructure lineSegment
ds Maybe (StatusStructure lineSegment)
-> (StatusStructure lineSegment -> Maybe lineSegment)
-> Maybe lineSegment
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= queryPoint -> StatusStructure lineSegment -> Maybe lineSegment
forall lineSegment point r queryPoint.
(LineSegment_ lineSegment point, Point_ point 2 r,
 Point_ queryPoint 2 r, Ord r, Num r,
 HasSupportingLine lineSegment) =>
queryPoint -> StatusStructure lineSegment -> Maybe lineSegment
lookupAbove queryPoint
q

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



-- | Given a query point, find the (data structure of the) slab containing the query point
--
-- \(O(\log n)\)
findSlab  :: ( LineSegment_ lineSegment point, Point_ point 2 r
             , Point_ queryPoint 2 r
             , Ord r, Num r, HasSupportingLine lineSegment
             )
          => queryPoint -> VerticalRayShootingStructure lineSegment
          -> Maybe (StatusStructure lineSegment)
findSlab :: forall lineSegment point r queryPoint.
(LineSegment_ lineSegment point, Point_ point 2 r,
 Point_ queryPoint 2 r, Ord r, Num r,
 HasSupportingLine lineSegment) =>
queryPoint
-> VerticalRayShootingStructure lineSegment
-> Maybe (StatusStructure lineSegment)
findSlab queryPoint
q VerticalRayShootingStructure lineSegment
ds | queryPoint
qqueryPoint -> Getting r queryPoint r -> r
forall s a. s -> Getting a s a -> a
^.Getting r queryPoint r
forall (d :: Natural) point r.
(1 <= d, Point_ point d r) =>
IndexedLens' Int point r
IndexedLens' Int queryPoint r
xCoord r -> r -> Bool
forall a. Ord a => a -> a -> Bool
< VerticalRayShootingStructure' r lineSegment
VerticalRayShootingStructure lineSegment
dsVerticalRayShootingStructure' r lineSegment
-> Getting r (VerticalRayShootingStructure' r lineSegment) r -> r
forall s a. s -> Getting a s a -> a
^.Getting r (VerticalRayShootingStructure' r lineSegment) r
forall r lineSegment (f :: * -> *).
(Contravariant f, Functor f) =>
(r -> f r)
-> VerticalRayShootingStructure' r lineSegment
-> f (VerticalRayShootingStructure' r lineSegment)
leftMost = Maybe (StatusStructure lineSegment)
forall a. Maybe a
Nothing
              | Bool
otherwise                = Getting
  (StatusStructure lineSegment)
  (r :+ StatusStructure lineSegment)
  (StatusStructure lineSegment)
-> (r :+ StatusStructure lineSegment)
-> StatusStructure lineSegment
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting
  (StatusStructure lineSegment)
  (r :+ StatusStructure lineSegment)
  (StatusStructure lineSegment)
forall core extra extra' (f :: * -> *).
Functor f =>
(extra -> f extra') -> (core :+ extra) -> f (core :+ extra')
extra
                                        ((r :+ StatusStructure lineSegment) -> StatusStructure lineSegment)
-> Maybe (r :+ StatusStructure lineSegment)
-> Maybe (StatusStructure lineSegment)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Elem (Vector (r :+ StatusStructure lineSegment)) -> Bool)
-> Vector (r :+ StatusStructure lineSegment)
-> Maybe (Elem (Vector (r :+ StatusStructure lineSegment)))
forall v. BinarySearch v => (Elem v -> Bool) -> v -> Maybe (Elem v)
binarySearchFirstIn (queryPoint
q `leftOf `) (VerticalRayShootingStructure' r lineSegment
VerticalRayShootingStructure lineSegment
dsVerticalRayShootingStructure' r lineSegment
-> Getting
     (Vector (r :+ StatusStructure lineSegment))
     (VerticalRayShootingStructure' r lineSegment)
     (Vector (r :+ StatusStructure lineSegment))
-> Vector (r :+ StatusStructure lineSegment)
forall s a. s -> Getting a s a -> a
^.Getting
  (Vector (r :+ StatusStructure lineSegment))
  (VerticalRayShootingStructure' r lineSegment)
  (Vector (r :+ StatusStructure lineSegment))
forall r lineSegment (f :: * -> *).
(Contravariant f, Functor f) =>
(Vector (r :+ StatusStructure lineSegment)
 -> f (Vector (r :+ StatusStructure lineSegment)))
-> VerticalRayShootingStructure' r lineSegment
-> f (VerticalRayShootingStructure' r lineSegment)
sweepStruct)
  where
    s
q' leftOf :: s -> (NumType s :+ extra) -> Bool
`leftOf` (NumType s
r :+ extra
_) = s
q's -> Getting (NumType s) s (NumType s) -> NumType s
forall s a. s -> Getting a s a -> a
^.Getting (NumType s) s (NumType s)
forall (d :: Natural) point r.
(1 <= d, Point_ point d r) =>
IndexedLens' Int point r
IndexedLens' Int s (NumType s)
xCoord NumType s -> NumType s -> Bool
forall a. Ord a => a -> a -> Bool
<= NumType s
r

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

-- | Finds the segment containing or above the query point 'q'
--
-- \(O(\log n)\)
lookupAboveOrOn   :: ( LineSegment_ lineSegment point, Point_ point 2 r
                     , Point_ queryPoint 2 r
                     , Ord r, Num r, HasSupportingLine lineSegment
                     )
                  => queryPoint -> StatusStructure lineSegment -> Maybe lineSegment
lookupAboveOrOn :: forall lineSegment point r queryPoint.
(LineSegment_ lineSegment point, Point_ point 2 r,
 Point_ queryPoint 2 r, Ord r, Num r,
 HasSupportingLine lineSegment) =>
queryPoint -> StatusStructure lineSegment -> Maybe lineSegment
lookupAboveOrOn queryPoint
q = (LinePV 2 r -> Bool)
-> StatusStructure lineSegment -> Maybe lineSegment
forall lineSegment point r.
(LineSegment_ lineSegment point, Point_ point 2 r,
 HasSupportingLine lineSegment, Num r) =>
(LinePV 2 r -> Bool)
-> StatusStructure lineSegment -> Maybe lineSegment
searchInSlab (Bool -> Bool
not (Bool -> Bool) -> (LinePV 2 r -> Bool) -> LinePV 2 r -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (queryPoint
q `liesAbove`))

-- | Finds the first segment strictly above q
--
-- \(O(\log n)\)
lookupAbove   :: ( LineSegment_ lineSegment point, Point_ point 2 r
                 , Point_ queryPoint 2 r
                 , Ord r, Num r, HasSupportingLine lineSegment
                 )
              => queryPoint -> StatusStructure lineSegment -> Maybe lineSegment
lookupAbove :: forall lineSegment point r queryPoint.
(LineSegment_ lineSegment point, Point_ point 2 r,
 Point_ queryPoint 2 r, Ord r, Num r,
 HasSupportingLine lineSegment) =>
queryPoint -> StatusStructure lineSegment -> Maybe lineSegment
lookupAbove queryPoint
q = (LinePV 2 r -> Bool)
-> StatusStructure lineSegment -> Maybe lineSegment
forall lineSegment point r.
(LineSegment_ lineSegment point, Point_ point 2 r,
 HasSupportingLine lineSegment, Num r) =>
(LinePV 2 r -> Bool)
-> StatusStructure lineSegment -> Maybe lineSegment
searchInSlab (queryPoint
q `liesBelow`)

-- | generic searching function
searchInSlab   :: (LineSegment_ lineSegment point, Point_ point 2 r
                  , HasSupportingLine lineSegment, Num r)
               => (LinePV 2 r -> Bool)
               -> StatusStructure lineSegment -> Maybe lineSegment
searchInSlab :: forall lineSegment point r.
(LineSegment_ lineSegment point, Point_ point 2 r,
 HasSupportingLine lineSegment, Num r) =>
(LinePV 2 r -> Bool)
-> StatusStructure lineSegment -> Maybe lineSegment
searchInSlab LinePV 2 r -> Bool
p = (Elem (StatusStructure lineSegment) -> Bool)
-> StatusStructure lineSegment
-> Maybe (Elem (StatusStructure lineSegment))
forall v. BinarySearch v => (Elem v -> Bool) -> v -> Maybe (Elem v)
binarySearchFirstIn (LinePV 2 r -> Bool
p (LinePV 2 r -> Bool)
-> (lineSegment -> LinePV 2 r) -> lineSegment -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. lineSegment -> LinePV 2 r
lineSegment -> LinePV (Dimension lineSegment) (NumType lineSegment)
forall t.
HasSupportingLine t =>
t -> LinePV (Dimension t) (NumType t)
supportingLine)


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