{-# LANGUAGE ScopedTypeVariables #-}
module Algorithms.Geometry.LineSegmentIntersection.BentleyOttmann
( intersections
, interiorIntersections
) where
import Algorithms.Geometry.LineSegmentIntersection.Types
import Control.Lens hiding (contains)
import Data.Coerce
import Data.Ext
import qualified Data.Foldable as F
import Data.Function (on)
import Data.Geometry.Interval
import Data.Geometry.LineSegment
import Data.Geometry.Point
import Data.Geometry.Properties
import qualified Data.List as L
import Data.List.NonEmpty (NonEmpty(..))
import qualified Data.List.NonEmpty as NonEmpty
import qualified Data.Map as M
import Data.Maybe
import Data.Ord (Down(..), comparing)
import qualified Data.Set as EQ
import qualified Data.Set as SS
import qualified Data.Set as Set
import qualified Data.Set.Util as SS
import Data.Vinyl
import Data.Vinyl.CoRec
intersections :: forall p r e. (Ord r, Fractional r)
=> [LineSegment 2 p r :+ e] -> Intersections p r e
intersections :: [LineSegment 2 p r :+ e] -> Intersections p r e
intersections [LineSegment 2 p r :+ e]
ss = (Associated p r (e :+ Flipped) -> Associated p r e)
-> Map (Point 2 r) (Associated p r (e :+ Flipped))
-> Intersections p r e
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Associated p r (e :+ Flipped) -> Associated p r e
forall r p e.
(Fractional r, Ord r) =>
Associated p r (e :+ Flipped) -> Associated p r e
unflipSegs (Map (Point 2 r) (Associated p r (e :+ Flipped))
-> Intersections p r e)
-> ([IntersectionPoint p r (e :+ Flipped)]
-> Map (Point 2 r) (Associated p r (e :+ Flipped)))
-> [IntersectionPoint p r (e :+ Flipped)]
-> Intersections p r e
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [IntersectionPoint p r (e :+ Flipped)]
-> Map (Point 2 r) (Associated p r (e :+ Flipped))
forall r p e.
(Ord r, Fractional r) =>
[IntersectionPoint p r e] -> Intersections p r e
merge ([IntersectionPoint p r (e :+ Flipped)] -> Intersections p r e)
-> [IntersectionPoint p r (e :+ Flipped)] -> Intersections p r e
forall a b. (a -> b) -> a -> b
$ EventQueue p r (e :+ Flipped)
-> StatusStructure p r (e :+ Flipped)
-> [IntersectionPoint p r (e :+ Flipped)]
forall r p e.
(Ord r, Fractional r) =>
EventQueue p r e
-> StatusStructure p r e -> [IntersectionPoint p r e]
sweep EventQueue p r (e :+ Flipped)
pts StatusStructure p r (e :+ Flipped)
forall a. Set a
SS.empty
where
pts :: EventQueue p r (e :+ Flipped)
pts = [Event p r (e :+ Flipped)] -> EventQueue p r (e :+ Flipped)
forall a. Eq a => [a] -> Set a
EQ.fromAscList ([Event p r (e :+ Flipped)] -> EventQueue p r (e :+ Flipped))
-> ([LineSegment 2 p r :+ e] -> [Event p r (e :+ Flipped)])
-> [LineSegment 2 p r :+ e]
-> EventQueue p r (e :+ Flipped)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Event p r (e :+ Flipped)] -> [Event p r (e :+ Flipped)]
forall r p e. Eq r => [Event p r e] -> [Event p r e]
groupStarts ([Event p r (e :+ Flipped)] -> [Event p r (e :+ Flipped)])
-> ([LineSegment 2 p r :+ e] -> [Event p r (e :+ Flipped)])
-> [LineSegment 2 p r :+ e]
-> [Event p r (e :+ Flipped)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Event p r (e :+ Flipped)] -> [Event p r (e :+ Flipped)]
forall a. Ord a => [a] -> [a]
L.sort ([Event p r (e :+ Flipped)] -> [Event p r (e :+ Flipped)])
-> ([LineSegment 2 p r :+ e] -> [Event p r (e :+ Flipped)])
-> [LineSegment 2 p r :+ e]
-> [Event p r (e :+ Flipped)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((LineSegment 2 p r :+ e) -> [Event p r (e :+ Flipped)])
-> [LineSegment 2 p r :+ e] -> [Event p r (e :+ Flipped)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((LineSegment 2 p r :+ (e :+ Flipped)) -> [Event p r (e :+ Flipped)]
forall p r e. (LineSegment 2 p r :+ e) -> [Event p r e]
asEventPts ((LineSegment 2 p r :+ (e :+ Flipped))
-> [Event p r (e :+ Flipped)])
-> ((LineSegment 2 p r :+ e)
-> LineSegment 2 p r :+ (e :+ Flipped))
-> (LineSegment 2 p r :+ e)
-> [Event p r (e :+ Flipped)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LineSegment 2 p r :+ e) -> LineSegment 2 p r :+ (e :+ Flipped)
forall r p e.
Ord r =>
(LineSegment 2 p r :+ e) -> LineSegment 2 p r :+ (e :+ Flipped)
tagFlipped) ([LineSegment 2 p r :+ e] -> EventQueue p r (e :+ Flipped))
-> [LineSegment 2 p r :+ e] -> EventQueue p r (e :+ Flipped)
forall a b. (a -> b) -> a -> b
$ [LineSegment 2 p r :+ e]
ss
interiorIntersections :: (Ord r, Fractional r)
=> [LineSegment 2 p r :+ e] -> Intersections p r e
interiorIntersections :: [LineSegment 2 p r :+ e] -> Intersections p r e
interiorIntersections = (Associated p r e -> Bool)
-> Intersections p r e -> Intersections p r e
forall a k. (a -> Bool) -> Map k a -> Map k a
M.filter Associated p r e -> Bool
forall p r e. Associated p r e -> Bool
isInteriorIntersection (Intersections p r e -> Intersections p r e)
-> ([LineSegment 2 p r :+ e] -> Intersections p r e)
-> [LineSegment 2 p r :+ e]
-> Intersections p r e
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [LineSegment 2 p r :+ e] -> Intersections p r e
forall p r e.
(Ord r, Fractional r) =>
[LineSegment 2 p r :+ e] -> Intersections p r e
intersections
data Flipped = NotFlipped | Flipped deriving (Int -> Flipped -> ShowS
[Flipped] -> ShowS
Flipped -> String
(Int -> Flipped -> ShowS)
-> (Flipped -> String) -> ([Flipped] -> ShowS) -> Show Flipped
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Flipped] -> ShowS
$cshowList :: [Flipped] -> ShowS
show :: Flipped -> String
$cshow :: Flipped -> String
showsPrec :: Int -> Flipped -> ShowS
$cshowsPrec :: Int -> Flipped -> ShowS
Show,Flipped -> Flipped -> Bool
(Flipped -> Flipped -> Bool)
-> (Flipped -> Flipped -> Bool) -> Eq Flipped
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Flipped -> Flipped -> Bool
$c/= :: Flipped -> Flipped -> Bool
== :: Flipped -> Flipped -> Bool
$c== :: Flipped -> Flipped -> Bool
Eq)
tagFlipped :: Ord r => LineSegment 2 p r :+ e -> LineSegment 2 p r :+ (e :+ Flipped)
tagFlipped :: (LineSegment 2 p r :+ e) -> LineSegment 2 p r :+ (e :+ Flipped)
tagFlipped LineSegment 2 p r :+ e
s = case (LineSegment 2 p r :+ e
s(LineSegment 2 p r :+ e)
-> Getting (Point 2 r) (LineSegment 2 p r :+ e) (Point 2 r)
-> Point 2 r
forall s a. s -> Getting a s a -> a
^.(LineSegment 2 p r -> Const (Point 2 r) (LineSegment 2 p r))
-> (LineSegment 2 p r :+ e)
-> Const (Point 2 r) (LineSegment 2 p r :+ e)
forall core extra core'.
Lens (core :+ extra) (core' :+ extra) core core'
core((LineSegment 2 p r -> Const (Point 2 r) (LineSegment 2 p r))
-> (LineSegment 2 p r :+ e)
-> Const (Point 2 r) (LineSegment 2 p r :+ e))
-> ((Point 2 r -> Const (Point 2 r) (Point 2 r))
-> LineSegment 2 p r -> Const (Point 2 r) (LineSegment 2 p r))
-> Getting (Point 2 r) (LineSegment 2 p r :+ e) (Point 2 r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.((Point 2 r :+ p) -> Const (Point 2 r) (Point 2 r :+ p))
-> LineSegment 2 p r -> Const (Point 2 r) (LineSegment 2 p r)
forall t. HasStart t => Lens' t (StartCore t :+ StartExtra t)
start(((Point 2 r :+ p) -> Const (Point 2 r) (Point 2 r :+ p))
-> LineSegment 2 p r -> Const (Point 2 r) (LineSegment 2 p r))
-> ((Point 2 r -> Const (Point 2 r) (Point 2 r))
-> (Point 2 r :+ p) -> Const (Point 2 r) (Point 2 r :+ p))
-> (Point 2 r -> Const (Point 2 r) (Point 2 r))
-> LineSegment 2 p r
-> Const (Point 2 r) (LineSegment 2 p r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Point 2 r -> Const (Point 2 r) (Point 2 r))
-> (Point 2 r :+ p) -> Const (Point 2 r) (Point 2 r :+ p)
forall core extra core'.
Lens (core :+ extra) (core' :+ extra) core core'
core) Point 2 r -> Point 2 r -> Ordering
forall r. Ord r => Point 2 r -> Point 2 r -> Ordering
`ordPoints` (LineSegment 2 p r :+ e
s(LineSegment 2 p r :+ e)
-> Getting (Point 2 r) (LineSegment 2 p r :+ e) (Point 2 r)
-> Point 2 r
forall s a. s -> Getting a s a -> a
^.(LineSegment 2 p r -> Const (Point 2 r) (LineSegment 2 p r))
-> (LineSegment 2 p r :+ e)
-> Const (Point 2 r) (LineSegment 2 p r :+ e)
forall core extra core'.
Lens (core :+ extra) (core' :+ extra) core core'
core((LineSegment 2 p r -> Const (Point 2 r) (LineSegment 2 p r))
-> (LineSegment 2 p r :+ e)
-> Const (Point 2 r) (LineSegment 2 p r :+ e))
-> ((Point 2 r -> Const (Point 2 r) (Point 2 r))
-> LineSegment 2 p r -> Const (Point 2 r) (LineSegment 2 p r))
-> Getting (Point 2 r) (LineSegment 2 p r :+ e) (Point 2 r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.((Point 2 r :+ p) -> Const (Point 2 r) (Point 2 r :+ p))
-> LineSegment 2 p r -> Const (Point 2 r) (LineSegment 2 p r)
forall t. HasEnd t => Lens' t (EndCore t :+ EndExtra t)
end(((Point 2 r :+ p) -> Const (Point 2 r) (Point 2 r :+ p))
-> LineSegment 2 p r -> Const (Point 2 r) (LineSegment 2 p r))
-> ((Point 2 r -> Const (Point 2 r) (Point 2 r))
-> (Point 2 r :+ p) -> Const (Point 2 r) (Point 2 r :+ p))
-> (Point 2 r -> Const (Point 2 r) (Point 2 r))
-> LineSegment 2 p r
-> Const (Point 2 r) (LineSegment 2 p r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Point 2 r -> Const (Point 2 r) (Point 2 r))
-> (Point 2 r :+ p) -> Const (Point 2 r) (Point 2 r :+ p)
forall core extra core'.
Lens (core :+ extra) (core' :+ extra) core core'
core) of
Ordering
GT -> LineSegment 2 p r :+ e
s(LineSegment 2 p r :+ e)
-> ((LineSegment 2 p r :+ e) -> LineSegment 2 p r :+ e)
-> LineSegment 2 p r :+ e
forall a b. a -> (a -> b) -> b
&(LineSegment 2 p r -> Identity (LineSegment 2 p r))
-> (LineSegment 2 p r :+ e) -> Identity (LineSegment 2 p r :+ e)
forall core extra core'.
Lens (core :+ extra) (core' :+ extra) core core'
core ((LineSegment 2 p r -> Identity (LineSegment 2 p r))
-> (LineSegment 2 p r :+ e) -> Identity (LineSegment 2 p r :+ e))
-> (LineSegment 2 p r -> LineSegment 2 p r)
-> (LineSegment 2 p r :+ e)
-> LineSegment 2 p r :+ e
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ LineSegment 2 p r -> LineSegment 2 p r
forall (d :: Nat) p r. LineSegment d p r -> LineSegment d p r
flipSeg
(LineSegment 2 p r :+ e)
-> ((LineSegment 2 p r :+ e)
-> LineSegment 2 p r :+ (e :+ Flipped))
-> LineSegment 2 p r :+ (e :+ Flipped)
forall a b. a -> (a -> b) -> b
&(e -> Identity (e :+ Flipped))
-> (LineSegment 2 p r :+ e)
-> Identity (LineSegment 2 p r :+ (e :+ Flipped))
forall core extra extra'.
Lens (core :+ extra) (core :+ extra') extra extra'
extra ((e -> Identity (e :+ Flipped))
-> (LineSegment 2 p r :+ e)
-> Identity (LineSegment 2 p r :+ (e :+ Flipped)))
-> (e -> e :+ Flipped)
-> (LineSegment 2 p r :+ e)
-> LineSegment 2 p r :+ (e :+ Flipped)
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (e -> Flipped -> e :+ Flipped
forall core extra. core -> extra -> core :+ extra
:+ Flipped
Flipped)
Ordering
_ -> LineSegment 2 p r :+ e
s(LineSegment 2 p r :+ e)
-> ((LineSegment 2 p r :+ e)
-> LineSegment 2 p r :+ (e :+ Flipped))
-> LineSegment 2 p r :+ (e :+ Flipped)
forall a b. a -> (a -> b) -> b
&(e -> Identity (e :+ Flipped))
-> (LineSegment 2 p r :+ e)
-> Identity (LineSegment 2 p r :+ (e :+ Flipped))
forall core extra extra'.
Lens (core :+ extra) (core :+ extra') extra extra'
extra ((e -> Identity (e :+ Flipped))
-> (LineSegment 2 p r :+ e)
-> Identity (LineSegment 2 p r :+ (e :+ Flipped)))
-> (e -> e :+ Flipped)
-> (LineSegment 2 p r :+ e)
-> LineSegment 2 p r :+ (e :+ Flipped)
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (e -> Flipped -> e :+ Flipped
forall core extra. core -> extra -> core :+ extra
:+ Flipped
NotFlipped)
flipSeg :: LineSegment d p r -> LineSegment d p r
flipSeg :: LineSegment d p r -> LineSegment d p r
flipSeg LineSegment d p r
seg = LineSegment d p r
segLineSegment d p r
-> (LineSegment d p r -> LineSegment d p r) -> LineSegment d p r
forall a b. a -> (a -> b) -> b
&((Point d r :+ p) -> Identity (Point d r :+ p))
-> LineSegment d p r -> Identity (LineSegment d p r)
forall t. HasStart t => Lens' t (StartCore t :+ StartExtra t)
start (((Point d r :+ p) -> Identity (Point d r :+ p))
-> LineSegment d p r -> Identity (LineSegment d p r))
-> (Point d r :+ p) -> LineSegment d p r -> LineSegment d p r
forall s t a b. ASetter s t a b -> b -> s -> t
.~ (LineSegment d p r
segLineSegment d p r
-> Getting (Point d r :+ p) (LineSegment d p r) (Point d r :+ p)
-> Point d r :+ p
forall s a. s -> Getting a s a -> a
^.Getting (Point d r :+ p) (LineSegment d p r) (Point d r :+ p)
forall t. HasEnd t => Lens' t (EndCore t :+ EndExtra t)
end)
LineSegment d p r
-> (LineSegment d p r -> LineSegment d p r) -> LineSegment d p r
forall a b. a -> (a -> b) -> b
&((Point d r :+ p) -> Identity (Point d r :+ p))
-> LineSegment d p r -> Identity (LineSegment d p r)
forall t. HasEnd t => Lens' t (EndCore t :+ EndExtra t)
end (((Point d r :+ p) -> Identity (Point d r :+ p))
-> LineSegment d p r -> Identity (LineSegment d p r))
-> (Point d r :+ p) -> LineSegment d p r -> LineSegment d p r
forall s t a b. ASetter s t a b -> b -> s -> t
.~ (LineSegment d p r
segLineSegment d p r
-> Getting (Point d r :+ p) (LineSegment d p r) (Point d r :+ p)
-> Point d r :+ p
forall s a. s -> Getting a s a -> a
^.Getting (Point d r :+ p) (LineSegment d p r) (Point d r :+ p)
forall t. HasStart t => Lens' t (StartCore t :+ StartExtra t)
start)
unflipSegs :: (Fractional r, Ord r)
=> Associated p r (e :+ Flipped) -> Associated p r e
unflipSegs :: Associated p r (e :+ Flipped) -> Associated p r e
unflipSegs (Associated Set (AroundEnd (LineSegment 2 p r :+ (e :+ Flipped)))
ss Set (AroundStart (LineSegment 2 p r :+ (e :+ Flipped)))
es Set (AroundIntersection (LineSegment 2 p r :+ (e :+ Flipped)))
is) =
Set (AroundEnd (LineSegment 2 p r :+ e))
-> Set (AroundStart (LineSegment 2 p r :+ e))
-> Set (AroundIntersection (LineSegment 2 p r :+ e))
-> Associated p r e
forall p r e.
Set (AroundEnd (LineSegment 2 p r :+ e))
-> Set (AroundStart (LineSegment 2 p r :+ e))
-> Set (AroundIntersection (LineSegment 2 p r :+ e))
-> Associated p r e
Associated (Set (AroundEnd (LineSegment 2 p r :+ (e :+ Flipped)))
-> Set (AroundEnd (LineSegment 2 p r :+ e))
forall (f :: * -> *) p r e.
Functor f =>
Set (f (LineSegment 2 p r :+ (e :+ Flipped)))
-> Set (f (LineSegment 2 p r :+ e))
dropFlipped Set (AroundEnd (LineSegment 2 p r :+ (e :+ Flipped)))
ss1 Set (AroundEnd (LineSegment 2 p r :+ e))
-> Set (AroundEnd (LineSegment 2 p r :+ e))
-> Set (AroundEnd (LineSegment 2 p r :+ e))
forall a. Semigroup a => a -> a -> a
<> Set (AroundStart (LineSegment 2 p r :+ (e :+ Flipped)))
-> Set (AroundEnd (LineSegment 2 p r :+ e))
forall (f :: * -> *) p r e (g :: * -> *).
(Functor f,
Coercible
(f (LineSegment 2 p r :+ e)) (g (LineSegment 2 p r :+ e))) =>
Set (f (LineSegment 2 p r :+ (e :+ Flipped)))
-> Set (g (LineSegment 2 p r :+ e))
unflipSegs' Set (AroundStart (LineSegment 2 p r :+ (e :+ Flipped)))
es')
(Set (AroundStart (LineSegment 2 p r :+ (e :+ Flipped)))
-> Set (AroundStart (LineSegment 2 p r :+ e))
forall (f :: * -> *) p r e.
Functor f =>
Set (f (LineSegment 2 p r :+ (e :+ Flipped)))
-> Set (f (LineSegment 2 p r :+ e))
dropFlipped Set (AroundStart (LineSegment 2 p r :+ (e :+ Flipped)))
es1 Set (AroundStart (LineSegment 2 p r :+ e))
-> Set (AroundStart (LineSegment 2 p r :+ e))
-> Set (AroundStart (LineSegment 2 p r :+ e))
forall a. Semigroup a => a -> a -> a
<> Set (AroundEnd (LineSegment 2 p r :+ (e :+ Flipped)))
-> Set (AroundStart (LineSegment 2 p r :+ e))
forall (f :: * -> *) p r e (g :: * -> *).
(Functor f,
Coercible
(f (LineSegment 2 p r :+ e)) (g (LineSegment 2 p r :+ e))) =>
Set (f (LineSegment 2 p r :+ (e :+ Flipped)))
-> Set (g (LineSegment 2 p r :+ e))
unflipSegs' Set (AroundEnd (LineSegment 2 p r :+ (e :+ Flipped)))
ss')
(Set (AroundIntersection (LineSegment 2 p r :+ (e :+ Flipped)))
-> Set (AroundIntersection (LineSegment 2 p r :+ e))
forall (f :: * -> *) p r e.
Functor f =>
Set (f (LineSegment 2 p r :+ (e :+ Flipped)))
-> Set (f (LineSegment 2 p r :+ e))
dropFlipped Set (AroundIntersection (LineSegment 2 p r :+ (e :+ Flipped)))
is1 Set (AroundIntersection (LineSegment 2 p r :+ e))
-> Set (AroundIntersection (LineSegment 2 p r :+ e))
-> Set (AroundIntersection (LineSegment 2 p r :+ e))
forall a. Semigroup a => a -> a -> a
<> Set (AroundIntersection (LineSegment 2 p r :+ (e :+ Flipped)))
-> Set (AroundIntersection (LineSegment 2 p r :+ e))
forall (f :: * -> *) p r e (g :: * -> *).
(Functor f,
Coercible
(f (LineSegment 2 p r :+ e)) (g (LineSegment 2 p r :+ e))) =>
Set (f (LineSegment 2 p r :+ (e :+ Flipped)))
-> Set (g (LineSegment 2 p r :+ e))
unflipSegs' Set (AroundIntersection (LineSegment 2 p r :+ (e :+ Flipped)))
is')
where
(Set (AroundEnd (LineSegment 2 p r :+ (e :+ Flipped)))
ss',Set (AroundEnd (LineSegment 2 p r :+ (e :+ Flipped)))
ss1) = (AroundEnd (LineSegment 2 p r :+ (e :+ Flipped)) -> Bool)
-> Set (AroundEnd (LineSegment 2 p r :+ (e :+ Flipped)))
-> (Set (AroundEnd (LineSegment 2 p r :+ (e :+ Flipped))),
Set (AroundEnd (LineSegment 2 p r :+ (e :+ Flipped))))
forall a. (a -> Bool) -> Set a -> (Set a, Set a)
Set.partition (\(AroundEnd LineSegment 2 p r :+ (e :+ Flipped)
s) -> (LineSegment 2 p r :+ (e :+ Flipped)) -> Bool
forall core core. (core :+ (core :+ Flipped)) -> Bool
isFlipped LineSegment 2 p r :+ (e :+ Flipped)
s) Set (AroundEnd (LineSegment 2 p r :+ (e :+ Flipped)))
ss
(Set (AroundStart (LineSegment 2 p r :+ (e :+ Flipped)))
es',Set (AroundStart (LineSegment 2 p r :+ (e :+ Flipped)))
es1) = (AroundStart (LineSegment 2 p r :+ (e :+ Flipped)) -> Bool)
-> Set (AroundStart (LineSegment 2 p r :+ (e :+ Flipped)))
-> (Set (AroundStart (LineSegment 2 p r :+ (e :+ Flipped))),
Set (AroundStart (LineSegment 2 p r :+ (e :+ Flipped))))
forall a. (a -> Bool) -> Set a -> (Set a, Set a)
Set.partition (\(AroundStart LineSegment 2 p r :+ (e :+ Flipped)
s) -> (LineSegment 2 p r :+ (e :+ Flipped)) -> Bool
forall core core. (core :+ (core :+ Flipped)) -> Bool
isFlipped LineSegment 2 p r :+ (e :+ Flipped)
s) Set (AroundStart (LineSegment 2 p r :+ (e :+ Flipped)))
es
(Set (AroundIntersection (LineSegment 2 p r :+ (e :+ Flipped)))
is',Set (AroundIntersection (LineSegment 2 p r :+ (e :+ Flipped)))
is1) = (AroundIntersection (LineSegment 2 p r :+ (e :+ Flipped)) -> Bool)
-> Set (AroundIntersection (LineSegment 2 p r :+ (e :+ Flipped)))
-> (Set (AroundIntersection (LineSegment 2 p r :+ (e :+ Flipped))),
Set (AroundIntersection (LineSegment 2 p r :+ (e :+ Flipped))))
forall a. (a -> Bool) -> Set a -> (Set a, Set a)
Set.partition (\(AroundIntersection LineSegment 2 p r :+ (e :+ Flipped)
s) -> (LineSegment 2 p r :+ (e :+ Flipped)) -> Bool
forall core core. (core :+ (core :+ Flipped)) -> Bool
isFlipped LineSegment 2 p r :+ (e :+ Flipped)
s) Set (AroundIntersection (LineSegment 2 p r :+ (e :+ Flipped)))
is
isFlipped :: (core :+ (core :+ Flipped)) -> Bool
isFlipped core :+ (core :+ Flipped)
s = Flipped
Flipped Flipped -> Flipped -> Bool
forall a. Eq a => a -> a -> Bool
== core :+ (core :+ Flipped)
s(core :+ (core :+ Flipped))
-> Getting Flipped (core :+ (core :+ Flipped)) Flipped -> Flipped
forall s a. s -> Getting a s a -> a
^.((core :+ Flipped) -> Const Flipped (core :+ Flipped))
-> (core :+ (core :+ Flipped))
-> Const Flipped (core :+ (core :+ Flipped))
forall core extra extra'.
Lens (core :+ extra) (core :+ extra') extra extra'
extra(((core :+ Flipped) -> Const Flipped (core :+ Flipped))
-> (core :+ (core :+ Flipped))
-> Const Flipped (core :+ (core :+ Flipped)))
-> ((Flipped -> Const Flipped Flipped)
-> (core :+ Flipped) -> Const Flipped (core :+ Flipped))
-> Getting Flipped (core :+ (core :+ Flipped)) Flipped
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Flipped -> Const Flipped Flipped)
-> (core :+ Flipped) -> Const Flipped (core :+ Flipped)
forall core extra extra'.
Lens (core :+ extra) (core :+ extra') extra extra'
extra
dropFlipped :: Functor f
=> Set.Set (f (LineSegment 2 p r :+ (e :+ Flipped)))
-> Set.Set (f (LineSegment 2 p r :+ e))
dropFlipped :: Set (f (LineSegment 2 p r :+ (e :+ Flipped)))
-> Set (f (LineSegment 2 p r :+ e))
dropFlipped = (f (LineSegment 2 p r :+ (e :+ Flipped))
-> f (LineSegment 2 p r :+ e))
-> Set (f (LineSegment 2 p r :+ (e :+ Flipped)))
-> Set (f (LineSegment 2 p r :+ e))
forall a b. (a -> b) -> Set a -> Set b
Set.mapMonotonic (((LineSegment 2 p r :+ (e :+ Flipped)) -> LineSegment 2 p r :+ e)
-> f (LineSegment 2 p r :+ (e :+ Flipped))
-> f (LineSegment 2 p r :+ e)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (LineSegment 2 p r :+ (e :+ Flipped)) -> LineSegment 2 p r :+ e
forall core extra extra.
(core :+ (extra :+ extra)) -> core :+ extra
dropFlip)
unflipSegs' :: ( Functor f
, Coercible (f (LineSegment 2 p r :+ e)) (g (LineSegment 2 p r :+ e))
)
=> Set.Set (f (LineSegment 2 p r :+ (e :+ Flipped)))
-> Set.Set (g (LineSegment 2 p r :+ e))
unflipSegs' :: Set (f (LineSegment 2 p r :+ (e :+ Flipped)))
-> Set (g (LineSegment 2 p r :+ e))
unflipSegs' = (f (LineSegment 2 p r :+ (e :+ Flipped))
-> g (LineSegment 2 p r :+ e))
-> Set (f (LineSegment 2 p r :+ (e :+ Flipped)))
-> Set (g (LineSegment 2 p r :+ e))
forall a b. (a -> b) -> Set a -> Set b
Set.mapMonotonic (f (LineSegment 2 p r :+ e) -> g (LineSegment 2 p r :+ e)
coerce (f (LineSegment 2 p r :+ e) -> g (LineSegment 2 p r :+ e))
-> (f (LineSegment 2 p r :+ (e :+ Flipped))
-> f (LineSegment 2 p r :+ e))
-> f (LineSegment 2 p r :+ (e :+ Flipped))
-> g (LineSegment 2 p r :+ e)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((LineSegment 2 p r :+ (e :+ Flipped)) -> LineSegment 2 p r :+ e)
-> f (LineSegment 2 p r :+ (e :+ Flipped))
-> f (LineSegment 2 p r :+ e)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (LineSegment 2 p r :+ (e :+ Flipped)) -> LineSegment 2 p r :+ e
forall (d :: Nat) p r extra extra.
(LineSegment d p r :+ (extra :+ extra))
-> LineSegment d p r :+ extra
unflip)
unflip :: (LineSegment d p r :+ (extra :+ extra))
-> LineSegment d p r :+ extra
unflip (LineSegment d p r
s :+ (extra
e :+ extra
_)) = LineSegment d p r -> LineSegment d p r
forall (d :: Nat) p r. LineSegment d p r -> LineSegment d p r
flipSeg LineSegment d p r
s LineSegment d p r -> extra -> LineSegment d p r :+ extra
forall core extra. core -> extra -> core :+ extra
:+ extra
e
dropFlip :: (core :+ (extra :+ extra)) -> core :+ extra
dropFlip (core
s :+ (extra
e :+ extra
_)) = core
s core -> extra -> core :+ extra
forall core extra. core -> extra -> core :+ extra
:+ extra
e
asEventPts :: LineSegment 2 p r :+ e -> [Event p r e]
asEventPts :: (LineSegment 2 p r :+ e) -> [Event p r e]
asEventPts LineSegment 2 p r :+ e
s = [ Point 2 r -> EventType (LineSegment 2 p r :+ e) -> Event p r e
forall p r e.
Point 2 r -> EventType (LineSegment 2 p r :+ e) -> Event p r e
Event (LineSegment 2 p r :+ e
s(LineSegment 2 p r :+ e)
-> Getting (Point 2 r) (LineSegment 2 p r :+ e) (Point 2 r)
-> Point 2 r
forall s a. s -> Getting a s a -> a
^.(LineSegment 2 p r -> Const (Point 2 r) (LineSegment 2 p r))
-> (LineSegment 2 p r :+ e)
-> Const (Point 2 r) (LineSegment 2 p r :+ e)
forall core extra core'.
Lens (core :+ extra) (core' :+ extra) core core'
core((LineSegment 2 p r -> Const (Point 2 r) (LineSegment 2 p r))
-> (LineSegment 2 p r :+ e)
-> Const (Point 2 r) (LineSegment 2 p r :+ e))
-> ((Point 2 r -> Const (Point 2 r) (Point 2 r))
-> LineSegment 2 p r -> Const (Point 2 r) (LineSegment 2 p r))
-> Getting (Point 2 r) (LineSegment 2 p r :+ e) (Point 2 r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.((Point 2 r :+ p) -> Const (Point 2 r) (Point 2 r :+ p))
-> LineSegment 2 p r -> Const (Point 2 r) (LineSegment 2 p r)
forall t. HasStart t => Lens' t (StartCore t :+ StartExtra t)
start(((Point 2 r :+ p) -> Const (Point 2 r) (Point 2 r :+ p))
-> LineSegment 2 p r -> Const (Point 2 r) (LineSegment 2 p r))
-> ((Point 2 r -> Const (Point 2 r) (Point 2 r))
-> (Point 2 r :+ p) -> Const (Point 2 r) (Point 2 r :+ p))
-> (Point 2 r -> Const (Point 2 r) (Point 2 r))
-> LineSegment 2 p r
-> Const (Point 2 r) (LineSegment 2 p r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Point 2 r -> Const (Point 2 r) (Point 2 r))
-> (Point 2 r :+ p) -> Const (Point 2 r) (Point 2 r :+ p)
forall core extra core'.
Lens (core :+ extra) (core' :+ extra) core core'
core) (NonEmpty (LineSegment 2 p r :+ e)
-> EventType (LineSegment 2 p r :+ e)
forall s. NonEmpty s -> EventType s
Start (NonEmpty (LineSegment 2 p r :+ e)
-> EventType (LineSegment 2 p r :+ e))
-> NonEmpty (LineSegment 2 p r :+ e)
-> EventType (LineSegment 2 p r :+ e)
forall a b. (a -> b) -> a -> b
$ LineSegment 2 p r :+ e
s (LineSegment 2 p r :+ e)
-> [LineSegment 2 p r :+ e] -> NonEmpty (LineSegment 2 p r :+ e)
forall a. a -> [a] -> NonEmpty a
:| [])
, Point 2 r -> EventType (LineSegment 2 p r :+ e) -> Event p r e
forall p r e.
Point 2 r -> EventType (LineSegment 2 p r :+ e) -> Event p r e
Event (LineSegment 2 p r :+ e
s(LineSegment 2 p r :+ e)
-> Getting (Point 2 r) (LineSegment 2 p r :+ e) (Point 2 r)
-> Point 2 r
forall s a. s -> Getting a s a -> a
^.(LineSegment 2 p r -> Const (Point 2 r) (LineSegment 2 p r))
-> (LineSegment 2 p r :+ e)
-> Const (Point 2 r) (LineSegment 2 p r :+ e)
forall core extra core'.
Lens (core :+ extra) (core' :+ extra) core core'
core((LineSegment 2 p r -> Const (Point 2 r) (LineSegment 2 p r))
-> (LineSegment 2 p r :+ e)
-> Const (Point 2 r) (LineSegment 2 p r :+ e))
-> ((Point 2 r -> Const (Point 2 r) (Point 2 r))
-> LineSegment 2 p r -> Const (Point 2 r) (LineSegment 2 p r))
-> Getting (Point 2 r) (LineSegment 2 p r :+ e) (Point 2 r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.((Point 2 r :+ p) -> Const (Point 2 r) (Point 2 r :+ p))
-> LineSegment 2 p r -> Const (Point 2 r) (LineSegment 2 p r)
forall t. HasEnd t => Lens' t (EndCore t :+ EndExtra t)
end(((Point 2 r :+ p) -> Const (Point 2 r) (Point 2 r :+ p))
-> LineSegment 2 p r -> Const (Point 2 r) (LineSegment 2 p r))
-> ((Point 2 r -> Const (Point 2 r) (Point 2 r))
-> (Point 2 r :+ p) -> Const (Point 2 r) (Point 2 r :+ p))
-> (Point 2 r -> Const (Point 2 r) (Point 2 r))
-> LineSegment 2 p r
-> Const (Point 2 r) (LineSegment 2 p r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Point 2 r -> Const (Point 2 r) (Point 2 r))
-> (Point 2 r :+ p) -> Const (Point 2 r) (Point 2 r :+ p)
forall core extra core'.
Lens (core :+ extra) (core' :+ extra) core core'
core) ((LineSegment 2 p r :+ e) -> EventType (LineSegment 2 p r :+ e)
forall s. s -> EventType s
End LineSegment 2 p r :+ e
s)
]
merge :: (Ord r, Fractional r) => [IntersectionPoint p r e] -> Intersections p r e
merge :: [IntersectionPoint p r e] -> Intersections p r e
merge = (IntersectionPoint p r e
-> Intersections p r e -> Intersections p r e)
-> Intersections p r e
-> [IntersectionPoint p r e]
-> Intersections p r e
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\(IntersectionPoint Point 2 r
p Associated p r e
a) -> (Associated p r e -> Associated p r e -> Associated p r e)
-> Point 2 r
-> Associated p r e
-> Intersections p r e
-> Intersections p r e
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
M.insertWith Associated p r e -> Associated p r e -> Associated p r e
forall a. Semigroup a => a -> a -> a
(<>) Point 2 r
p Associated p r e
a) Intersections p r e
forall k a. Map k a
M.empty
groupStarts :: Eq r => [Event p r e] -> [Event p r e]
groupStarts :: [Event p r e] -> [Event p r e]
groupStarts [] = []
groupStarts (Event Point 2 r
p (Start NonEmpty (LineSegment 2 p r :+ e)
s) : [Event p r e]
es) = Point 2 r -> EventType (LineSegment 2 p r :+ e) -> Event p r e
forall p r e.
Point 2 r -> EventType (LineSegment 2 p r :+ e) -> Event p r e
Event Point 2 r
p (NonEmpty (LineSegment 2 p r :+ e)
-> EventType (LineSegment 2 p r :+ e)
forall s. NonEmpty s -> EventType s
Start NonEmpty (LineSegment 2 p r :+ e)
ss) Event p r e -> [Event p r e] -> [Event p r e]
forall a. a -> [a] -> [a]
: [Event p r e] -> [Event p r e]
forall r p e. Eq r => [Event p r e] -> [Event p r e]
groupStarts [Event p r e]
rest
where
([Event p r e]
ss',[Event p r e]
rest) = (Event p r e -> Bool)
-> [Event p r e] -> ([Event p r e], [Event p r e])
forall a. (a -> Bool) -> [a] -> ([a], [a])
L.span Event p r e -> Bool
sameStart [Event p r e]
es
ss :: NonEmpty (LineSegment 2 p r :+ e)
ss = let (LineSegment 2 p r :+ e
x:|[LineSegment 2 p r :+ e]
xs) = NonEmpty (LineSegment 2 p r :+ e)
s
in LineSegment 2 p r :+ e
x (LineSegment 2 p r :+ e)
-> [LineSegment 2 p r :+ e] -> NonEmpty (LineSegment 2 p r :+ e)
forall a. a -> [a] -> NonEmpty a
:| ([LineSegment 2 p r :+ e]
xs [LineSegment 2 p r :+ e]
-> [LineSegment 2 p r :+ e] -> [LineSegment 2 p r :+ e]
forall a. [a] -> [a] -> [a]
++ (Event p r e -> [LineSegment 2 p r :+ e])
-> [Event p r e] -> [LineSegment 2 p r :+ e]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Event p r e -> [LineSegment 2 p r :+ e]
forall p r e. Event p r e -> [LineSegment 2 p r :+ e]
startSegs [Event p r e]
ss')
sameStart :: Event p r e -> Bool
sameStart (Event Point 2 r
q (Start NonEmpty (LineSegment 2 p r :+ e)
_)) = Point 2 r
p Point 2 r -> Point 2 r -> Bool
forall a. Eq a => a -> a -> Bool
== Point 2 r
q
sameStart Event p r e
_ = Bool
False
groupStarts (Event p r e
e : [Event p r e]
es) = Event p r e
e Event p r e -> [Event p r e] -> [Event p r e]
forall a. a -> [a] -> [a]
: [Event p r e] -> [Event p r e]
forall r p e. Eq r => [Event p r e] -> [Event p r e]
groupStarts [Event p r e]
es
data EventType s = Start !(NonEmpty s)| Intersection | End !s deriving (Int -> EventType s -> ShowS
[EventType s] -> ShowS
EventType s -> String
(Int -> EventType s -> ShowS)
-> (EventType s -> String)
-> ([EventType s] -> ShowS)
-> Show (EventType s)
forall s. Show s => Int -> EventType s -> ShowS
forall s. Show s => [EventType s] -> ShowS
forall s. Show s => EventType s -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [EventType s] -> ShowS
$cshowList :: forall s. Show s => [EventType s] -> ShowS
show :: EventType s -> String
$cshow :: forall s. Show s => EventType s -> String
showsPrec :: Int -> EventType s -> ShowS
$cshowsPrec :: forall s. Show s => Int -> EventType s -> ShowS
Show)
instance Eq (EventType s) where
EventType s
a == :: EventType s -> EventType s -> Bool
== EventType s
b = EventType s
a EventType s -> EventType s -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` EventType s
b Ordering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
== Ordering
EQ
instance Ord (EventType s) where
(Start NonEmpty s
_) compare :: EventType s -> EventType s -> Ordering
`compare` (Start NonEmpty s
_) = Ordering
EQ
(Start NonEmpty s
_) `compare` EventType s
_ = Ordering
LT
EventType s
Intersection `compare` (Start NonEmpty s
_) = Ordering
GT
EventType s
Intersection `compare` EventType s
Intersection = Ordering
EQ
EventType s
Intersection `compare` (End s
_) = Ordering
LT
(End s
_) `compare` (End s
_) = Ordering
EQ
(End s
_) `compare` EventType s
_ = Ordering
GT
data Event p r e = Event { Event p r e -> Point 2 r
eventPoint :: !(Point 2 r)
, Event p r e -> EventType (LineSegment 2 p r :+ e)
eventType :: !(EventType (LineSegment 2 p r :+ e))
} deriving (Int -> Event p r e -> ShowS
[Event p r e] -> ShowS
Event p r e -> String
(Int -> Event p r e -> ShowS)
-> (Event p r e -> String)
-> ([Event p r e] -> ShowS)
-> Show (Event p r e)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall p r e.
(Show r, Show p, Show e) =>
Int -> Event p r e -> ShowS
forall p r e. (Show r, Show p, Show e) => [Event p r e] -> ShowS
forall p r e. (Show r, Show p, Show e) => Event p r e -> String
showList :: [Event p r e] -> ShowS
$cshowList :: forall p r e. (Show r, Show p, Show e) => [Event p r e] -> ShowS
show :: Event p r e -> String
$cshow :: forall p r e. (Show r, Show p, Show e) => Event p r e -> String
showsPrec :: Int -> Event p r e -> ShowS
$cshowsPrec :: forall p r e.
(Show r, Show p, Show e) =>
Int -> Event p r e -> ShowS
Show,Event p r e -> Event p r e -> Bool
(Event p r e -> Event p r e -> Bool)
-> (Event p r e -> Event p r e -> Bool) -> Eq (Event p r e)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall p r e. Eq r => Event p r e -> Event p r e -> Bool
/= :: Event p r e -> Event p r e -> Bool
$c/= :: forall p r e. Eq r => Event p r e -> Event p r e -> Bool
== :: Event p r e -> Event p r e -> Bool
$c== :: forall p r e. Eq r => Event p r e -> Event p r e -> Bool
Eq)
instance Ord r => Ord (Event p r e) where
(Event Point 2 r
p EventType (LineSegment 2 p r :+ e)
s) compare :: Event p r e -> Event p r e -> Ordering
`compare` (Event Point 2 r
q EventType (LineSegment 2 p r :+ e)
t) = case Point 2 r -> Point 2 r -> Ordering
forall r. Ord r => Point 2 r -> Point 2 r -> Ordering
ordPoints Point 2 r
p Point 2 r
q of
Ordering
EQ -> EventType (LineSegment 2 p r :+ e)
s EventType (LineSegment 2 p r :+ e)
-> EventType (LineSegment 2 p r :+ e) -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` EventType (LineSegment 2 p r :+ e)
t
Ordering
x -> Ordering
x
startSegs :: Event p r e -> [LineSegment 2 p r :+ e]
startSegs :: Event p r e -> [LineSegment 2 p r :+ e]
startSegs Event p r e
e = case Event p r e -> EventType (LineSegment 2 p r :+ e)
forall p r e. Event p r e -> EventType (LineSegment 2 p r :+ e)
eventType Event p r e
e of
Start NonEmpty (LineSegment 2 p r :+ e)
ss -> NonEmpty (LineSegment 2 p r :+ e) -> [LineSegment 2 p r :+ e]
forall a. NonEmpty a -> [a]
NonEmpty.toList NonEmpty (LineSegment 2 p r :+ e)
ss
EventType (LineSegment 2 p r :+ e)
_ -> []
type EventQueue p r e = EQ.Set (Event p r e)
type StatusStructure p r e = SS.Set (LineSegment 2 p r :+ e)
sweep :: (Ord r, Fractional r)
=> EventQueue p r e -> StatusStructure p r e -> [IntersectionPoint p r e]
sweep :: EventQueue p r e
-> StatusStructure p r e -> [IntersectionPoint p r e]
sweep EventQueue p r e
eq StatusStructure p r e
ss = case EventQueue p r e -> Maybe (Event p r e, EventQueue p r e)
forall a. Set a -> Maybe (a, Set a)
EQ.minView EventQueue p r e
eq of
Maybe (Event p r e, EventQueue p r e)
Nothing -> []
Just (Event p r e
e,EventQueue p r e
eq') -> Event p r e
-> EventQueue p r e
-> StatusStructure p r e
-> [IntersectionPoint p r e]
forall r p e.
(Ord r, Fractional r) =>
Event p r e
-> EventQueue p r e
-> StatusStructure p r e
-> [IntersectionPoint p r e]
handle Event p r e
e EventQueue p r e
eq' StatusStructure p r e
ss
handle :: forall r p e. (Ord r, Fractional r)
=> Event p r e -> EventQueue p r e -> StatusStructure p r e
-> [IntersectionPoint p r e]
handle :: Event p r e
-> EventQueue p r e
-> StatusStructure p r e
-> [IntersectionPoint p r e]
handle e :: Event p r e
e@(Event p r e -> Point 2 r
forall p r e. Event p r e -> Point 2 r
eventPoint -> Point 2 r
p) EventQueue p r e
eq StatusStructure p r e
ss = [IntersectionPoint p r e]
toReport [IntersectionPoint p r e]
-> [IntersectionPoint p r e] -> [IntersectionPoint p r e]
forall a. Semigroup a => a -> a -> a
<> EventQueue p r e
-> StatusStructure p r e -> [IntersectionPoint p r e]
forall r p e.
(Ord r, Fractional r) =>
EventQueue p r e
-> StatusStructure p r e -> [IntersectionPoint p r e]
sweep EventQueue p r e
eq' StatusStructure p r e
ss'
where
starts :: [LineSegment 2 p r :+ e]
starts = Event p r e -> [LineSegment 2 p r :+ e]
forall p r e. Event p r e -> [LineSegment 2 p r :+ e]
startSegs Event p r e
e
(StatusStructure p r e
before,[LineSegment 2 p r :+ e]
contains',StatusStructure p r e
after) = Point 2 r
-> StatusStructure p r e
-> (StatusStructure p r e, [LineSegment 2 p r :+ e],
StatusStructure p r e)
forall r p e.
(Fractional r, Ord r) =>
Point 2 r
-> StatusStructure p r e
-> (StatusStructure p r e, [LineSegment 2 p r :+ e],
StatusStructure p r e)
extractContains Point 2 r
p StatusStructure p r e
ss
([LineSegment 2 p r :+ e]
ends,[LineSegment 2 p r :+ e]
contains) = ((LineSegment 2 p r :+ e) -> Bool)
-> [LineSegment 2 p r :+ e]
-> ([LineSegment 2 p r :+ e], [LineSegment 2 p r :+ e])
forall a. (a -> Bool) -> [a] -> ([a], [a])
L.partition (Point 2 r -> (LineSegment 2 p r :+ e) -> Bool
forall r p e. Eq r => Point 2 r -> (LineSegment 2 p r :+ e) -> Bool
endsAt Point 2 r
p) [LineSegment 2 p r :+ e]
contains'
starts' :: [LineSegment 2 p r :+ e]
starts' = Point 2 r -> [LineSegment 2 p r :+ e] -> [LineSegment 2 p r :+ e]
forall r p e.
(Ord r, Num r) =>
Point 2 r -> [LineSegment 2 p r :+ e] -> [LineSegment 2 p r :+ e]
shouldReport Point 2 r
p ([LineSegment 2 p r :+ e] -> [LineSegment 2 p r :+ e])
-> [LineSegment 2 p r :+ e] -> [LineSegment 2 p r :+ e]
forall a b. (a -> b) -> a -> b
$ StatusStructure p r e -> [LineSegment 2 p r :+ e]
forall a. Set a -> [a]
SS.toAscList StatusStructure p r e
newSegs
pureContains :: [LineSegment 2 p r :+ e]
pureContains = ((LineSegment 2 p r :+ e) -> Bool)
-> [LineSegment 2 p r :+ e] -> [LineSegment 2 p r :+ e]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(LineSegment EndPoint (Point 2 r :+ p)
s EndPoint (Point 2 r :+ p)
_ :+ e
_) ->
Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ EndPoint (Point 2 r :+ p) -> Bool
forall a. EndPoint a -> Bool
isOpen EndPoint (Point 2 r :+ p)
s Bool -> Bool -> Bool
&& Point 2 r
p Point 2 r -> Point 2 r -> Bool
forall a. Eq a => a -> a -> Bool
== EndPoint (Point 2 r :+ p)
sEndPoint (Point 2 r :+ p)
-> Getting (Point 2 r) (EndPoint (Point 2 r :+ p)) (Point 2 r)
-> Point 2 r
forall s a. s -> Getting a s a -> a
^.((Point 2 r :+ p) -> Const (Point 2 r) (Point 2 r :+ p))
-> EndPoint (Point 2 r :+ p)
-> Const (Point 2 r) (EndPoint (Point 2 r :+ p))
forall a b. Lens (EndPoint a) (EndPoint b) a b
unEndPoint(((Point 2 r :+ p) -> Const (Point 2 r) (Point 2 r :+ p))
-> EndPoint (Point 2 r :+ p)
-> Const (Point 2 r) (EndPoint (Point 2 r :+ p)))
-> ((Point 2 r -> Const (Point 2 r) (Point 2 r))
-> (Point 2 r :+ p) -> Const (Point 2 r) (Point 2 r :+ p))
-> Getting (Point 2 r) (EndPoint (Point 2 r :+ p)) (Point 2 r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Point 2 r -> Const (Point 2 r) (Point 2 r))
-> (Point 2 r :+ p) -> Const (Point 2 r) (Point 2 r :+ p)
forall core extra core'.
Lens (core :+ extra) (core' :+ extra) core core'
core) [LineSegment 2 p r :+ e]
contains
closedEnds :: [LineSegment 2 p r :+ e]
closedEnds = ((LineSegment 2 p r :+ e) -> Bool)
-> [LineSegment 2 p r :+ e] -> [LineSegment 2 p r :+ e]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(LineSegment EndPoint (Point 2 r :+ p)
_ EndPoint (Point 2 r :+ p)
e' :+ e
_) -> EndPoint (Point 2 r :+ p) -> Bool
forall a. EndPoint a -> Bool
isClosed EndPoint (Point 2 r :+ p)
e') [LineSegment 2 p r :+ e]
ends
toReport :: [IntersectionPoint p r e]
toReport = case [LineSegment 2 p r :+ e]
starts' [LineSegment 2 p r :+ e]
-> [LineSegment 2 p r :+ e] -> [LineSegment 2 p r :+ e]
forall a. Semigroup a => a -> a -> a
<> [LineSegment 2 p r :+ e]
closedEnds [LineSegment 2 p r :+ e]
-> [LineSegment 2 p r :+ e] -> [LineSegment 2 p r :+ e]
forall a. Semigroup a => a -> a -> a
<> [LineSegment 2 p r :+ e]
pureContains of
(LineSegment 2 p r :+ e
_:LineSegment 2 p r :+ e
_:[LineSegment 2 p r :+ e]
_) -> [Point 2 r
-> [LineSegment 2 p r :+ e]
-> [LineSegment 2 p r :+ e]
-> IntersectionPoint p r e
forall r p e.
(Ord r, Fractional r) =>
Point 2 r
-> [LineSegment 2 p r :+ e]
-> [LineSegment 2 p r :+ e]
-> IntersectionPoint p r e
mkIntersectionPoint Point 2 r
p ([LineSegment 2 p r :+ e]
starts' [LineSegment 2 p r :+ e]
-> [LineSegment 2 p r :+ e] -> [LineSegment 2 p r :+ e]
forall a. Semigroup a => a -> a -> a
<> [LineSegment 2 p r :+ e]
closedEnds) [LineSegment 2 p r :+ e]
pureContains]
[LineSegment 2 p r :+ e]
_ -> []
ss' :: StatusStructure p r e
ss' = StatusStructure p r e
before StatusStructure p r e
-> StatusStructure p r e -> StatusStructure p r e
forall a. Set a -> Set a -> Set a
`SS.join` StatusStructure p r e
newSegs StatusStructure p r e
-> StatusStructure p r e -> StatusStructure p r e
forall a. Set a -> Set a -> Set a
`SS.join` StatusStructure p r e
after
newSegs :: StatusStructure p r e
newSegs = Point 2 r -> [LineSegment 2 p r :+ e] -> StatusStructure p r e
forall r p e.
(Fractional r, Ord r) =>
Point 2 r -> [LineSegment 2 p r :+ e] -> StatusStructure p r e
toStatusStruct Point 2 r
p ([LineSegment 2 p r :+ e] -> StatusStructure p r e)
-> [LineSegment 2 p r :+ e] -> StatusStructure p r e
forall a b. (a -> b) -> a -> b
$ [LineSegment 2 p r :+ e]
starts [LineSegment 2 p r :+ e]
-> [LineSegment 2 p r :+ e] -> [LineSegment 2 p r :+ e]
forall a. [a] -> [a] -> [a]
++ [LineSegment 2 p r :+ e]
contains
eq' :: EventQueue p r e
eq' = (Event p r e -> EventQueue p r e -> EventQueue p r e)
-> EventQueue p r e -> [Event p r e] -> EventQueue p r e
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Event p r e -> EventQueue p r e -> EventQueue p r e
forall a. Ord a => a -> Set a -> Set a
EQ.insert EventQueue p r e
eq [Event p r e]
es
es :: [Event p r e]
es | StatusStructure p r e -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
F.null StatusStructure p r e
newSegs = Maybe (Event p r e) -> [Event p r e]
forall a. Maybe a -> [a]
maybeToList (Maybe (Event p r e) -> [Event p r e])
-> Maybe (Event p r e) -> [Event p r e]
forall a b. (a -> b) -> a -> b
$ ((LineSegment 2 p r :+ e)
-> (LineSegment 2 p r :+ e) -> Maybe (Event p r e))
-> Maybe (LineSegment 2 p r :+ e)
-> Maybe (LineSegment 2 p r :+ e)
-> Maybe (Event p r e)
forall (m :: * -> *) t t b.
Monad m =>
(t -> t -> m b) -> m t -> m t -> m b
app (Point 2 r
-> (LineSegment 2 p r :+ e)
-> (LineSegment 2 p r :+ e)
-> Maybe (Event p r e)
forall r p e.
(Ord r, Fractional r) =>
Point 2 r
-> (LineSegment 2 p r :+ e)
-> (LineSegment 2 p r :+ e)
-> Maybe (Event p r e)
findNewEvent Point 2 r
p) Maybe (LineSegment 2 p r :+ e)
sl Maybe (LineSegment 2 p r :+ e)
sr
| Bool
otherwise = let s' :: Maybe (LineSegment 2 p r :+ e)
s' = StatusStructure p r e -> Maybe (LineSegment 2 p r :+ e)
forall a. Set a -> Maybe a
SS.lookupMin StatusStructure p r e
newSegs
s'' :: Maybe (LineSegment 2 p r :+ e)
s'' = StatusStructure p r e -> Maybe (LineSegment 2 p r :+ e)
forall a. Set a -> Maybe a
SS.lookupMax StatusStructure p r e
newSegs
in [Maybe (Event p r e)] -> [Event p r e]
forall a. [Maybe a] -> [a]
catMaybes [ ((LineSegment 2 p r :+ e)
-> (LineSegment 2 p r :+ e) -> Maybe (Event p r e))
-> Maybe (LineSegment 2 p r :+ e)
-> Maybe (LineSegment 2 p r :+ e)
-> Maybe (Event p r e)
forall (m :: * -> *) t t b.
Monad m =>
(t -> t -> m b) -> m t -> m t -> m b
app (Point 2 r
-> (LineSegment 2 p r :+ e)
-> (LineSegment 2 p r :+ e)
-> Maybe (Event p r e)
forall r p e.
(Ord r, Fractional r) =>
Point 2 r
-> (LineSegment 2 p r :+ e)
-> (LineSegment 2 p r :+ e)
-> Maybe (Event p r e)
findNewEvent Point 2 r
p) Maybe (LineSegment 2 p r :+ e)
sl Maybe (LineSegment 2 p r :+ e)
s'
, ((LineSegment 2 p r :+ e)
-> (LineSegment 2 p r :+ e) -> Maybe (Event p r e))
-> Maybe (LineSegment 2 p r :+ e)
-> Maybe (LineSegment 2 p r :+ e)
-> Maybe (Event p r e)
forall (m :: * -> *) t t b.
Monad m =>
(t -> t -> m b) -> m t -> m t -> m b
app (Point 2 r
-> (LineSegment 2 p r :+ e)
-> (LineSegment 2 p r :+ e)
-> Maybe (Event p r e)
forall r p e.
(Ord r, Fractional r) =>
Point 2 r
-> (LineSegment 2 p r :+ e)
-> (LineSegment 2 p r :+ e)
-> Maybe (Event p r e)
findNewEvent Point 2 r
p) Maybe (LineSegment 2 p r :+ e)
s'' Maybe (LineSegment 2 p r :+ e)
sr
]
sl :: Maybe (LineSegment 2 p r :+ e)
sl = StatusStructure p r e -> Maybe (LineSegment 2 p r :+ e)
forall a. Set a -> Maybe a
SS.lookupMax StatusStructure p r e
before
sr :: Maybe (LineSegment 2 p r :+ e)
sr = StatusStructure p r e -> Maybe (LineSegment 2 p r :+ e)
forall a. Set a -> Maybe a
SS.lookupMin StatusStructure p r e
after
app :: (t -> t -> m b) -> m t -> m t -> m b
app t -> t -> m b
f m t
x m t
y = do { t
x' <- m t
x ; t
y' <- m t
y ; t -> t -> m b
f t
x' t
y'}
shouldReport :: (Ord r, Num r)
=> Point 2 r -> [LineSegment 2 p r :+ e] -> [LineSegment 2 p r :+ e]
shouldReport :: Point 2 r -> [LineSegment 2 p r :+ e] -> [LineSegment 2 p r :+ e]
shouldReport Point 2 r
_ = ((LineSegment 2 p r :+ e) -> Bool)
-> ((LineSegment 2 p r :+ e) -> (LineSegment 2 p r :+ e) -> Bool)
-> [LineSegment 2 p r :+ e]
-> [LineSegment 2 p r :+ e]
forall a. (a -> Bool) -> (a -> a -> Bool) -> [a] -> [a]
overlapsOr (\(LineSegment EndPoint (Point 2 r :+ p)
s EndPoint (Point 2 r :+ p)
_ :+ e
_) -> EndPoint (Point 2 r :+ p) -> Bool
forall a. EndPoint a -> Bool
isClosed EndPoint (Point 2 r :+ p)
s)
(\(LineSegment 2 p r
s :+ e
_) (LineSegment 2 p r
s2 :+ e
_) -> LineSegment 2 p r
s LineSegment 2 p r -> LineSegment 2 p r -> Bool
forall g h. HasIntersectionWith g h => g -> h -> Bool
`intersects` LineSegment 2 p r
s2)
extractContains :: (Fractional r, Ord r)
=> Point 2 r -> StatusStructure p r e
-> (StatusStructure p r e, [LineSegment 2 p r :+ e], StatusStructure p r e)
Point 2 r
p StatusStructure p r e
ss = (StatusStructure p r e
before, StatusStructure p r e -> [LineSegment 2 p r :+ e]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList StatusStructure p r e
mid1 [LineSegment 2 p r :+ e]
-> [LineSegment 2 p r :+ e] -> [LineSegment 2 p r :+ e]
forall a. Semigroup a => a -> a -> a
<> StatusStructure p r e -> [LineSegment 2 p r :+ e]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList StatusStructure p r e
mid2, StatusStructure p r e
after)
where
(StatusStructure p r e
before, StatusStructure p r e
mid1, StatusStructure p r e
after') = ((LineSegment 2 p r :+ e) -> r)
-> r
-> StatusStructure p r e
-> (StatusStructure p r e, StatusStructure p r e,
StatusStructure p r e)
forall b a.
Ord b =>
(a -> b) -> b -> Set a -> (Set a, Set a, Set a)
SS.splitOn (r -> (LineSegment 2 p r :+ e) -> r
forall r p extra.
(Fractional r, Ord r) =>
r -> (LineSegment 2 p r :+ extra) -> r
xCoordAt' (r -> (LineSegment 2 p r :+ e) -> r)
-> r -> (LineSegment 2 p r :+ e) -> r
forall a b. (a -> b) -> a -> b
$ Point 2 r
pPoint 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.
(2 <= d, Arity d, AsAPoint point) =>
Lens' (point d r) r
yCoord) (Point 2 r
pPoint 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) StatusStructure p r e
ss
(StatusStructure p r e
mid2, StatusStructure p r e
after) = ((LineSegment 2 p r :+ e) -> Bool)
-> StatusStructure p r e
-> (StatusStructure p r e, StatusStructure p r e)
forall a. (a -> Bool) -> Set a -> (Set a, Set a)
SS.spanAntitone (Point 2 r -> LineSegment 2 p r -> Bool
forall g h. HasIntersectionWith g h => g -> h -> Bool
intersects Point 2 r
p (LineSegment 2 p r -> Bool)
-> ((LineSegment 2 p r :+ e) -> LineSegment 2 p r)
-> (LineSegment 2 p r :+ e)
-> Bool
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) StatusStructure p r e
after'
xCoordAt' :: r -> (LineSegment 2 p r :+ extra) -> r
xCoordAt' r
y LineSegment 2 p r :+ extra
sa = r -> LineSegment 2 p r -> r
forall r p. (Fractional r, Ord r) => r -> LineSegment 2 p r -> r
xCoordAt r
y (LineSegment 2 p r :+ extra
sa(LineSegment 2 p r :+ extra)
-> Getting
(LineSegment 2 p r)
(LineSegment 2 p r :+ extra)
(LineSegment 2 p r)
-> LineSegment 2 p r
forall s a. s -> Getting a s a -> a
^.Getting
(LineSegment 2 p r)
(LineSegment 2 p r :+ extra)
(LineSegment 2 p r)
forall core extra core'.
Lens (core :+ extra) (core' :+ extra) core core'
core)
toStatusStruct :: (Fractional r, Ord r)
=> Point 2 r -> [LineSegment 2 p r :+ e] -> StatusStructure p r e
toStatusStruct :: Point 2 r -> [LineSegment 2 p r :+ e] -> StatusStructure p r e
toStatusStruct Point 2 r
p [LineSegment 2 p r :+ e]
xs = StatusStructure p r e
ss StatusStructure p r e
-> StatusStructure p r e -> StatusStructure p r e
forall a. Set a -> Set a -> Set a
`SS.join` StatusStructure p r e
hors
where
([LineSegment 2 p r :+ e]
hors',[LineSegment 2 p r :+ e]
rest) = ((LineSegment 2 p r :+ e) -> Bool)
-> [LineSegment 2 p r :+ e]
-> ([LineSegment 2 p r :+ e], [LineSegment 2 p r :+ e])
forall a. (a -> Bool) -> [a] -> ([a], [a])
L.partition (LineSegment 2 p r :+ e) -> Bool
forall (d :: Nat) (d :: Nat) core' a (point :: Nat -> * -> *)
(point :: Nat -> * -> *) extra.
(ImplicitPeano (Peano d), ImplicitPeano (Peano d), HasEnd core',
Eq a, HasStart core', ArityPeano (Peano (FromPeano (Peano d))),
ArityPeano (Peano (FromPeano (Peano d))), KnownNat d,
KnownNat (FromPeano (Peano d)), KnownNat (FromPeano (Peano d)),
KnownNat d, AsAPoint point, AsAPoint point, (2 <=? d) ~ 'True,
(2 <=? d) ~ 'True,
Peano (FromPeano (Peano d) + 1) ~ 'S (Peano (FromPeano (Peano d))),
EndCore core' ~ point d a, StartCore core' ~ point d a,
Peano (FromPeano (Peano d) + 1)
~ 'S (Peano (FromPeano (Peano d)))) =>
(core' :+ extra) -> Bool
isHorizontal [LineSegment 2 p r :+ e]
xs
ss :: StatusStructure p r e
ss = ((LineSegment 2 p r :+ e) -> (LineSegment 2 p r :+ e) -> Ordering)
-> [LineSegment 2 p r :+ e] -> StatusStructure p r e
forall a. (a -> a -> Ordering) -> [a] -> Set a
SS.fromListBy (r
-> (LineSegment 2 p r :+ e) -> (LineSegment 2 p r :+ e) -> Ordering
forall r p extra extra.
(Fractional r, Ord r) =>
r
-> (LineSegment 2 p r :+ extra)
-> (LineSegment 2 p r :+ extra)
-> Ordering
ordAtY' (r
-> (LineSegment 2 p r :+ e)
-> (LineSegment 2 p r :+ e)
-> Ordering)
-> r
-> (LineSegment 2 p r :+ e)
-> (LineSegment 2 p r :+ e)
-> Ordering
forall a b. (a -> b) -> a -> b
$ [LineSegment 2 p r :+ e] -> r
maxY [LineSegment 2 p r :+ e]
xs) [LineSegment 2 p r :+ e]
rest
hors :: StatusStructure p r e
hors = ((LineSegment 2 p r :+ e) -> (LineSegment 2 p r :+ e) -> Ordering)
-> [LineSegment 2 p r :+ e] -> StatusStructure p r e
forall a. (a -> a -> Ordering) -> [a] -> Set a
SS.fromListBy (((LineSegment 2 p r :+ e) -> r)
-> (LineSegment 2 p r :+ e) -> (LineSegment 2 p r :+ e) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (LineSegment 2 p r :+ e) -> r
forall r p e. Ord r => (LineSegment 2 p r :+ e) -> r
rightEndpoint) [LineSegment 2 p r :+ e]
hors'
isHorizontal :: (core' :+ extra) -> Bool
isHorizontal core' :+ extra
s = core' :+ extra
s(core' :+ extra) -> Getting a (core' :+ extra) a -> a
forall s a. s -> Getting a s a -> a
^.(core' -> Const a core')
-> (core' :+ extra) -> Const a (core' :+ extra)
forall core extra core'.
Lens (core :+ extra) (core' :+ extra) core core'
core((core' -> Const a core')
-> (core' :+ extra) -> Const a (core' :+ extra))
-> ((a -> Const a a) -> core' -> Const a core')
-> Getting a (core' :+ extra) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
.((point d a :+ StartExtra core')
-> Const a (point d a :+ StartExtra core'))
-> core' -> Const a core'
forall t. HasStart t => Lens' t (StartCore t :+ StartExtra t)
start(((point d a :+ StartExtra core')
-> Const a (point d a :+ StartExtra core'))
-> core' -> Const a core')
-> ((a -> Const a a)
-> (point d a :+ StartExtra core')
-> Const a (point d a :+ StartExtra core'))
-> (a -> Const a a)
-> core'
-> Const a core'
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(point d a -> Const a (point d a))
-> (point d a :+ StartExtra core')
-> Const a (point d a :+ StartExtra core')
forall core extra core'.
Lens (core :+ extra) (core' :+ extra) core core'
core((point d a -> Const a (point d a))
-> (point d a :+ StartExtra core')
-> Const a (point d a :+ StartExtra core'))
-> ((a -> Const a a) -> point d a -> Const a (point d a))
-> (a -> Const a a)
-> (point d a :+ StartExtra core')
-> Const a (point d a :+ StartExtra 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.
(2 <= d, Arity d, AsAPoint point) =>
Lens' (point d r) r
yCoord a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== core' :+ extra
s(core' :+ extra) -> Getting a (core' :+ extra) a -> a
forall s a. s -> Getting a s a -> a
^.(core' -> Const a core')
-> (core' :+ extra) -> Const a (core' :+ extra)
forall core extra core'.
Lens (core :+ extra) (core' :+ extra) core core'
core((core' -> Const a core')
-> (core' :+ extra) -> Const a (core' :+ extra))
-> ((a -> Const a a) -> core' -> Const a core')
-> Getting a (core' :+ extra) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
.((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'))
-> (a -> Const a a)
-> core'
-> Const a core'
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.
(2 <= d, Arity d, AsAPoint point) =>
Lens' (point d r) r
yCoord
ordAtY' :: r
-> (LineSegment 2 p r :+ extra)
-> (LineSegment 2 p r :+ extra)
-> Ordering
ordAtY' r
q LineSegment 2 p r :+ extra
sa LineSegment 2 p r :+ extra
sb = r -> LineSegment 2 p r -> LineSegment 2 p r -> Ordering
forall r p.
(Fractional r, Ord r) =>
r -> LineSegment 2 p r -> LineSegment 2 p r -> Ordering
ordAtY r
q (LineSegment 2 p r :+ extra
sa(LineSegment 2 p r :+ extra)
-> Getting
(LineSegment 2 p r)
(LineSegment 2 p r :+ extra)
(LineSegment 2 p r)
-> LineSegment 2 p r
forall s a. s -> Getting a s a -> a
^.Getting
(LineSegment 2 p r)
(LineSegment 2 p r :+ extra)
(LineSegment 2 p r)
forall core extra core'.
Lens (core :+ extra) (core' :+ extra) core core'
core) (LineSegment 2 p r :+ extra
sb(LineSegment 2 p r :+ extra)
-> Getting
(LineSegment 2 p r)
(LineSegment 2 p r :+ extra)
(LineSegment 2 p r)
-> LineSegment 2 p r
forall s a. s -> Getting a s a -> a
^.Getting
(LineSegment 2 p r)
(LineSegment 2 p r :+ extra)
(LineSegment 2 p r)
forall core extra core'.
Lens (core :+ extra) (core' :+ extra) core core'
core)
maxY :: [LineSegment 2 p r :+ e] -> r
maxY = [r] -> r
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ([r] -> r)
-> ([LineSegment 2 p r :+ e] -> [r])
-> [LineSegment 2 p r :+ e]
-> r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (r -> Bool) -> [r] -> [r]
forall a. (a -> Bool) -> [a] -> [a]
filter (r -> r -> Bool
forall a. Ord a => a -> a -> Bool
< Point 2 r
pPoint 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.
(2 <= d, Arity d, AsAPoint point) =>
Lens' (point d r) r
yCoord)
([r] -> [r])
-> ([LineSegment 2 p r :+ e] -> [r])
-> [LineSegment 2 p r :+ e]
-> [r]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((LineSegment 2 p r :+ e) -> [r])
-> [LineSegment 2 p r :+ e] -> [r]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\LineSegment 2 p r :+ e
s -> [LineSegment 2 p r :+ e
s(LineSegment 2 p r :+ e)
-> Getting r (LineSegment 2 p r :+ e) r -> r
forall s a. s -> Getting a s a -> a
^.(LineSegment 2 p r -> Const r (LineSegment 2 p r))
-> (LineSegment 2 p r :+ e) -> Const r (LineSegment 2 p r :+ e)
forall core extra core'.
Lens (core :+ extra) (core' :+ extra) core core'
core((LineSegment 2 p r -> Const r (LineSegment 2 p r))
-> (LineSegment 2 p r :+ e) -> Const r (LineSegment 2 p r :+ e))
-> ((r -> Const r r)
-> LineSegment 2 p r -> Const r (LineSegment 2 p r))
-> Getting r (LineSegment 2 p r :+ e) r
forall b c a. (b -> c) -> (a -> b) -> a -> c
.((Point 2 r :+ p) -> Const r (Point 2 r :+ p))
-> LineSegment 2 p r -> Const r (LineSegment 2 p r)
forall t. HasStart t => Lens' t (StartCore t :+ StartExtra t)
start(((Point 2 r :+ p) -> Const r (Point 2 r :+ p))
-> LineSegment 2 p r -> Const r (LineSegment 2 p r))
-> ((r -> Const r r)
-> (Point 2 r :+ p) -> Const r (Point 2 r :+ p))
-> (r -> Const r r)
-> LineSegment 2 p r
-> Const r (LineSegment 2 p r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(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))
-> Getting r (Point 2 r) r
-> (r -> Const r r)
-> (Point 2 r :+ p)
-> Const r (Point 2 r :+ p)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Getting r (Point 2 r) r
forall (d :: Nat) (point :: Nat -> * -> *) r.
(2 <= d, Arity d, AsAPoint point) =>
Lens' (point d r) r
yCoord,LineSegment 2 p r :+ e
s(LineSegment 2 p r :+ e)
-> Getting r (LineSegment 2 p r :+ e) r -> r
forall s a. s -> Getting a s a -> a
^.(LineSegment 2 p r -> Const r (LineSegment 2 p r))
-> (LineSegment 2 p r :+ e) -> Const r (LineSegment 2 p r :+ e)
forall core extra core'.
Lens (core :+ extra) (core' :+ extra) core core'
core((LineSegment 2 p r -> Const r (LineSegment 2 p r))
-> (LineSegment 2 p r :+ e) -> Const r (LineSegment 2 p r :+ e))
-> ((r -> Const r r)
-> LineSegment 2 p r -> Const r (LineSegment 2 p r))
-> Getting r (LineSegment 2 p r :+ e) r
forall b c a. (b -> c) -> (a -> b) -> a -> c
.((Point 2 r :+ p) -> Const r (Point 2 r :+ p))
-> LineSegment 2 p r -> Const r (LineSegment 2 p r)
forall t. HasEnd t => Lens' t (EndCore t :+ EndExtra t)
end(((Point 2 r :+ p) -> Const r (Point 2 r :+ p))
-> LineSegment 2 p r -> Const r (LineSegment 2 p r))
-> ((r -> Const r r)
-> (Point 2 r :+ p) -> Const r (Point 2 r :+ p))
-> (r -> Const r r)
-> LineSegment 2 p r
-> Const r (LineSegment 2 p r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(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))
-> Getting r (Point 2 r) r
-> (r -> Const r r)
-> (Point 2 r :+ p)
-> Const r (Point 2 r :+ p)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Getting r (Point 2 r) r
forall (d :: Nat) (point :: Nat -> * -> *) r.
(2 <= d, Arity d, AsAPoint point) =>
Lens' (point d r) r
yCoord])
rightEndpoint :: Ord r => LineSegment 2 p r :+ e -> r
rightEndpoint :: (LineSegment 2 p r :+ e) -> r
rightEndpoint LineSegment 2 p r :+ e
s = (LineSegment 2 p r :+ e
s(LineSegment 2 p r :+ e)
-> Getting r (LineSegment 2 p r :+ e) r -> r
forall s a. s -> Getting a s a -> a
^.(LineSegment 2 p r -> Const r (LineSegment 2 p r))
-> (LineSegment 2 p r :+ e) -> Const r (LineSegment 2 p r :+ e)
forall core extra core'.
Lens (core :+ extra) (core' :+ extra) core core'
core((LineSegment 2 p r -> Const r (LineSegment 2 p r))
-> (LineSegment 2 p r :+ e) -> Const r (LineSegment 2 p r :+ e))
-> ((r -> Const r r)
-> LineSegment 2 p r -> Const r (LineSegment 2 p r))
-> Getting r (LineSegment 2 p r :+ e) r
forall b c a. (b -> c) -> (a -> b) -> a -> c
.((Point 2 r :+ p) -> Const r (Point 2 r :+ p))
-> LineSegment 2 p r -> Const r (LineSegment 2 p r)
forall t. HasStart t => Lens' t (StartCore t :+ StartExtra t)
start(((Point 2 r :+ p) -> Const r (Point 2 r :+ p))
-> LineSegment 2 p r -> Const r (LineSegment 2 p r))
-> ((r -> Const r r)
-> (Point 2 r :+ p) -> Const r (Point 2 r :+ p))
-> (r -> Const r r)
-> LineSegment 2 p r
-> Const r (LineSegment 2 p r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(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))
-> (r -> Const r r)
-> (Point 2 r :+ p)
-> Const r (Point 2 r :+ p)
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 -> r -> r
forall a. Ord a => a -> a -> a
`max` (LineSegment 2 p r :+ e
s(LineSegment 2 p r :+ e)
-> Getting r (LineSegment 2 p r :+ e) r -> r
forall s a. s -> Getting a s a -> a
^.(LineSegment 2 p r -> Const r (LineSegment 2 p r))
-> (LineSegment 2 p r :+ e) -> Const r (LineSegment 2 p r :+ e)
forall core extra core'.
Lens (core :+ extra) (core' :+ extra) core core'
core((LineSegment 2 p r -> Const r (LineSegment 2 p r))
-> (LineSegment 2 p r :+ e) -> Const r (LineSegment 2 p r :+ e))
-> ((r -> Const r r)
-> LineSegment 2 p r -> Const r (LineSegment 2 p r))
-> Getting r (LineSegment 2 p r :+ e) r
forall b c a. (b -> c) -> (a -> b) -> a -> c
.((Point 2 r :+ p) -> Const r (Point 2 r :+ p))
-> LineSegment 2 p r -> Const r (LineSegment 2 p r)
forall t. HasEnd t => Lens' t (EndCore t :+ EndExtra t)
end(((Point 2 r :+ p) -> Const r (Point 2 r :+ p))
-> LineSegment 2 p r -> Const r (LineSegment 2 p r))
-> ((r -> Const r r)
-> (Point 2 r :+ p) -> Const r (Point 2 r :+ p))
-> (r -> Const r r)
-> LineSegment 2 p r
-> Const r (LineSegment 2 p r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(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))
-> (r -> Const r r)
-> (Point 2 r :+ p)
-> Const r (Point 2 r :+ p)
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)
endsAt :: Eq r => Point 2 r -> LineSegment 2 p r :+ e -> Bool
endsAt :: Point 2 r -> (LineSegment 2 p r :+ e) -> Bool
endsAt Point 2 r
p (LineSegment' Point 2 r :+ p
_ (Point 2 r
b :+ p
_) :+ e
_) = Point 2 r
p Point 2 r -> Point 2 r -> Bool
forall a. Eq a => a -> a -> Bool
== Point 2 r
b
findNewEvent :: (Ord r, Fractional r)
=> Point 2 r -> LineSegment 2 p r :+ e -> LineSegment 2 p r :+ e
-> Maybe (Event p r e)
findNewEvent :: Point 2 r
-> (LineSegment 2 p r :+ e)
-> (LineSegment 2 p r :+ e)
-> Maybe (Event p r e)
findNewEvent Point 2 r
p LineSegment 2 p r :+ e
l LineSegment 2 p r :+ e
r = CoRec
Identity '[NoIntersection, Point 2 r, LineSegment 2 (Either p p) r]
-> Handlers
'[NoIntersection, Point 2 r, LineSegment 2 (Either p p) r]
(Maybe (Event p r e))
-> Maybe (Event p r e)
forall (ts :: [*]) b. CoRec Identity ts -> Handlers ts b -> b
match ((LineSegment 2 p r :+ e
l(LineSegment 2 p r :+ e)
-> Getting
(LineSegment 2 p r) (LineSegment 2 p r :+ e) (LineSegment 2 p r)
-> LineSegment 2 p r
forall s a. s -> Getting a s a -> a
^.Getting
(LineSegment 2 p r) (LineSegment 2 p r :+ e) (LineSegment 2 p r)
forall core extra core'.
Lens (core :+ extra) (core' :+ extra) core core'
core) LineSegment 2 p r
-> LineSegment 2 p r
-> Intersection (LineSegment 2 p r) (LineSegment 2 p r)
forall g h. IsIntersectableWith g h => g -> h -> Intersection g h
`intersect` (LineSegment 2 p r :+ e
r(LineSegment 2 p r :+ e)
-> Getting
(LineSegment 2 p r) (LineSegment 2 p r :+ e) (LineSegment 2 p r)
-> LineSegment 2 p r
forall s a. s -> Getting a s a -> a
^.Getting
(LineSegment 2 p r) (LineSegment 2 p r :+ e) (LineSegment 2 p r)
forall core extra core'.
Lens (core :+ extra) (core' :+ extra) core core'
core)) (Handlers
'[NoIntersection, Point 2 r, LineSegment 2 (Either p p) r]
(Maybe (Event p r e))
-> Maybe (Event p r e))
-> Handlers
'[NoIntersection, Point 2 r, LineSegment 2 (Either p p) r]
(Maybe (Event p r e))
-> Maybe (Event p r e)
forall a b. (a -> b) -> a -> b
$
(NoIntersection -> Maybe (Event p r e))
-> Handler (Maybe (Event p r e)) NoIntersection
forall b a. (a -> b) -> Handler b a
H (Maybe (Event p r e) -> NoIntersection -> Maybe (Event p r e)
forall a b. a -> b -> a
const Maybe (Event p r e)
forall a. Maybe a
Nothing)
Handler (Maybe (Event p r e)) NoIntersection
-> Rec
(Handler (Maybe (Event p r e)))
'[Point 2 r, LineSegment 2 (Either p p) r]
-> Handlers
'[NoIntersection, Point 2 r, LineSegment 2 (Either p p) r]
(Maybe (Event p r e))
forall u (a :: u -> *) (r :: u) (rs :: [u]).
a r -> Rec a rs -> Rec a (r : rs)
:& (Point 2 r -> Maybe (Event p r e))
-> Handler (Maybe (Event p r e)) (Point 2 r)
forall b a. (a -> b) -> Handler b a
H (\Point 2 r
q -> if Point 2 r -> Point 2 r -> Ordering
forall r. Ord r => Point 2 r -> Point 2 r -> Ordering
ordPoints Point 2 r
q Point 2 r
p Ordering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
== Ordering
GT then Event p r e -> Maybe (Event p r e)
forall a. a -> Maybe a
Just (Point 2 r -> EventType (LineSegment 2 p r :+ e) -> Event p r e
forall p r e.
Point 2 r -> EventType (LineSegment 2 p r :+ e) -> Event p r e
Event Point 2 r
q EventType (LineSegment 2 p r :+ e)
forall s. EventType s
Intersection)
else Maybe (Event p r e)
forall a. Maybe a
Nothing)
Handler (Maybe (Event p r e)) (Point 2 r)
-> Rec
(Handler (Maybe (Event p r e))) '[LineSegment 2 (Either p p) r]
-> Rec
(Handler (Maybe (Event p r e)))
'[Point 2 r, LineSegment 2 (Either p p) r]
forall u (a :: u -> *) (r :: u) (rs :: [u]).
a r -> Rec a rs -> Rec a (r : rs)
:& (LineSegment 2 (Either p p) r -> Maybe (Event p r e))
-> Handler (Maybe (Event p r e)) (LineSegment 2 (Either p p) r)
forall b a. (a -> b) -> Handler b a
H (Maybe (Event p r e)
-> LineSegment 2 (Either p p) r -> Maybe (Event p r e)
forall a b. a -> b -> a
const Maybe (Event p r e)
forall a. Maybe a
Nothing)
Handler (Maybe (Event p r e)) (LineSegment 2 (Either p p) r)
-> Rec (Handler (Maybe (Event p r e))) '[]
-> Rec
(Handler (Maybe (Event p r e))) '[LineSegment 2 (Either p p) r]
forall u (a :: u -> *) (r :: u) (rs :: [u]).
a r -> Rec a rs -> Rec a (r : rs)
:& Rec (Handler (Maybe (Event p r e))) '[]
forall u (a :: u -> *). Rec a '[]
RNil
type R = Rational
seg1, seg2 :: LineSegment 2 () R
seg1 :: LineSegment 2 () R
seg1 = (Point 2 R :+ ()) -> (Point 2 R :+ ()) -> LineSegment 2 () R
forall (d :: Nat) r p.
(Point d r :+ p) -> (Point d r :+ p) -> LineSegment d p r
ClosedLineSegment (Point 2 R -> Point 2 R :+ ()
forall a. a -> a :+ ()
ext (Point 2 R -> Point 2 R :+ ()) -> Point 2 R -> Point 2 R :+ ()
forall a b. (a -> b) -> a -> b
$ R -> R -> Point 2 R
forall r. r -> r -> Point 2 r
Point2 R
0 R
0) (Point 2 R -> Point 2 R :+ ()
forall a. a -> a :+ ()
ext (Point 2 R -> Point 2 R :+ ()) -> Point 2 R -> Point 2 R :+ ()
forall a b. (a -> b) -> a -> b
$ R -> R -> Point 2 R
forall r. r -> r -> Point 2 r
Point2 R
0 R
10)
seg2 :: LineSegment 2 () R
seg2 = (Point 2 R :+ ()) -> (Point 2 R :+ ()) -> LineSegment 2 () R
forall (d :: Nat) r p.
(Point d r :+ p) -> (Point d r :+ p) -> LineSegment d p r
ClosedLineSegment (Point 2 R -> Point 2 R :+ ()
forall a. a -> a :+ ()
ext (Point 2 R -> Point 2 R :+ ()) -> Point 2 R -> Point 2 R :+ ()
forall a b. (a -> b) -> a -> b
$ R -> R -> Point 2 R
forall r. r -> r -> Point 2 r
Point2 R
0 R
1) (Point 2 R -> Point 2 R :+ ()
forall a. a -> a :+ ()
ext (Point 2 R -> Point 2 R :+ ()) -> Point 2 R -> Point 2 R :+ ()
forall a b. (a -> b) -> a -> b
$ R -> R -> Point 2 R
forall r. r -> r -> Point 2 r
Point2 R
0 R
5)
overlapsOr :: (a -> Bool)
-> (a -> a -> Bool)
-> [a]
-> [a]
overlapsOr :: (a -> Bool) -> (a -> a -> Bool) -> [a] -> [a]
overlapsOr a -> Bool
p a -> a -> Bool
q = ((a, Bool) -> a) -> [(a, Bool)] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map (a, Bool) -> a
forall a b. (a, b) -> a
fst ([(a, Bool)] -> [a]) -> ([a] -> [(a, Bool)]) -> [a] -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((a, Bool) -> Bool) -> [(a, Bool)] -> [(a, Bool)]
forall a. (a -> Bool) -> [a] -> [a]
filter (a, Bool) -> Bool
forall a b. (a, b) -> b
snd ([(a, Bool)] -> [(a, Bool)])
-> ([a] -> [(a, Bool)]) -> [a] -> [(a, Bool)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (((a, Bool), Bool) -> (a, Bool))
-> [((a, Bool), Bool)] -> [(a, Bool)]
forall a b. (a -> b) -> [a] -> [b]
map (\((a
a,Bool
b),Bool
b') -> (a
a, Bool
b Bool -> Bool -> Bool
|| Bool
b'))
([((a, Bool), Bool)] -> [(a, Bool)])
-> ([a] -> [((a, Bool), Bool)]) -> [a] -> [(a, Bool)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((a, Bool) -> (a, Bool) -> Bool)
-> [(a, Bool)] -> [((a, Bool), Bool)]
forall a. (a -> a -> Bool) -> [a] -> [(a, Bool)]
overlapsWithNeighbour (a -> a -> Bool
q (a -> a -> Bool)
-> ((a, Bool) -> a) -> (a, Bool) -> (a, Bool) -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (a, Bool) -> a
forall a b. (a, b) -> a
fst)
([(a, Bool)] -> [((a, Bool), Bool)])
-> ([a] -> [(a, Bool)]) -> [a] -> [((a, Bool), Bool)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> (a, Bool)) -> [a] -> [(a, Bool)]
forall a b. (a -> b) -> [a] -> [b]
map (\a
x -> (a
x, a -> Bool
p a
x))
overlapsWithNeighbour :: (a -> a -> Bool) -> [a] -> [(a,Bool)]
overlapsWithNeighbour :: (a -> a -> Bool) -> [a] -> [(a, Bool)]
overlapsWithNeighbour a -> a -> Bool
p = [a] -> [(a, Bool)]
go0
where
go0 :: [a] -> [(a, Bool)]
go0 = \case
[] -> []
(a
x:[a]
xs) -> a -> Bool -> [a] -> [(a, Bool)]
go a
x Bool
False [a]
xs
go :: a -> Bool -> [a] -> [(a, Bool)]
go a
x Bool
b = \case
[] -> []
(a
y:[a]
ys) -> let b' :: Bool
b' = a -> a -> Bool
p a
x a
y
in (a
x,Bool
b Bool -> Bool -> Bool
|| Bool
b') (a, Bool) -> [(a, Bool)] -> [(a, Bool)]
forall a. a -> [a] -> [a]
: a -> Bool -> [a] -> [(a, Bool)]
go a
y Bool
b' [a]
ys
overlapsWithNext' :: (a -> a -> Bool) -> [a] -> [(a,Bool)]
overlapsWithNext' :: (a -> a -> Bool) -> [a] -> [(a, Bool)]
overlapsWithNext' a -> a -> Bool
p = [a] -> [(a, Bool)]
go
where
go :: [a] -> [(a, Bool)]
go = \case
[] -> []
[a
x] -> [(a
x,Bool
False)]
(a
x:xs :: [a]
xs@(a
y:[a]
_)) -> (a
x,a -> a -> Bool
p a
x a
y) (a, Bool) -> [(a, Bool)] -> [(a, Bool)]
forall a. a -> [a] -> [a]
: [a] -> [(a, Bool)]
go [a]
xs
overlapsWithPrev' :: (a -> a -> Bool) -> [a] -> [(a,Bool)]
overlapsWithPrev' :: (a -> a -> Bool) -> [a] -> [(a, Bool)]
overlapsWithPrev' a -> a -> Bool
p = [a] -> [(a, Bool)]
go0
where
go0 :: [a] -> [(a, Bool)]
go0 = \case
[] -> []
(a
x:[a]
xs) -> (a
x,Bool
False) (a, Bool) -> [(a, Bool)] -> [(a, Bool)]
forall a. a -> [a] -> [a]
: a -> [a] -> [(a, Bool)]
go a
x [a]
xs
go :: a -> [a] -> [(a, Bool)]
go a
x = \case
[] -> []
(a
y:[a]
ys) -> (a
y,a -> a -> Bool
p a
x a
y) (a, Bool) -> [(a, Bool)] -> [(a, Bool)]
forall a. a -> [a] -> [a]
: a -> [a] -> [(a, Bool)]
go a
y [a]
ys
overlapsWithNeighbour2 :: (a -> a -> Bool) -> [a] -> [(a, Bool)]
overlapsWithNeighbour2 a -> a -> Bool
p = (((a, Bool), Bool) -> (a, Bool))
-> [((a, Bool), Bool)] -> [(a, Bool)]
forall a b. (a -> b) -> [a] -> [b]
map (\((a
a,Bool
b),Bool
b') -> (a
a, Bool
b Bool -> Bool -> Bool
|| Bool
b'))
([((a, Bool), Bool)] -> [(a, Bool)])
-> ([a] -> [((a, Bool), Bool)]) -> [a] -> [(a, Bool)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((a, Bool) -> (a, Bool) -> Bool)
-> [(a, Bool)] -> [((a, Bool), Bool)]
forall a. (a -> a -> Bool) -> [a] -> [(a, Bool)]
overlapsWithNext' (a -> a -> Bool
p (a -> a -> Bool)
-> ((a, Bool) -> a) -> (a, Bool) -> (a, Bool) -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (a, Bool) -> a
forall a b. (a, b) -> a
fst)
([(a, Bool)] -> [((a, Bool), Bool)])
-> ([a] -> [(a, Bool)]) -> [a] -> [((a, Bool), Bool)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> a -> Bool) -> [a] -> [(a, Bool)]
forall a. (a -> a -> Bool) -> [a] -> [(a, Bool)]
overlapsWithPrev' a -> a -> Bool
p
shouldBe :: Eq a => a -> a -> Bool
shouldBe :: a -> a -> Bool
shouldBe = a -> a -> Bool
forall a. Eq a => a -> a -> Bool
(==)
propSameAsSeparate :: (a -> a -> Bool) -> [a] -> Bool
propSameAsSeparate a -> a -> Bool
p [a]
xs = (a -> a -> Bool) -> [a] -> [(a, Bool)]
forall a. (a -> a -> Bool) -> [a] -> [(a, Bool)]
overlapsWithNeighbour a -> a -> Bool
p [a]
xs [(a, Bool)] -> [(a, Bool)] -> Bool
forall a. Eq a => a -> a -> Bool
`shouldBe` (a -> a -> Bool) -> [a] -> [(a, Bool)]
forall a. (a -> a -> Bool) -> [a] -> [(a, Bool)]
overlapsWithNeighbour2 a -> a -> Bool
p [a]
xs
test' :: [(Integer, Bool)]
test' = (Integer -> Integer -> Bool) -> [Integer] -> [(Integer, Bool)]
forall a. (a -> a -> Bool) -> [a] -> [(a, Bool)]
overlapsWithNeighbour Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
(==) [Integer]
testOverlapNext
testOverlapNext :: [Integer]
testOverlapNext = [Integer
1,Integer
2,Integer
3,Integer
3,Integer
3,Integer
5,Integer
6,Integer
6,Integer
8,Integer
10,Integer
11,Integer
34,Integer
2,Integer
2,Integer
3]