{-# Language TemplateHaskell #-}
module HGeometry.VerticalRayShooting.PersistentSweep
( VerticalRayShootingStructure
, StatusStructure
, verticalRayShootingStructure
, 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
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
type VerticalRayShootingStructure lineSegment =
VerticalRayShootingStructure' (NumType lineSegment) lineSegment
data VerticalRayShootingStructure' r lineSegment =
VerticalRayShootingStructure { forall r lineSegment.
VerticalRayShootingStructure' r lineSegment -> r
_leftMost :: r
, forall r lineSegment.
VerticalRayShootingStructure' r lineSegment
-> Vector (r :+ StatusStructure lineSegment)
_sweepStruct :: V.Vector (r :+ StatusStructure lineSegment)
} 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)
type StatusStructure lineSegment = SS.Set lineSegment
makeLensesWith (lensRules&generateUpdateableOptics .~ False) ''VerticalRayShootingStructure'
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
:| []
]
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)
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
type Event r lineSegment = r :+ NonEmpty (Action lineSegment)
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
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
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')
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)
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
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
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
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
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`))
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`)
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)