{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE TemplateHaskell #-}
--------------------------------------------------------------------------------
-- |
-- Module      :  HGeometry.LineSegment.Intersection.Types
-- Copyright   :  (C) Frank Staals
-- License     :  see the LICENSE file
-- Maintainer  :  Frank Staals
--
-- Types for line segment intersections
--
--------------------------------------------------------------------------------
module HGeometry.LineSegment.Intersection.Types
  ( Intersections
  , intersectionPoints

  , Associated(Associated), startPointOf, endPointOf, interiorTo
  , mkAssociated
  , associatedSegments

  , AroundEnd(..), AroundStart(..), AroundIntersection(..)
  , isInteriorIntersection


  , IntersectionPoint
  , intersectionPointOf

  , intersectionPoint, associatedSegs
  , mkIntersectionPoint


  , IntersectConstraints
  , OrdArounds

  , ordPoints
  ) where

import           Control.DeepSeq
import           Control.Lens
import qualified Data.List as List
import qualified Data.Map as Map
import           Data.Ord (comparing, Down(..))
import qualified Data.Set as Set
import           GHC.Generics
import           HGeometry.Intersection
import           HGeometry.Interval
import           HGeometry.LineSegment
import           HGeometry.Point

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


-- FIXME: What do we do when one segment lies *on* the other one. For
-- the short segment it should be an "around start", but then the
-- startpoints do not match.
--
-- for the long one it's an "on" segment, but they do not intersect


-- | Assumes that two segments have the same start point
newtype AroundStart a = AroundStart a deriving (Int -> AroundStart a -> ShowS
[AroundStart a] -> ShowS
AroundStart a -> String
(Int -> AroundStart a -> ShowS)
-> (AroundStart a -> String)
-> ([AroundStart a] -> ShowS)
-> Show (AroundStart a)
forall a. Show a => Int -> AroundStart a -> ShowS
forall a. Show a => [AroundStart a] -> ShowS
forall a. Show a => AroundStart a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> AroundStart a -> ShowS
showsPrec :: Int -> AroundStart a -> ShowS
$cshow :: forall a. Show a => AroundStart a -> String
show :: AroundStart a -> String
$cshowList :: forall a. Show a => [AroundStart a] -> ShowS
showList :: [AroundStart a] -> ShowS
Show,ReadPrec [AroundStart a]
ReadPrec (AroundStart a)
Int -> ReadS (AroundStart a)
ReadS [AroundStart a]
(Int -> ReadS (AroundStart a))
-> ReadS [AroundStart a]
-> ReadPrec (AroundStart a)
-> ReadPrec [AroundStart a]
-> Read (AroundStart a)
forall a. Read a => ReadPrec [AroundStart a]
forall a. Read a => ReadPrec (AroundStart a)
forall a. Read a => Int -> ReadS (AroundStart a)
forall a. Read a => ReadS [AroundStart a]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: forall a. Read a => Int -> ReadS (AroundStart a)
readsPrec :: Int -> ReadS (AroundStart a)
$creadList :: forall a. Read a => ReadS [AroundStart a]
readList :: ReadS [AroundStart a]
$creadPrec :: forall a. Read a => ReadPrec (AroundStart a)
readPrec :: ReadPrec (AroundStart a)
$creadListPrec :: forall a. Read a => ReadPrec [AroundStart a]
readListPrec :: ReadPrec [AroundStart a]
Read,AroundStart a -> ()
(AroundStart a -> ()) -> NFData (AroundStart a)
forall a. NFData a => AroundStart a -> ()
forall a. (a -> ()) -> NFData a
$crnf :: forall a. NFData a => AroundStart a -> ()
rnf :: AroundStart a -> ()
NFData,(forall a b. (a -> b) -> AroundStart a -> AroundStart b)
-> (forall a b. a -> AroundStart b -> AroundStart a)
-> Functor AroundStart
forall a b. a -> AroundStart b -> AroundStart a
forall a b. (a -> b) -> AroundStart a -> AroundStart b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> AroundStart a -> AroundStart b
fmap :: forall a b. (a -> b) -> AroundStart a -> AroundStart b
$c<$ :: forall a b. a -> AroundStart b -> AroundStart a
<$ :: forall a b. a -> AroundStart b -> AroundStart a
Functor)

makeWrapped ''AroundStart

instance ( Point_ point 2 r, Eq r
         , HasEnd lineSegment point) => Eq (AroundStart lineSegment) where
  -- | equality on endpoint
  (AroundStart lineSegment
s) == :: AroundStart lineSegment -> AroundStart lineSegment -> Bool
== (AroundStart lineSegment
s') = lineSegment
slineSegment
-> Getting (Point 2 r) lineSegment (Point 2 r) -> Point 2 r
forall s a. s -> Getting a s a -> a
^.(point -> Const (Point 2 r) point)
-> lineSegment -> Const (Point 2 r) lineSegment
forall seg p. HasEnd seg p => Lens' seg p
Lens' lineSegment point
end((point -> Const (Point 2 r) point)
 -> lineSegment -> Const (Point 2 r) lineSegment)
-> ((Point 2 r -> Const (Point 2 r) (Point 2 r))
    -> point -> Const (Point 2 r) point)
-> Getting (Point 2 r) lineSegment (Point 2 r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Point 2 r -> Const (Point 2 r) (Point 2 r))
-> point -> Const (Point 2 r) point
forall point (d :: Nat) r.
Point_ point d r =>
Lens' point (Point d r)
Lens' point (Point 2 r)
asPoint Point 2 r -> Point 2 r -> Bool
forall a. Eq a => a -> a -> Bool
== lineSegment
s'lineSegment
-> Getting (Point 2 r) lineSegment (Point 2 r) -> Point 2 r
forall s a. s -> Getting a s a -> a
^.(point -> Const (Point 2 r) point)
-> lineSegment -> Const (Point 2 r) lineSegment
forall seg p. HasEnd seg p => Lens' seg p
Lens' lineSegment point
end((point -> Const (Point 2 r) point)
 -> lineSegment -> Const (Point 2 r) lineSegment)
-> ((Point 2 r -> Const (Point 2 r) (Point 2 r))
    -> point -> Const (Point 2 r) point)
-> Getting (Point 2 r) lineSegment (Point 2 r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Point 2 r -> Const (Point 2 r) (Point 2 r))
-> point -> Const (Point 2 r) point
forall point (d :: Nat) r.
Point_ point d r =>
Lens' point (Point d r)
Lens' point (Point 2 r)
asPoint

instance ( LineSegment_ lineSegment point
         , Point_ point 2 r
         , Ord r, Num r
         ) => Ord (AroundStart lineSegment) where
  -- | ccw ordered around their suposed common startpoint
  (AroundStart lineSegment
s) compare :: AroundStart lineSegment -> AroundStart lineSegment -> Ordering
`compare` (AroundStart lineSegment
s') = point -> point -> point -> Ordering
forall point r.
(Point_ point 2 r, Ord r, Num r) =>
point -> point -> point -> Ordering
ccwCmpAround (lineSegment
slineSegment -> Getting point lineSegment point -> point
forall s a. s -> Getting a s a -> a
^.Getting point lineSegment point
forall seg p. HasStart seg p => Lens' seg p
Lens' lineSegment point
start) (lineSegment
slineSegment -> Getting point lineSegment point -> point
forall s a. s -> Getting a s a -> a
^.Getting point lineSegment point
forall seg p. HasEnd seg p => Lens' seg p
Lens' lineSegment point
end)  (lineSegment
s'lineSegment -> Getting point lineSegment point -> point
forall s a. s -> Getting a s a -> a
^.Getting point lineSegment point
forall seg p. HasEnd seg p => Lens' seg p
Lens' lineSegment point
end)

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

-- | Assumes that two segments have the same end point
newtype AroundEnd a = AroundEnd a deriving (Int -> AroundEnd a -> ShowS
[AroundEnd a] -> ShowS
AroundEnd a -> String
(Int -> AroundEnd a -> ShowS)
-> (AroundEnd a -> String)
-> ([AroundEnd a] -> ShowS)
-> Show (AroundEnd a)
forall a. Show a => Int -> AroundEnd a -> ShowS
forall a. Show a => [AroundEnd a] -> ShowS
forall a. Show a => AroundEnd a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> AroundEnd a -> ShowS
showsPrec :: Int -> AroundEnd a -> ShowS
$cshow :: forall a. Show a => AroundEnd a -> String
show :: AroundEnd a -> String
$cshowList :: forall a. Show a => [AroundEnd a] -> ShowS
showList :: [AroundEnd a] -> ShowS
Show,ReadPrec [AroundEnd a]
ReadPrec (AroundEnd a)
Int -> ReadS (AroundEnd a)
ReadS [AroundEnd a]
(Int -> ReadS (AroundEnd a))
-> ReadS [AroundEnd a]
-> ReadPrec (AroundEnd a)
-> ReadPrec [AroundEnd a]
-> Read (AroundEnd a)
forall a. Read a => ReadPrec [AroundEnd a]
forall a. Read a => ReadPrec (AroundEnd a)
forall a. Read a => Int -> ReadS (AroundEnd a)
forall a. Read a => ReadS [AroundEnd a]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: forall a. Read a => Int -> ReadS (AroundEnd a)
readsPrec :: Int -> ReadS (AroundEnd a)
$creadList :: forall a. Read a => ReadS [AroundEnd a]
readList :: ReadS [AroundEnd a]
$creadPrec :: forall a. Read a => ReadPrec (AroundEnd a)
readPrec :: ReadPrec (AroundEnd a)
$creadListPrec :: forall a. Read a => ReadPrec [AroundEnd a]
readListPrec :: ReadPrec [AroundEnd a]
Read,AroundEnd a -> ()
(AroundEnd a -> ()) -> NFData (AroundEnd a)
forall a. NFData a => AroundEnd a -> ()
forall a. (a -> ()) -> NFData a
$crnf :: forall a. NFData a => AroundEnd a -> ()
rnf :: AroundEnd a -> ()
NFData,(forall a b. (a -> b) -> AroundEnd a -> AroundEnd b)
-> (forall a b. a -> AroundEnd b -> AroundEnd a)
-> Functor AroundEnd
forall a b. a -> AroundEnd b -> AroundEnd a
forall a b. (a -> b) -> AroundEnd a -> AroundEnd b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> AroundEnd a -> AroundEnd b
fmap :: forall a b. (a -> b) -> AroundEnd a -> AroundEnd b
$c<$ :: forall a b. a -> AroundEnd b -> AroundEnd a
<$ :: forall a b. a -> AroundEnd b -> AroundEnd a
Functor)

makeWrapped ''AroundEnd

instance (Point_ point 2 r, Eq r, HasStart lineSegment point) => Eq (AroundEnd lineSegment) where
  -- | equality on endpoint
  (AroundEnd lineSegment
s) == :: AroundEnd lineSegment -> AroundEnd lineSegment -> Bool
== (AroundEnd lineSegment
s') = lineSegment
slineSegment
-> Getting (Point 2 r) lineSegment (Point 2 r) -> Point 2 r
forall s a. s -> Getting a s a -> a
^.(point -> Const (Point 2 r) point)
-> lineSegment -> Const (Point 2 r) lineSegment
forall seg p. HasStart seg p => Lens' seg p
Lens' lineSegment point
start((point -> Const (Point 2 r) point)
 -> lineSegment -> Const (Point 2 r) lineSegment)
-> ((Point 2 r -> Const (Point 2 r) (Point 2 r))
    -> point -> Const (Point 2 r) point)
-> Getting (Point 2 r) lineSegment (Point 2 r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Point 2 r -> Const (Point 2 r) (Point 2 r))
-> point -> Const (Point 2 r) point
forall point (d :: Nat) r.
Point_ point d r =>
Lens' point (Point d r)
Lens' point (Point 2 r)
asPoint Point 2 r -> Point 2 r -> Bool
forall a. Eq a => a -> a -> Bool
== lineSegment
s'lineSegment
-> Getting (Point 2 r) lineSegment (Point 2 r) -> Point 2 r
forall s a. s -> Getting a s a -> a
^.(point -> Const (Point 2 r) point)
-> lineSegment -> Const (Point 2 r) lineSegment
forall seg p. HasStart seg p => Lens' seg p
Lens' lineSegment point
start((point -> Const (Point 2 r) point)
 -> lineSegment -> Const (Point 2 r) lineSegment)
-> ((Point 2 r -> Const (Point 2 r) (Point 2 r))
    -> point -> Const (Point 2 r) point)
-> Getting (Point 2 r) lineSegment (Point 2 r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Point 2 r -> Const (Point 2 r) (Point 2 r))
-> point -> Const (Point 2 r) point
forall point (d :: Nat) r.
Point_ point d r =>
Lens' point (Point d r)
Lens' point (Point 2 r)
asPoint

instance ( LineSegment_ lineSegment point
         , Point_ point 2 r
         , Ord r, Num r
         , Eq lineSegment
         ) => Ord (AroundEnd lineSegment) where
  -- | ccw ordered around their suposed common end point
  (AroundEnd lineSegment
s) compare :: AroundEnd lineSegment -> AroundEnd lineSegment -> Ordering
`compare` (AroundEnd lineSegment
s') = point -> point -> point -> Ordering
forall point r.
(Point_ point 2 r, Ord r, Num r) =>
point -> point -> point -> Ordering
ccwCmpAround (lineSegment
slineSegment -> Getting point lineSegment point -> point
forall s a. s -> Getting a s a -> a
^.Getting point lineSegment point
forall seg p. HasEnd seg p => Lens' seg p
Lens' lineSegment point
end) (lineSegment
slineSegment -> Getting point lineSegment point -> point
forall s a. s -> Getting a s a -> a
^.Getting point lineSegment point
forall seg p. HasStart seg p => Lens' seg p
Lens' lineSegment point
start) (lineSegment
s'lineSegment -> Getting point lineSegment point -> point
forall s a. s -> Getting a s a -> a
^.Getting point lineSegment point
forall seg p. HasStart seg p => Lens' seg p
Lens' lineSegment point
start)

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

-- | Assumes that two segments intersect in a single point.
newtype AroundIntersection a = AroundIntersection a deriving (AroundIntersection a -> AroundIntersection a -> Bool
(AroundIntersection a -> AroundIntersection a -> Bool)
-> (AroundIntersection a -> AroundIntersection a -> Bool)
-> Eq (AroundIntersection a)
forall a.
Eq a =>
AroundIntersection a -> AroundIntersection a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a.
Eq a =>
AroundIntersection a -> AroundIntersection a -> Bool
== :: AroundIntersection a -> AroundIntersection a -> Bool
$c/= :: forall a.
Eq a =>
AroundIntersection a -> AroundIntersection a -> Bool
/= :: AroundIntersection a -> AroundIntersection a -> Bool
Eq,Int -> AroundIntersection a -> ShowS
[AroundIntersection a] -> ShowS
AroundIntersection a -> String
(Int -> AroundIntersection a -> ShowS)
-> (AroundIntersection a -> String)
-> ([AroundIntersection a] -> ShowS)
-> Show (AroundIntersection a)
forall a. Show a => Int -> AroundIntersection a -> ShowS
forall a. Show a => [AroundIntersection a] -> ShowS
forall a. Show a => AroundIntersection a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> AroundIntersection a -> ShowS
showsPrec :: Int -> AroundIntersection a -> ShowS
$cshow :: forall a. Show a => AroundIntersection a -> String
show :: AroundIntersection a -> String
$cshowList :: forall a. Show a => [AroundIntersection a] -> ShowS
showList :: [AroundIntersection a] -> ShowS
Show,ReadPrec [AroundIntersection a]
ReadPrec (AroundIntersection a)
Int -> ReadS (AroundIntersection a)
ReadS [AroundIntersection a]
(Int -> ReadS (AroundIntersection a))
-> ReadS [AroundIntersection a]
-> ReadPrec (AroundIntersection a)
-> ReadPrec [AroundIntersection a]
-> Read (AroundIntersection a)
forall a. Read a => ReadPrec [AroundIntersection a]
forall a. Read a => ReadPrec (AroundIntersection a)
forall a. Read a => Int -> ReadS (AroundIntersection a)
forall a. Read a => ReadS [AroundIntersection a]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: forall a. Read a => Int -> ReadS (AroundIntersection a)
readsPrec :: Int -> ReadS (AroundIntersection a)
$creadList :: forall a. Read a => ReadS [AroundIntersection a]
readList :: ReadS [AroundIntersection a]
$creadPrec :: forall a. Read a => ReadPrec (AroundIntersection a)
readPrec :: ReadPrec (AroundIntersection a)
$creadListPrec :: forall a. Read a => ReadPrec [AroundIntersection a]
readListPrec :: ReadPrec [AroundIntersection a]
Read,AroundIntersection a -> ()
(AroundIntersection a -> ()) -> NFData (AroundIntersection a)
forall a. NFData a => AroundIntersection a -> ()
forall a. (a -> ()) -> NFData a
$crnf :: forall a. NFData a => AroundIntersection a -> ()
rnf :: AroundIntersection a -> ()
NFData,(forall a b.
 (a -> b) -> AroundIntersection a -> AroundIntersection b)
-> (forall a b. a -> AroundIntersection b -> AroundIntersection a)
-> Functor AroundIntersection
forall a b. a -> AroundIntersection b -> AroundIntersection a
forall a b.
(a -> b) -> AroundIntersection a -> AroundIntersection b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b.
(a -> b) -> AroundIntersection a -> AroundIntersection b
fmap :: forall a b.
(a -> b) -> AroundIntersection a -> AroundIntersection b
$c<$ :: forall a b. a -> AroundIntersection b -> AroundIntersection a
<$ :: forall a b. a -> AroundIntersection b -> AroundIntersection a
Functor)

makeWrapped ''AroundIntersection

instance ( LineSegment_ lineSegment point
         , Point_ point 2 r
         , Ord r, Fractional r
         , Eq lineSegment
         , IsIntersectableWith lineSegment lineSegment
         , Intersection lineSegment lineSegment ~
           Maybe (LineSegmentLineSegmentIntersection lineSegment)
         ) => Ord (AroundIntersection lineSegment) where
  -- | ccw ordered around their common intersection point.
  (AroundIntersection lineSegment
s) compare :: AroundIntersection lineSegment
-> AroundIntersection lineSegment -> Ordering
`compare` (AroundIntersection lineSegment
s') = case lineSegment
s lineSegment -> lineSegment -> Intersection lineSegment lineSegment
forall g h. IsIntersectableWith g h => g -> h -> Intersection g h
`intersect` lineSegment
s' of
    Maybe (LineSegmentLineSegmentIntersection lineSegment)
Intersection lineSegment lineSegment
Nothing                                  ->
      String -> Ordering
forall a. HasCallStack => String -> a
error String
"AroundIntersection: segments do not intersect!"
    Just (LineSegment_x_LineSegment_Point Point 2 (NumType lineSegment)
p)       -> Point 2 r -> lineSegment -> lineSegment -> Ordering
forall lineSegment point r point'.
(LineSegment_ lineSegment point, Point_ point 2 r,
 Point_ point' 2 r, Ord r, Num r) =>
point' -> lineSegment -> lineSegment -> Ordering
cmpAroundP Point 2 r
Point 2 (NumType lineSegment)
p lineSegment
s lineSegment
s'
    Just (LineSegment_x_LineSegment_LineSegment lineSegment
_) -> lineSegment -> NumType point
forall {point} {s}.
(Num (NumType point),
 Point_ point (Dimension point) (NumType point),
 Metric_
   (Vector (Dimension point) (NumType point))
   (Dimension point)
   (NumType point),
 HasStart s point, HasEnd s point) =>
s -> NumType point
squaredLength lineSegment
s NumType point -> NumType point -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` (lineSegment -> NumType point
forall {point} {s}.
(Num (NumType point),
 Point_ point (Dimension point) (NumType point),
 Metric_
   (Vector (Dimension point) (NumType point))
   (Dimension point)
   (NumType point),
 HasStart s point, HasEnd s point) =>
s -> NumType point
squaredLength lineSegment
s')
        -- if s and s' just happen to be the same length but
        -- intersect in different behaviour from using (==).
        -- but that situation doese not satisfy the precondition
        -- of aroundIntersection anyway.
    where
      squaredLength :: s -> NumType point
squaredLength s
ss = point -> point -> NumType point
forall r point (d :: Nat).
(Num r, Point_ point d r, Metric_ (Vector d r) d r) =>
point -> point -> r
squaredEuclideanDist (s
sss -> Getting point s point -> point
forall s a. s -> Getting a s a -> a
^.Getting point s point
forall seg p. HasStart seg p => Lens' seg p
Lens' s point
start) (s
sss -> Getting point s point -> point
forall s a. s -> Getting a s a -> a
^.Getting point s point
forall seg p. HasEnd seg p => Lens' seg p
Lens' s point
end)

-- | compare around p
cmpAroundP        :: ( LineSegment_ lineSegment point
                     , Point_ point 2 r
                     , Point_ point' 2 r
                     , Ord r, Num r
                     )
                  => point' -> lineSegment -> lineSegment -> Ordering
cmpAroundP :: forall lineSegment point r point'.
(LineSegment_ lineSegment point, Point_ point 2 r,
 Point_ point' 2 r, Ord r, Num r) =>
point' -> lineSegment -> lineSegment -> Ordering
cmpAroundP point'
p lineSegment
s lineSegment
s' = Point 2 r -> Point 2 r -> Point 2 r -> Ordering
forall point r.
(Point_ point 2 r, Ord r, Num r) =>
point -> point -> point -> Ordering
ccwCmpAround (point'
ppoint' -> Getting (Point 2 r) point' (Point 2 r) -> Point 2 r
forall s a. s -> Getting a s a -> a
^.Getting (Point 2 r) point' (Point 2 r)
forall point (d :: Nat) r.
Point_ point d r =>
Lens' point (Point d r)
Lens' point' (Point 2 r)
asPoint) (lineSegment
slineSegment
-> Getting (Point 2 r) lineSegment (Point 2 r) -> Point 2 r
forall s a. s -> Getting a s a -> a
^.(point -> Const (Point 2 r) point)
-> lineSegment -> Const (Point 2 r) lineSegment
forall seg p. HasStart seg p => Lens' seg p
Lens' lineSegment point
start((point -> Const (Point 2 r) point)
 -> lineSegment -> Const (Point 2 r) lineSegment)
-> ((Point 2 r -> Const (Point 2 r) (Point 2 r))
    -> point -> Const (Point 2 r) point)
-> Getting (Point 2 r) lineSegment (Point 2 r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Point 2 r -> Const (Point 2 r) (Point 2 r))
-> point -> Const (Point 2 r) point
forall point (d :: Nat) r.
Point_ point d r =>
Lens' point (Point d r)
Lens' point (Point 2 r)
asPoint)  (lineSegment
s'lineSegment
-> Getting (Point 2 r) lineSegment (Point 2 r) -> Point 2 r
forall s a. s -> Getting a s a -> a
^.(point -> Const (Point 2 r) point)
-> lineSegment -> Const (Point 2 r) lineSegment
forall seg p. HasStart seg p => Lens' seg p
Lens' lineSegment point
start((point -> Const (Point 2 r) point)
 -> lineSegment -> Const (Point 2 r) lineSegment)
-> ((Point 2 r -> Const (Point 2 r) (Point 2 r))
    -> point -> Const (Point 2 r) point)
-> Getting (Point 2 r) lineSegment (Point 2 r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Point 2 r -> Const (Point 2 r) (Point 2 r))
-> point -> Const (Point 2 r) point
forall point (d :: Nat) r.
Point_ point d r =>
Lens' point (Point d r)
Lens' point (Point 2 r)
asPoint)


-- seg1 = ClosedLineSegment (ext $ Point2 0 0) (ext $ Point2 0 10)
-- seg2 = ClosedLineSegment (ext $ Point2 0 0) (ext $ Point2 0 10)

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



-- | The line segments that contain a given point p may either have p
-- as the endpoint or have p in their interior.
--
-- if somehow the segment is degenerate, and p is both the start and
-- end it is reported only as the start point.
data Associated lineSegment =
  Associated { forall lineSegment.
Associated lineSegment -> Set (AroundStart lineSegment)
_startPointOf :: Set.Set (AroundStart lineSegment)
             -- ^ segments for which the intersection point is the
             -- start point (i.e. s^.start == p)
             , forall lineSegment.
Associated lineSegment -> Set (AroundEnd lineSegment)
_endPointOf   :: Set.Set (AroundEnd lineSegment)
             -- ^ segments for which the intersection point is the end
             -- point (i.e. s^.end == p)
             , forall lineSegment.
Associated lineSegment -> Set (AroundIntersection lineSegment)
_interiorTo   :: Set.Set (AroundIntersection lineSegment)
             } deriving stock (Int -> Associated lineSegment -> ShowS
[Associated lineSegment] -> ShowS
Associated lineSegment -> String
(Int -> Associated lineSegment -> ShowS)
-> (Associated lineSegment -> String)
-> ([Associated lineSegment] -> ShowS)
-> Show (Associated lineSegment)
forall lineSegment.
Show lineSegment =>
Int -> Associated lineSegment -> ShowS
forall lineSegment.
Show lineSegment =>
[Associated lineSegment] -> ShowS
forall lineSegment.
Show lineSegment =>
Associated lineSegment -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall lineSegment.
Show lineSegment =>
Int -> Associated lineSegment -> ShowS
showsPrec :: Int -> Associated lineSegment -> ShowS
$cshow :: forall lineSegment.
Show lineSegment =>
Associated lineSegment -> String
show :: Associated lineSegment -> String
$cshowList :: forall lineSegment.
Show lineSegment =>
[Associated lineSegment] -> ShowS
showList :: [Associated lineSegment] -> ShowS
Show, (forall x.
 Associated lineSegment -> Rep (Associated lineSegment) x)
-> (forall x.
    Rep (Associated lineSegment) x -> Associated lineSegment)
-> Generic (Associated lineSegment)
forall x. Rep (Associated lineSegment) x -> Associated lineSegment
forall x. Associated lineSegment -> Rep (Associated lineSegment) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall lineSegment x.
Rep (Associated lineSegment) x -> Associated lineSegment
forall lineSegment x.
Associated lineSegment -> Rep (Associated lineSegment) x
$cfrom :: forall lineSegment x.
Associated lineSegment -> Rep (Associated lineSegment) x
from :: forall x. Associated lineSegment -> Rep (Associated lineSegment) x
$cto :: forall lineSegment x.
Rep (Associated lineSegment) x -> Associated lineSegment
to :: forall x. Rep (Associated lineSegment) x -> Associated lineSegment
Generic)

deriving stock instance ( Eq (AroundStart lineSegment)
                        , Eq (AroundIntersection lineSegment)
                        , Eq (AroundEnd lineSegment)
                        ) => Eq (Associated lineSegment)

deriving stock instance ( Read lineSegment
                        , OrdArounds lineSegment
                        ) => Read (Associated lineSegment)


type OrdArounds lineSegment = ( Ord (AroundStart lineSegment)
                              , Ord (AroundIntersection lineSegment)
                              , Ord (AroundEnd lineSegment)
                              )

makeLenses ''Associated


-- | Fold over the segments associated with the intersection.
associatedSegments     :: Fold (Associated lineSegment) lineSegment
associatedSegments :: forall lineSegment (f :: * -> *).
(Contravariant f, Applicative f) =>
(lineSegment -> f lineSegment)
-> Associated lineSegment -> f (Associated lineSegment)
associatedSegments lineSegment -> f lineSegment
f Associated lineSegment
a =  ((Set (AroundStart lineSegment)
 -> f (Set (AroundStart lineSegment)))
-> Associated lineSegment -> f (Associated lineSegment)
forall lineSegment (f :: * -> *).
Functor f =>
(Set (AroundStart lineSegment)
 -> f (Set (AroundStart lineSegment)))
-> Associated lineSegment -> f (Associated lineSegment)
startPointOf ((Set (AroundStart lineSegment)
  -> f (Set (AroundStart lineSegment)))
 -> Associated lineSegment -> f (Associated lineSegment))
-> ((lineSegment -> f lineSegment)
    -> Set (AroundStart lineSegment)
    -> f (Set (AroundStart lineSegment)))
-> (lineSegment -> f lineSegment)
-> Associated lineSegment
-> f (Associated lineSegment)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AroundStart lineSegment -> f (AroundStart lineSegment))
-> Set (AroundStart lineSegment)
-> f (Set (AroundStart lineSegment))
forall (f :: * -> *) a. Foldable f => IndexedFold Int (f a) a
IndexedFold
  Int (Set (AroundStart lineSegment)) (AroundStart lineSegment)
folded ((AroundStart lineSegment -> f (AroundStart lineSegment))
 -> Set (AroundStart lineSegment)
 -> f (Set (AroundStart lineSegment)))
-> ((lineSegment -> f lineSegment)
    -> AroundStart lineSegment -> f (AroundStart lineSegment))
-> (lineSegment -> f lineSegment)
-> Set (AroundStart lineSegment)
-> f (Set (AroundStart lineSegment))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (lineSegment -> f lineSegment)
-> AroundStart lineSegment -> f (AroundStart lineSegment)
(Unwrapped (AroundStart lineSegment)
 -> f (Unwrapped (AroundStart lineSegment)))
-> AroundStart lineSegment -> f (AroundStart lineSegment)
forall s t. Rewrapping s t => Iso s t (Unwrapped s) (Unwrapped t)
Iso
  (AroundStart lineSegment)
  (AroundStart lineSegment)
  (Unwrapped (AroundStart lineSegment))
  (Unwrapped (AroundStart lineSegment))
_Wrapped) lineSegment -> f lineSegment
f Associated lineSegment
a f (Associated lineSegment)
-> f (Associated lineSegment) -> f (Associated lineSegment)
forall a b. f a -> f b -> f b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*>
                          ((Set (AroundEnd lineSegment) -> f (Set (AroundEnd lineSegment)))
-> Associated lineSegment -> f (Associated lineSegment)
forall lineSegment (f :: * -> *).
Functor f =>
(Set (AroundEnd lineSegment) -> f (Set (AroundEnd lineSegment)))
-> Associated lineSegment -> f (Associated lineSegment)
endPointOf   ((Set (AroundEnd lineSegment) -> f (Set (AroundEnd lineSegment)))
 -> Associated lineSegment -> f (Associated lineSegment))
-> ((lineSegment -> f lineSegment)
    -> Set (AroundEnd lineSegment) -> f (Set (AroundEnd lineSegment)))
-> (lineSegment -> f lineSegment)
-> Associated lineSegment
-> f (Associated lineSegment)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AroundEnd lineSegment -> f (AroundEnd lineSegment))
-> Set (AroundEnd lineSegment) -> f (Set (AroundEnd lineSegment))
forall (f :: * -> *) a. Foldable f => IndexedFold Int (f a) a
IndexedFold
  Int (Set (AroundEnd lineSegment)) (AroundEnd lineSegment)
folded ((AroundEnd lineSegment -> f (AroundEnd lineSegment))
 -> Set (AroundEnd lineSegment) -> f (Set (AroundEnd lineSegment)))
-> ((lineSegment -> f lineSegment)
    -> AroundEnd lineSegment -> f (AroundEnd lineSegment))
-> (lineSegment -> f lineSegment)
-> Set (AroundEnd lineSegment)
-> f (Set (AroundEnd lineSegment))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (lineSegment -> f lineSegment)
-> AroundEnd lineSegment -> f (AroundEnd lineSegment)
(Unwrapped (AroundEnd lineSegment)
 -> f (Unwrapped (AroundEnd lineSegment)))
-> AroundEnd lineSegment -> f (AroundEnd lineSegment)
forall s t. Rewrapping s t => Iso s t (Unwrapped s) (Unwrapped t)
Iso
  (AroundEnd lineSegment)
  (AroundEnd lineSegment)
  (Unwrapped (AroundEnd lineSegment))
  (Unwrapped (AroundEnd lineSegment))
_Wrapped) lineSegment -> f lineSegment
f Associated lineSegment
a f (Associated lineSegment)
-> f (Associated lineSegment) -> f (Associated lineSegment)
forall a b. f a -> f b -> f b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*>
                          ((Set (AroundIntersection lineSegment)
 -> f (Set (AroundIntersection lineSegment)))
-> Associated lineSegment -> f (Associated lineSegment)
forall lineSegment (f :: * -> *).
Functor f =>
(Set (AroundIntersection lineSegment)
 -> f (Set (AroundIntersection lineSegment)))
-> Associated lineSegment -> f (Associated lineSegment)
interiorTo   ((Set (AroundIntersection lineSegment)
  -> f (Set (AroundIntersection lineSegment)))
 -> Associated lineSegment -> f (Associated lineSegment))
-> ((lineSegment -> f lineSegment)
    -> Set (AroundIntersection lineSegment)
    -> f (Set (AroundIntersection lineSegment)))
-> (lineSegment -> f lineSegment)
-> Associated lineSegment
-> f (Associated lineSegment)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AroundIntersection lineSegment
 -> f (AroundIntersection lineSegment))
-> Set (AroundIntersection lineSegment)
-> f (Set (AroundIntersection lineSegment))
forall (f :: * -> *) a. Foldable f => IndexedFold Int (f a) a
IndexedFold
  Int
  (Set (AroundIntersection lineSegment))
  (AroundIntersection lineSegment)
folded ((AroundIntersection lineSegment
  -> f (AroundIntersection lineSegment))
 -> Set (AroundIntersection lineSegment)
 -> f (Set (AroundIntersection lineSegment)))
-> ((lineSegment -> f lineSegment)
    -> AroundIntersection lineSegment
    -> f (AroundIntersection lineSegment))
-> (lineSegment -> f lineSegment)
-> Set (AroundIntersection lineSegment)
-> f (Set (AroundIntersection lineSegment))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (lineSegment -> f lineSegment)
-> AroundIntersection lineSegment
-> f (AroundIntersection lineSegment)
(Unwrapped (AroundIntersection lineSegment)
 -> f (Unwrapped (AroundIntersection lineSegment)))
-> AroundIntersection lineSegment
-> f (AroundIntersection lineSegment)
forall s t. Rewrapping s t => Iso s t (Unwrapped s) (Unwrapped t)
Iso
  (AroundIntersection lineSegment)
  (AroundIntersection lineSegment)
  (Unwrapped (AroundIntersection lineSegment))
  (Unwrapped (AroundIntersection lineSegment))
_Wrapped) lineSegment -> f lineSegment
f Associated lineSegment
a
  -- combine the folds

-- instance Functor (Associated lineSegment) where
--   fmap f (Associated ss es is) = Associated (Set.mapMonotonic (g f) ss)
--                                             (Set.mapMonotonic (g f) es)
--                                             (Set.mapMonotonic (g f) is)
--     where
--       g   :: forall f c e b. Functor f => (e -> b) -> f (c :+ e) -> f (c :+ b)
--       g f' = fmap (&extra %~ f')


-- | Reports whether this associated has any interior intersections
--
-- \(O(1)\)
isInteriorIntersection :: Associated lineSegment -> Bool
isInteriorIntersection :: forall lineSegment. Associated lineSegment -> Bool
isInteriorIntersection = Bool -> Bool
not (Bool -> Bool)
-> (Associated lineSegment -> Bool)
-> Associated lineSegment
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set (AroundIntersection lineSegment) -> Bool
forall a. Set a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Set (AroundIntersection lineSegment) -> Bool)
-> (Associated lineSegment -> Set (AroundIntersection lineSegment))
-> Associated lineSegment
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Associated lineSegment -> Set (AroundIntersection lineSegment)
forall lineSegment.
Associated lineSegment -> Set (AroundIntersection lineSegment)
_interiorTo


-- | test if the given segment has p as its endpoint, an construct the
-- appropriate associated representing that.
--
-- pre: p intersects the segment
mkAssociated      :: ( LineSegment_ lineSegment point
                     , Point_ point 2 r
                     , Point_ point' 2 r
                     , Eq r
                     , OrdArounds lineSegment
                     )
                  => point' -> lineSegment -> Associated lineSegment
mkAssociated :: forall lineSegment point r point'.
(LineSegment_ lineSegment point, Point_ point 2 r,
 Point_ point' 2 r, Eq r, OrdArounds lineSegment) =>
point' -> lineSegment -> Associated lineSegment
mkAssociated point'
p lineSegment
s
  | point'
ppoint' -> Getting (Point 2 r) point' (Point 2 r) -> Point 2 r
forall s a. s -> Getting a s a -> a
^.Getting (Point 2 r) point' (Point 2 r)
forall point (d :: Nat) r.
Point_ point d r =>
Lens' point (Point d r)
Lens' point' (Point 2 r)
asPoint Point 2 r -> Point 2 r -> Bool
forall a. Eq a => a -> a -> Bool
== lineSegment
slineSegment
-> Getting (Point 2 r) lineSegment (Point 2 r) -> Point 2 r
forall s a. s -> Getting a s a -> a
^.(point -> Const (Point 2 r) point)
-> lineSegment -> Const (Point 2 r) lineSegment
forall seg p. HasStart seg p => Lens' seg p
Lens' lineSegment point
start((point -> Const (Point 2 r) point)
 -> lineSegment -> Const (Point 2 r) lineSegment)
-> ((Point 2 r -> Const (Point 2 r) (Point 2 r))
    -> point -> Const (Point 2 r) point)
-> Getting (Point 2 r) lineSegment (Point 2 r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Point 2 r -> Const (Point 2 r) (Point 2 r))
-> point -> Const (Point 2 r) point
forall point (d :: Nat) r.
Point_ point d r =>
Lens' point (Point d r)
Lens' point (Point 2 r)
asPoint = Associated lineSegment
forall a. Monoid a => a
memptyAssociated lineSegment
-> (Associated lineSegment -> Associated lineSegment)
-> Associated lineSegment
forall a b. a -> (a -> b) -> b
&(Set (AroundStart lineSegment)
 -> Identity (Set (AroundStart lineSegment)))
-> Associated lineSegment -> Identity (Associated lineSegment)
forall lineSegment (f :: * -> *).
Functor f =>
(Set (AroundStart lineSegment)
 -> f (Set (AroundStart lineSegment)))
-> Associated lineSegment -> f (Associated lineSegment)
startPointOf ((Set (AroundStart lineSegment)
  -> Identity (Set (AroundStart lineSegment)))
 -> Associated lineSegment -> Identity (Associated lineSegment))
-> Set (AroundStart lineSegment)
-> Associated lineSegment
-> Associated lineSegment
forall s t a b. ASetter s t a b -> b -> s -> t
.~  AroundStart lineSegment -> Set (AroundStart lineSegment)
forall a. a -> Set a
Set.singleton (lineSegment -> AroundStart lineSegment
forall a. a -> AroundStart a
AroundStart lineSegment
s)
  | point'
ppoint' -> Getting (Point 2 r) point' (Point 2 r) -> Point 2 r
forall s a. s -> Getting a s a -> a
^.Getting (Point 2 r) point' (Point 2 r)
forall point (d :: Nat) r.
Point_ point d r =>
Lens' point (Point d r)
Lens' point' (Point 2 r)
asPoint Point 2 r -> Point 2 r -> Bool
forall a. Eq a => a -> a -> Bool
== lineSegment
slineSegment
-> Getting (Point 2 r) lineSegment (Point 2 r) -> Point 2 r
forall s a. s -> Getting a s a -> a
^.(point -> Const (Point 2 r) point)
-> lineSegment -> Const (Point 2 r) lineSegment
forall seg p. HasEnd seg p => Lens' seg p
Lens' lineSegment point
end((point -> Const (Point 2 r) point)
 -> lineSegment -> Const (Point 2 r) lineSegment)
-> ((Point 2 r -> Const (Point 2 r) (Point 2 r))
    -> point -> Const (Point 2 r) point)
-> Getting (Point 2 r) lineSegment (Point 2 r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Point 2 r -> Const (Point 2 r) (Point 2 r))
-> point -> Const (Point 2 r) point
forall point (d :: Nat) r.
Point_ point d r =>
Lens' point (Point d r)
Lens' point (Point 2 r)
asPoint   = Associated lineSegment
forall a. Monoid a => a
memptyAssociated lineSegment
-> (Associated lineSegment -> Associated lineSegment)
-> Associated lineSegment
forall a b. a -> (a -> b) -> b
&(Set (AroundEnd lineSegment)
 -> Identity (Set (AroundEnd lineSegment)))
-> Associated lineSegment -> Identity (Associated lineSegment)
forall lineSegment (f :: * -> *).
Functor f =>
(Set (AroundEnd lineSegment) -> f (Set (AroundEnd lineSegment)))
-> Associated lineSegment -> f (Associated lineSegment)
endPointOf   ((Set (AroundEnd lineSegment)
  -> Identity (Set (AroundEnd lineSegment)))
 -> Associated lineSegment -> Identity (Associated lineSegment))
-> Set (AroundEnd lineSegment)
-> Associated lineSegment
-> Associated lineSegment
forall s t a b. ASetter s t a b -> b -> s -> t
.~  AroundEnd lineSegment -> Set (AroundEnd lineSegment)
forall a. a -> Set a
Set.singleton (lineSegment -> AroundEnd lineSegment
forall a. a -> AroundEnd a
AroundEnd lineSegment
s)
  | Bool
otherwise                      = Associated lineSegment
forall a. Monoid a => a
memptyAssociated lineSegment
-> (Associated lineSegment -> Associated lineSegment)
-> Associated lineSegment
forall a b. a -> (a -> b) -> b
&(Set (AroundIntersection lineSegment)
 -> Identity (Set (AroundIntersection lineSegment)))
-> Associated lineSegment -> Identity (Associated lineSegment)
forall lineSegment (f :: * -> *).
Functor f =>
(Set (AroundIntersection lineSegment)
 -> f (Set (AroundIntersection lineSegment)))
-> Associated lineSegment -> f (Associated lineSegment)
interiorTo   ((Set (AroundIntersection lineSegment)
  -> Identity (Set (AroundIntersection lineSegment)))
 -> Associated lineSegment -> Identity (Associated lineSegment))
-> Set (AroundIntersection lineSegment)
-> Associated lineSegment
-> Associated lineSegment
forall s t a b. ASetter s t a b -> b -> s -> t
.~  AroundIntersection lineSegment
-> Set (AroundIntersection lineSegment)
forall a. a -> Set a
Set.singleton (lineSegment -> AroundIntersection lineSegment
forall a. a -> AroundIntersection a
AroundIntersection lineSegment
s)


---- | test if the given segment has p as its endpoint, an construct the
---- appropriate associated representing that.
----
---- If p is not one of the endpoints we concstruct an empty Associated!
----
--mkAssociated'     :: ( LineSegment_ lineSegment point
--                     , Point_ point 2 r
--                     , Eq r
--                     , OrdArounds lineSegment
--                     )
--                  => point -> lineSegment -> Associated lineSegment
--mkAssociated' p s = (mkAssociated p s)&interiorTo .~ mempty


instance OrdArounds lineSegment => Semigroup (Associated lineSegment) where
  (Associated Set (AroundStart lineSegment)
ss Set (AroundEnd lineSegment)
es Set (AroundIntersection lineSegment)
is) <> :: Associated lineSegment
-> Associated lineSegment -> Associated lineSegment
<> (Associated Set (AroundStart lineSegment)
ss' Set (AroundEnd lineSegment)
es' Set (AroundIntersection lineSegment)
is') =
    Set (AroundStart lineSegment)
-> Set (AroundEnd lineSegment)
-> Set (AroundIntersection lineSegment)
-> Associated lineSegment
forall lineSegment.
Set (AroundStart lineSegment)
-> Set (AroundEnd lineSegment)
-> Set (AroundIntersection lineSegment)
-> Associated lineSegment
Associated (Set (AroundStart lineSegment)
ss Set (AroundStart lineSegment)
-> Set (AroundStart lineSegment) -> Set (AroundStart lineSegment)
forall a. Semigroup a => a -> a -> a
<> Set (AroundStart lineSegment)
ss') (Set (AroundEnd lineSegment)
es Set (AroundEnd lineSegment)
-> Set (AroundEnd lineSegment) -> Set (AroundEnd lineSegment)
forall a. Semigroup a => a -> a -> a
<> Set (AroundEnd lineSegment)
es') (Set (AroundIntersection lineSegment)
is Set (AroundIntersection lineSegment)
-> Set (AroundIntersection lineSegment)
-> Set (AroundIntersection lineSegment)
forall a. Semigroup a => a -> a -> a
<> Set (AroundIntersection lineSegment)
is')

instance OrdArounds lineSegment => Monoid (Associated lineSegment) where
  mempty :: Associated lineSegment
mempty = Set (AroundStart lineSegment)
-> Set (AroundEnd lineSegment)
-> Set (AroundIntersection lineSegment)
-> Associated lineSegment
forall lineSegment.
Set (AroundStart lineSegment)
-> Set (AroundEnd lineSegment)
-> Set (AroundIntersection lineSegment)
-> Associated lineSegment
Associated Set (AroundStart lineSegment)
forall a. Monoid a => a
mempty Set (AroundEnd lineSegment)
forall a. Monoid a => a
mempty Set (AroundIntersection lineSegment)
forall a. Monoid a => a
mempty

instance (NFData lineSegment) => NFData (Associated lineSegment)

-- | For each intersection point the segments intersecting there.
type Intersections r lineSegment = Map.Map (Point 2 r) (Associated lineSegment)

-- | Get the set of all intersection points
intersectionPoints :: Intersections r lineSegment -> Set.Set (Point 2 r)
intersectionPoints :: forall r lineSegment.
Intersections r lineSegment -> Set (Point 2 r)
intersectionPoints = Map (Point 2 r) (Associated lineSegment) -> Set (Point 2 r)
forall k a. Map k a -> Set k
Map.keysSet

-- | An intersection point together with all segments intersecting at
-- this point.
data IntersectionPoint point lineSegment =
  IntersectionPoint { forall point lineSegment.
IntersectionPoint point lineSegment -> point
_intersectionPoint :: !point
                    , forall point lineSegment.
IntersectionPoint point lineSegment -> Associated lineSegment
_associatedSegs    :: !(Associated lineSegment)
                    } deriving stock (Int -> IntersectionPoint point lineSegment -> ShowS
[IntersectionPoint point lineSegment] -> ShowS
IntersectionPoint point lineSegment -> String
(Int -> IntersectionPoint point lineSegment -> ShowS)
-> (IntersectionPoint point lineSegment -> String)
-> ([IntersectionPoint point lineSegment] -> ShowS)
-> Show (IntersectionPoint point lineSegment)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall point lineSegment.
(Show point, Show lineSegment) =>
Int -> IntersectionPoint point lineSegment -> ShowS
forall point lineSegment.
(Show point, Show lineSegment) =>
[IntersectionPoint point lineSegment] -> ShowS
forall point lineSegment.
(Show point, Show lineSegment) =>
IntersectionPoint point lineSegment -> String
$cshowsPrec :: forall point lineSegment.
(Show point, Show lineSegment) =>
Int -> IntersectionPoint point lineSegment -> ShowS
showsPrec :: Int -> IntersectionPoint point lineSegment -> ShowS
$cshow :: forall point lineSegment.
(Show point, Show lineSegment) =>
IntersectionPoint point lineSegment -> String
show :: IntersectionPoint point lineSegment -> String
$cshowList :: forall point lineSegment.
(Show point, Show lineSegment) =>
[IntersectionPoint point lineSegment] -> ShowS
showList :: [IntersectionPoint point lineSegment] -> ShowS
Show,(forall x.
 IntersectionPoint point lineSegment
 -> Rep (IntersectionPoint point lineSegment) x)
-> (forall x.
    Rep (IntersectionPoint point lineSegment) x
    -> IntersectionPoint point lineSegment)
-> Generic (IntersectionPoint point lineSegment)
forall x.
Rep (IntersectionPoint point lineSegment) x
-> IntersectionPoint point lineSegment
forall x.
IntersectionPoint point lineSegment
-> Rep (IntersectionPoint point lineSegment) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall point lineSegment x.
Rep (IntersectionPoint point lineSegment) x
-> IntersectionPoint point lineSegment
forall point lineSegment x.
IntersectionPoint point lineSegment
-> Rep (IntersectionPoint point lineSegment) x
$cfrom :: forall point lineSegment x.
IntersectionPoint point lineSegment
-> Rep (IntersectionPoint point lineSegment) x
from :: forall x.
IntersectionPoint point lineSegment
-> Rep (IntersectionPoint point lineSegment) x
$cto :: forall point lineSegment x.
Rep (IntersectionPoint point lineSegment) x
-> IntersectionPoint point lineSegment
to :: forall x.
Rep (IntersectionPoint point lineSegment) x
-> IntersectionPoint point lineSegment
Generic)
makeLenses ''IntersectionPoint

deriving stock instance ( Eq (AroundStart lineSegment)
                        , Eq (AroundIntersection lineSegment)
                        , Eq (AroundEnd lineSegment)
                        , Eq point
                        ) => Eq (IntersectionPoint point lineSegment)

deriving stock instance ( Read lineSegment, Read point
                        , OrdArounds lineSegment
                        ) => Read (IntersectionPoint point lineSegment)


instance (NFData point, NFData lineSegment) => NFData (IntersectionPoint point lineSegment)


-- sameOrder           :: (Ord r, Num r, Eq p) => Point 2 r
--                     -> [LineSegment 2 p r] -> [LineSegment 2 p r] -> Bool
-- sameOrder c ss ss' = f ss == f ss'
--   where
--     f = map (^.extra) . sortAround' (ext c) . map (\s -> s^.end.core :+ s)




-- | Given a point p, and a bunch of segments that suposedly intersect
-- at p, correctly categorize them.
mkIntersectionPoint         :: ( LineSegment_ lineSegment endPoint
                               , Point_ endPoint 2 r
                               , Point_ point 2 r, Eq r
                               , OrdArounds lineSegment
                               )
                            => point
                            -> [lineSegment] -- ^ uncategorized
                            -> [lineSegment] -- ^ segments we know contain p,
                            -> IntersectionPoint point lineSegment
mkIntersectionPoint :: forall lineSegment endPoint r point.
(LineSegment_ lineSegment endPoint, Point_ endPoint 2 r,
 Point_ point 2 r, Eq r, OrdArounds lineSegment) =>
point
-> [lineSegment]
-> [lineSegment]
-> IntersectionPoint point lineSegment
mkIntersectionPoint point
p [lineSegment]
as [lineSegment]
cs = point
-> Associated lineSegment -> IntersectionPoint point lineSegment
forall point lineSegment.
point
-> Associated lineSegment -> IntersectionPoint point lineSegment
IntersectionPoint point
p (Associated lineSegment -> IntersectionPoint point lineSegment)
-> Associated lineSegment -> IntersectionPoint point lineSegment
forall a b. (a -> b) -> a -> b
$ (lineSegment -> Associated lineSegment)
-> [lineSegment] -> Associated lineSegment
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (point -> lineSegment -> Associated lineSegment
forall lineSegment point r point'.
(LineSegment_ lineSegment point, Point_ point 2 r,
 Point_ point' 2 r, Eq r, OrdArounds lineSegment) =>
point' -> lineSegment -> Associated lineSegment
mkAssociated point
p) ([lineSegment] -> Associated lineSegment)
-> [lineSegment] -> Associated lineSegment
forall a b. (a -> b) -> a -> b
$ [lineSegment]
as [lineSegment] -> [lineSegment] -> [lineSegment]
forall a. Semigroup a => a -> a -> a
<> [lineSegment]
cs

  -- IntersectionPoint p
  --                           $ Associated mempty mempty (Set.fromAscList cs')
  --                           <> foldMap (mkAssociated p) as
  -- where
  --   cs' = map AroundIntersection . List.sortBy (cmpAroundP p) $ cs
  -- -- TODO: In the bentley ottman algo we already know the sorted order of the segments
  -- -- so we can likely save the additional sort


-- | An ordering that is decreasing on y, increasing on x
ordPoints     :: (Point_ point 2 r, Ord r) => point -> point -> Ordering
ordPoints :: forall point r.
(Point_ point 2 r, Ord r) =>
point -> point -> Ordering
ordPoints point
a point
b = let f :: s -> (Down (NumType s), NumType s)
f s
p = (NumType s -> Down (NumType s)
forall a. a -> Down a
Down (NumType s -> Down (NumType s)) -> NumType s -> Down (NumType s)
forall a b. (a -> b) -> a -> b
$ s
ps -> Getting (NumType s) s (NumType s) -> NumType s
forall s a. s -> Getting a s a -> a
^.Getting (NumType s) s (NumType s)
forall (d :: Nat) point r.
(2 <= d, Point_ point d r) =>
IndexedLens' Int point r
IndexedLens' Int s (NumType s)
yCoord, s
ps -> Getting (NumType s) s (NumType s) -> NumType s
forall s a. s -> Getting a s a -> a
^.Getting (NumType s) s (NumType s)
forall (d :: Nat) point r.
(1 <= d, Point_ point d r) =>
IndexedLens' Int point r
IndexedLens' Int s (NumType s)
xCoord) in (point -> (Down r, r)) -> point -> point -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing point -> (Down r, r)
point -> (Down (NumType point), NumType point)
forall {s}.
(Assert
   (OrdCond (CmpNat 2 (Dimension s)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 1 (Dimension s)) 'True 'True 'False)
   (TypeError ...),
 Point_ s (Dimension s) (NumType s)) =>
s -> (Down (NumType s), NumType s)
f point
a point
b

-- | Given two segments, compute an IntersectionPoint representing their intersection (if
-- such an intersection exists).
intersectionPointOf      :: ( LineSegment_ lineSegment point
                            , Point_ point 2 r
                            , Ord r, Fractional r
                            , IntersectConstraints lineSegment
                            )
                         => lineSegment -> lineSegment
                         -> Maybe (IntersectionPoint (Point 2 r) lineSegment)
intersectionPointOf :: forall lineSegment point r.
(LineSegment_ lineSegment point, Point_ point 2 r, Ord r,
 Fractional r, IntersectConstraints lineSegment) =>
lineSegment
-> lineSegment -> Maybe (IntersectionPoint (Point 2 r) lineSegment)
intersectionPointOf lineSegment
s lineSegment
s' = lineSegment
s lineSegment -> lineSegment -> Intersection lineSegment lineSegment
forall g h. IsIntersectableWith g h => g -> h -> Intersection g h
`intersect` lineSegment
s' Maybe (LineSegmentLineSegmentIntersection lineSegment)
-> (LineSegmentLineSegmentIntersection lineSegment
    -> IntersectionPoint (Point 2 r) lineSegment)
-> Maybe (IntersectionPoint (Point 2 r) lineSegment)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
     LineSegment_x_LineSegment_Point Point 2 (NumType lineSegment)
p         -> Point 2 r -> IntersectionPoint (Point 2 r) lineSegment
intersectionPoint' Point 2 r
Point 2 (NumType lineSegment)
p
     LineSegment_x_LineSegment_LineSegment lineSegment
seg -> Point 2 r -> IntersectionPoint (Point 2 r) lineSegment
intersectionPoint' (lineSegment -> Point (Dimension point) (NumType point)
forall {p} {p} {s}.
(Dimension p ~ 2, Dimension p ~ 2, NumType p ~ NumType p,
 Ord (NumType p), HasStart s p, HasEnd s p, Point_ p 2 (NumType p),
 Point_ p 2 (NumType p)) =>
s -> Point (Dimension p) (NumType p)
topEndPoint lineSegment
seg)
  where
    intersectionPoint' :: Point 2 r -> IntersectionPoint (Point 2 r) lineSegment
intersectionPoint' Point 2 r
p = Point 2 r
-> Associated lineSegment
-> IntersectionPoint (Point 2 r) lineSegment
forall point lineSegment.
point
-> Associated lineSegment -> IntersectionPoint point lineSegment
IntersectionPoint Point 2 r
p (Point 2 r -> lineSegment -> Associated lineSegment
forall lineSegment point r point'.
(LineSegment_ lineSegment point, Point_ point 2 r,
 Point_ point' 2 r, Eq r, OrdArounds lineSegment) =>
point' -> lineSegment -> Associated lineSegment
mkAssociated Point 2 r
p lineSegment
s Associated lineSegment
-> Associated lineSegment -> Associated lineSegment
forall a. Semigroup a => a -> a -> a
<> Point 2 r -> lineSegment -> Associated lineSegment
forall lineSegment point r point'.
(LineSegment_ lineSegment point, Point_ point 2 r,
 Point_ point' 2 r, Eq r, OrdArounds lineSegment) =>
point' -> lineSegment -> Associated lineSegment
mkAssociated Point 2 r
p lineSegment
s')
    topEndPoint :: s -> Point (Dimension p) (NumType p)
topEndPoint s
seg = (Point (Dimension p) (NumType p)
 -> Point (Dimension p) (NumType p) -> Ordering)
-> [Point (Dimension p) (NumType p)]
-> Point (Dimension p) (NumType p)
forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
List.minimumBy Point (Dimension p) (NumType p)
-> Point (Dimension p) (NumType p) -> Ordering
forall point r.
(Point_ point 2 r, Ord r) =>
point -> point -> Ordering
ordPoints [s
segs
-> Getting
     (Point (Dimension p) (NumType p))
     s
     (Point (Dimension p) (NumType p))
-> Point (Dimension p) (NumType p)
forall s a. s -> Getting a s a -> a
^.(p -> Const (Point (Dimension p) (NumType p)) p)
-> s -> Const (Point (Dimension p) (NumType p)) s
forall seg p. HasStart seg p => Lens' seg p
Lens' s p
start((p -> Const (Point (Dimension p) (NumType p)) p)
 -> s -> Const (Point (Dimension p) (NumType p)) s)
-> ((Point (Dimension p) (NumType p)
     -> Const
          (Point (Dimension p) (NumType p))
          (Point (Dimension p) (NumType p)))
    -> p -> Const (Point (Dimension p) (NumType p)) p)
-> Getting
     (Point (Dimension p) (NumType p))
     s
     (Point (Dimension p) (NumType p))
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Point (Dimension p) (NumType p)
 -> Const
      (Point (Dimension p) (NumType p))
      (Point (Dimension p) (NumType p)))
-> p -> Const (Point (Dimension p) (NumType p)) p
forall point (d :: Nat) r.
Point_ point d r =>
Lens' point (Point d r)
Lens' p (Point (Dimension p) (NumType p))
asPoint, s
segs
-> Getting
     (Point (Dimension p) (NumType p))
     s
     (Point (Dimension p) (NumType p))
-> Point (Dimension p) (NumType p)
forall s a. s -> Getting a s a -> a
^.(p -> Const (Point (Dimension p) (NumType p)) p)
-> s -> Const (Point (Dimension p) (NumType p)) s
forall seg p. HasEnd seg p => Lens' seg p
Lens' s p
end((p -> Const (Point (Dimension p) (NumType p)) p)
 -> s -> Const (Point (Dimension p) (NumType p)) s)
-> ((Point (Dimension p) (NumType p)
     -> Const
          (Point (Dimension p) (NumType p))
          (Point (Dimension p) (NumType p)))
    -> p -> Const (Point (Dimension p) (NumType p)) p)
-> Getting
     (Point (Dimension p) (NumType p))
     s
     (Point (Dimension p) (NumType p))
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Point (Dimension p) (NumType p)
 -> Const
      (Point (Dimension p) (NumType p))
      (Point (Dimension p) (NumType p)))
-> p -> Const (Point (Dimension p) (NumType p)) p
forall point (d :: Nat) r.
Point_ point d r =>
Lens' point (Point d r)
Lens' p (Point (Dimension p) (NumType p))
asPoint]

-- | Shorthand for the more-or-less standard constraints that we need on LineSegments
type IntersectConstraints lineSegment =
  ( OrdArounds lineSegment
  , IsIntersectableWith lineSegment lineSegment
  , Intersection lineSegment lineSegment ~ Maybe (LineSegmentLineSegmentIntersection lineSegment)
  )