{-# LANGUAGE ScopedTypeVariables #-}
--------------------------------------------------------------------------------
-- |
-- Module      :  Algorithms.Geometry.LineSegmentIntersection.BentleyOttmann
-- Copyright   :  (C) Frank Staals
-- License     :  see the LICENSE file
-- Maintainer  :  Frank Staals
--
-- The \(O((n+k)\log n)\) time line segment intersection algorithm by Bentley
-- and Ottmann.
--
--------------------------------------------------------------------------------
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 -- event queue
import qualified Data.Set as SS -- status struct
import qualified Data.Set as Set
import qualified Data.Set.Util as SS -- status struct
import           Data.Vinyl
import           Data.Vinyl.CoRec
--------------------------------------------------------------------------------

-- | Compute all intersections
--
-- \(O((n+k)\log n)\), where \(k\) is the number of intersections.
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

-- | Computes all intersection points p s.t. p lies in the interior of at least
-- one of the segments.
--
--  \(O((n+k)\log n)\), where \(k\) is the number of intersections.
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

--------------------------------------------------------------------------------
-- * Flipping and unflipping

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)

-- | Make sure the 'start' endpoint occurs before the end-endpoints in
-- terms of the sweep order.
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)

-- | Flips the segment
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)

-- | Unflips the segments in an associated.
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

    -- | For segments that are not acutally flipped, we can just drop the flipped bit
    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)

    -- For flipped segs we unflip them (and appropriately coerce the
    -- so that they remain in the same order. I.e. if they were sorted
    -- around the start point they are now sorted around the endpoint.
    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

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

-- | Computes the event points for a given line segment
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)
               ]

-- | Group the segments with the intersection points
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

-- | Group the startpoints such that segments with the same start point
-- correspond to one event.
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
    -- FIXME: this seems to keep the segments on decreasing y, increasing x. shouldn't we
    -- sort them cyclically around p instead?
    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 type for Events

-- | Type of segment
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

-- | The actual event consists of a point and its type
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
  -- decreasing on the y-coord, then increasing on x-coord, and increasing on event-type
  (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

-- | Get the segments that start at the given event point
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)
_        -> []

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


--------------------------------------------------------------------------------
-- * The Main Sweep

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

-- | Run the sweep handling all events
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 an event point
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'
    -- starting segments, exluding those that have an open starting point
    -- starts' = filter (isClosedStart p) starts
    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

    -- If we just inserted open-ended segments that start here, then
    -- don't consider them to be "contained" segments.
    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

    -- any (closed) ending segments at this event point.
    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]
_       -> []

    -- new status structure
    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


    -- the new eeventqueue
    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
    -- the new events:
    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'}

-- | given the starting point p, and the segments that either start in
-- p, or continue in p, in left to right order along a line just
-- epsilon below p, figure out which segments we should report as
-- intersecting at p.
--
-- in partcular; those that:
-- - have a closed endpoint at p
-- - those that have an open endpoint at p and have an intersection
--   with a segment eps below p. Those segments thus overlap wtih
--   their predecessor or successor in the cyclic order.
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)

-- | split the status structure, extracting the segments that contain p.
-- the result is (before,contains,after)
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)
extractContains :: 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 = (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
    -- Make sure to also select the horizontal segments containing p
    (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)

-- | Given a point and the linesegements that contain it. Create a piece of
-- status structure for it.
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
  -- ss { SS.nav = ordAtNav $ p^.yCoord } `SS.join` 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)

    -- find the y coord of the first interesting thing below the sweep at y
    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])

-- | Get the right endpoint of a segment
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)

-- | Test if a segment ends at p
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
  -- all (\q -> ordPoints (q^.core) p /= GT) [a,b]

--------------------------------------------------------------------------------
-- * Finding New events

-- | Find all events
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) -- NoIntersection
  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) -- full segment intersectsions are handled
                       -- at insertion time
  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)



--------------------------------------------------------------------------------
-- *

-- | Given a predicate p on elements, and a predicate q on
-- (neighbouring) pairs of elements, filter the elements that satisfy
-- p, or together with one of their neighbours satisfy q.
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))

-- | Given a predicate, test and a list, annotate each element whether
-- it, together with one of its neighbors satisifies the predicate.
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

-- annotateReport   :: (a -> Bool) -> [a] -> [(a,Bool)]
-- annotateReport p = map (\x -> (x, p x))

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]