{-# LANGUAGE TemplateHaskell #-}
--------------------------------------------------------------------------------
-- |
-- Module      :  Algorithms.Geometry.LineSegmentIntersection.Types
-- Copyright   :  (C) Frank Staals
-- License     :  see the LICENSE file
-- Maintainer  :  Frank Staals
--------------------------------------------------------------------------------
module Algorithms.Geometry.LineSegmentIntersection.Types where

import           Control.DeepSeq
import           Control.Lens
import           Data.Ext
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 Map
import           GHC.Generics

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

type Compare a = a -> a -> Ordering

-- get the endpoints of a line segment
endPoints'   :: (HasEnd s, HasStart s) => s -> (StartCore s, EndCore s)
endPoints' :: s -> (StartCore s, EndCore s)
endPoints' s
s = (s
ss -> Getting (StartCore s) s (StartCore s) -> StartCore s
forall s a. s -> Getting a s a -> a
^.((StartCore s :+ StartExtra s)
 -> Const (StartCore s) (StartCore s :+ StartExtra s))
-> s -> Const (StartCore s) s
forall t. HasStart t => Lens' t (StartCore t :+ StartExtra t)
start(((StartCore s :+ StartExtra s)
  -> Const (StartCore s) (StartCore s :+ StartExtra s))
 -> s -> Const (StartCore s) s)
-> ((StartCore s -> Const (StartCore s) (StartCore s))
    -> (StartCore s :+ StartExtra s)
    -> Const (StartCore s) (StartCore s :+ StartExtra s))
-> Getting (StartCore s) s (StartCore s)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(StartCore s -> Const (StartCore s) (StartCore s))
-> (StartCore s :+ StartExtra s)
-> Const (StartCore s) (StartCore s :+ StartExtra s)
forall core extra core'.
Lens (core :+ extra) (core' :+ extra) core core'
core,s
ss -> Getting (EndCore s) s (EndCore s) -> EndCore s
forall s a. s -> Getting a s a -> a
^.((EndCore s :+ EndExtra s)
 -> Const (EndCore s) (EndCore s :+ EndExtra s))
-> s -> Const (EndCore s) s
forall t. HasEnd t => Lens' t (EndCore t :+ EndExtra t)
end(((EndCore s :+ EndExtra s)
  -> Const (EndCore s) (EndCore s :+ EndExtra s))
 -> s -> Const (EndCore s) s)
-> ((EndCore s -> Const (EndCore s) (EndCore s))
    -> (EndCore s :+ EndExtra s)
    -> Const (EndCore s) (EndCore s :+ EndExtra s))
-> Getting (EndCore s) s (EndCore s)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(EndCore s -> Const (EndCore s) (EndCore s))
-> (EndCore s :+ EndExtra s)
-> Const (EndCore s) (EndCore s :+ EndExtra s)
forall core extra core'.
Lens (core :+ extra) (core' :+ extra) core core'
core)


type Set' l =
  Map.Map (Point (Dimension l) (NumType l), Point (Dimension l) (NumType l)) (NonEmpty l)

data Associated p r = Associated { Associated p r -> Set' (LineSegment 2 p r)
_endPointOf        :: Set' (LineSegment 2 p r)
                                 , Associated p r -> Set' (LineSegment 2 p r)
_interiorTo        :: Set' (LineSegment 2 p r)
                                 } deriving (Int -> Associated p r -> ShowS
[Associated p r] -> ShowS
Associated p r -> String
(Int -> Associated p r -> ShowS)
-> (Associated p r -> String)
-> ([Associated p r] -> ShowS)
-> Show (Associated p r)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall p r. (Show r, Show p) => Int -> Associated p r -> ShowS
forall p r. (Show r, Show p) => [Associated p r] -> ShowS
forall p r. (Show r, Show p) => Associated p r -> String
showList :: [Associated p r] -> ShowS
$cshowList :: forall p r. (Show r, Show p) => [Associated p r] -> ShowS
show :: Associated p r -> String
$cshow :: forall p r. (Show r, Show p) => Associated p r -> String
showsPrec :: Int -> Associated p r -> ShowS
$cshowsPrec :: forall p r. (Show r, Show p) => Int -> Associated p r -> ShowS
Show, (forall x. Associated p r -> Rep (Associated p r) x)
-> (forall x. Rep (Associated p r) x -> Associated p r)
-> Generic (Associated p r)
forall x. Rep (Associated p r) x -> Associated p r
forall x. Associated p r -> Rep (Associated p r) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall p r x. Rep (Associated p r) x -> Associated p r
forall p r x. Associated p r -> Rep (Associated p r) x
$cto :: forall p r x. Rep (Associated p r) x -> Associated p r
$cfrom :: forall p r x. Associated p r -> Rep (Associated p r) x
Generic)


instance (Eq p, Eq r) => Eq (Associated p r) where
  (Associated Set' (LineSegment 2 p r)
es Set' (LineSegment 2 p r)
is) == :: Associated p r -> Associated p r -> Bool
== (Associated Set' (LineSegment 2 p r)
es' Set' (LineSegment 2 p r)
is') = Map (Point 2 r, Point 2 r) (NonEmpty (LineSegment 2 p r))
-> Map (Point 2 r, Point 2 r) (NonEmpty (LineSegment 2 p r))
-> Bool
f Map (Point 2 r, Point 2 r) (NonEmpty (LineSegment 2 p r))
Set' (LineSegment 2 p r)
es Map (Point 2 r, Point 2 r) (NonEmpty (LineSegment 2 p r))
Set' (LineSegment 2 p r)
es' Bool -> Bool -> Bool
&& Map (Point 2 r, Point 2 r) (NonEmpty (LineSegment 2 p r))
-> Map (Point 2 r, Point 2 r) (NonEmpty (LineSegment 2 p r))
-> Bool
f Map (Point 2 r, Point 2 r) (NonEmpty (LineSegment 2 p r))
Set' (LineSegment 2 p r)
is Map (Point 2 r, Point 2 r) (NonEmpty (LineSegment 2 p r))
Set' (LineSegment 2 p r)
is'
    where
      f :: Map (Point 2 r, Point 2 r) (NonEmpty (LineSegment 2 p r))
-> Map (Point 2 r, Point 2 r) (NonEmpty (LineSegment 2 p r))
-> Bool
f Map (Point 2 r, Point 2 r) (NonEmpty (LineSegment 2 p r))
xs Map (Point 2 r, Point 2 r) (NonEmpty (LineSegment 2 p r))
ys = [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and ([Bool] -> Bool) -> [Bool] -> Bool
forall a b. (a -> b) -> a -> b
$ (((Point 2 r, Point 2 r), NonEmpty (LineSegment 2 p r))
 -> ((Point 2 r, Point 2 r), NonEmpty (LineSegment 2 p r)) -> Bool)
-> [((Point 2 r, Point 2 r), NonEmpty (LineSegment 2 p r))]
-> [((Point 2 r, Point 2 r), NonEmpty (LineSegment 2 p r))]
-> [Bool]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\((Point 2 r, Point 2 r)
p,NonEmpty (LineSegment 2 p r)
pa) ((Point 2 r, Point 2 r)
q,NonEmpty (LineSegment 2 p r)
qa) -> (Point 2 r, Point 2 r)
p (Point 2 r, Point 2 r) -> (Point 2 r, Point 2 r) -> Bool
forall a. Eq a => a -> a -> Bool
== (Point 2 r, Point 2 r)
q Bool -> Bool -> Bool
&& NonEmpty (LineSegment 2 p r)
pa NonEmpty (LineSegment 2 p r)
-> NonEmpty (LineSegment 2 p r) -> Bool
`sameElements` NonEmpty (LineSegment 2 p r)
qa)
                        (Map (Point 2 r, Point 2 r) (NonEmpty (LineSegment 2 p r))
-> [((Point 2 r, Point 2 r), NonEmpty (LineSegment 2 p r))]
forall k a. Map k a -> [(k, a)]
Map.toAscList Map (Point 2 r, Point 2 r) (NonEmpty (LineSegment 2 p r))
xs) (Map (Point 2 r, Point 2 r) (NonEmpty (LineSegment 2 p r))
-> [((Point 2 r, Point 2 r), NonEmpty (LineSegment 2 p r))]
forall k a. Map k a -> [(k, a)]
Map.toAscList Map (Point 2 r, Point 2 r) (NonEmpty (LineSegment 2 p r))
ys)

      g :: NonEmpty (LineSegment 2 p r) -> [LineSegment 2 p r]
g = [LineSegment 2 p r] -> [LineSegment 2 p r]
forall a. Eq a => [a] -> [a]
L.nub ([LineSegment 2 p r] -> [LineSegment 2 p r])
-> (NonEmpty (LineSegment 2 p r) -> [LineSegment 2 p r])
-> NonEmpty (LineSegment 2 p r)
-> [LineSegment 2 p r]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty (LineSegment 2 p r) -> [LineSegment 2 p r]
forall a. NonEmpty a -> [a]
NonEmpty.toList
      sameElements :: NonEmpty (LineSegment 2 p r)
-> NonEmpty (LineSegment 2 p r) -> Bool
sameElements (NonEmpty (LineSegment 2 p r) -> [LineSegment 2 p r]
g -> [LineSegment 2 p r]
xs) (NonEmpty (LineSegment 2 p r) -> [LineSegment 2 p r]
g -> [LineSegment 2 p r]
ys) = [LineSegment 2 p r] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
L.null ([LineSegment 2 p r] -> Bool) -> [LineSegment 2 p r] -> Bool
forall a b. (a -> b) -> a -> b
$ ([LineSegment 2 p r]
xs [LineSegment 2 p r] -> [LineSegment 2 p r] -> [LineSegment 2 p r]
forall a. Eq a => [a] -> [a] -> [a]
L.\\ [LineSegment 2 p r]
ys) [LineSegment 2 p r] -> [LineSegment 2 p r] -> [LineSegment 2 p r]
forall a. [a] -> [a] -> [a]
++ ([LineSegment 2 p r]
ys [LineSegment 2 p r] -> [LineSegment 2 p r] -> [LineSegment 2 p r]
forall a. Eq a => [a] -> [a] -> [a]
L.\\ [LineSegment 2 p r]
xs)


instance (NFData p, NFData r) => NFData (Associated p r)




associated       :: Ord r
                 => [LineSegment 2 p r] -> [LineSegment 2 p r] -> Associated p r
associated :: [LineSegment 2 p r] -> [LineSegment 2 p r] -> Associated p r
associated [LineSegment 2 p r]
es [LineSegment 2 p r]
is = Set' (LineSegment 2 p r)
-> Set' (LineSegment 2 p r) -> Associated p r
forall p r.
Set' (LineSegment 2 p r)
-> Set' (LineSegment 2 p r) -> Associated p r
Associated ([LineSegment 2 p r]
-> Map
     (StartCore (LineSegment 2 p r), EndCore (LineSegment 2 p r))
     (NonEmpty (LineSegment 2 p r))
f [LineSegment 2 p r]
es) ([LineSegment 2 p r]
-> Map
     (StartCore (LineSegment 2 p r), EndCore (LineSegment 2 p r))
     (NonEmpty (LineSegment 2 p r))
f [LineSegment 2 p r]
is)
  where
    f :: [LineSegment 2 p r]
-> Map
     (StartCore (LineSegment 2 p r), EndCore (LineSegment 2 p r))
     (NonEmpty (LineSegment 2 p r))
f = (LineSegment 2 p r
 -> Map
      (StartCore (LineSegment 2 p r), EndCore (LineSegment 2 p r))
      (NonEmpty (LineSegment 2 p r))
 -> Map
      (StartCore (LineSegment 2 p r), EndCore (LineSegment 2 p r))
      (NonEmpty (LineSegment 2 p r)))
-> Map
     (StartCore (LineSegment 2 p r), EndCore (LineSegment 2 p r))
     (NonEmpty (LineSegment 2 p r))
-> [LineSegment 2 p r]
-> Map
     (StartCore (LineSegment 2 p r), EndCore (LineSegment 2 p r))
     (NonEmpty (LineSegment 2 p r))
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\LineSegment 2 p r
s -> (NonEmpty (LineSegment 2 p r)
 -> NonEmpty (LineSegment 2 p r) -> NonEmpty (LineSegment 2 p r))
-> (StartCore (LineSegment 2 p r), EndCore (LineSegment 2 p r))
-> NonEmpty (LineSegment 2 p r)
-> Map
     (StartCore (LineSegment 2 p r), EndCore (LineSegment 2 p r))
     (NonEmpty (LineSegment 2 p r))
-> Map
     (StartCore (LineSegment 2 p r), EndCore (LineSegment 2 p r))
     (NonEmpty (LineSegment 2 p r))
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith NonEmpty (LineSegment 2 p r)
-> NonEmpty (LineSegment 2 p r) -> NonEmpty (LineSegment 2 p r)
forall a. Semigroup a => a -> a -> a
(<>) (LineSegment 2 p r
-> (StartCore (LineSegment 2 p r), EndCore (LineSegment 2 p r))
forall s. (HasEnd s, HasStart s) => s -> (StartCore s, EndCore s)
endPoints' LineSegment 2 p r
s) (LineSegment 2 p r
s LineSegment 2 p r
-> [LineSegment 2 p r] -> NonEmpty (LineSegment 2 p r)
forall a. a -> [a] -> NonEmpty a
:| [])) Map
  (StartCore (LineSegment 2 p r), EndCore (LineSegment 2 p r))
  (NonEmpty (LineSegment 2 p r))
forall a. Monoid a => a
mempty


endPointOf :: Associated p r -> [LineSegment 2 p r]
endPointOf :: Associated p r -> [LineSegment 2 p r]
endPointOf = (NonEmpty (LineSegment 2 p r) -> [LineSegment 2 p r])
-> [NonEmpty (LineSegment 2 p r)] -> [LineSegment 2 p r]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap NonEmpty (LineSegment 2 p r) -> [LineSegment 2 p r]
forall a. NonEmpty a -> [a]
NonEmpty.toList ([NonEmpty (LineSegment 2 p r)] -> [LineSegment 2 p r])
-> (Associated p r -> [NonEmpty (LineSegment 2 p r)])
-> Associated p r
-> [LineSegment 2 p r]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map (Point 2 r, Point 2 r) (NonEmpty (LineSegment 2 p r))
-> [NonEmpty (LineSegment 2 p r)]
forall k a. Map k a -> [a]
Map.elems (Map (Point 2 r, Point 2 r) (NonEmpty (LineSegment 2 p r))
 -> [NonEmpty (LineSegment 2 p r)])
-> (Associated p r
    -> Map (Point 2 r, Point 2 r) (NonEmpty (LineSegment 2 p r)))
-> Associated p r
-> [NonEmpty (LineSegment 2 p r)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Associated p r
-> Map (Point 2 r, Point 2 r) (NonEmpty (LineSegment 2 p r))
forall p r. Associated p r -> Set' (LineSegment 2 p r)
_endPointOf

interiorTo :: Associated p r -> [LineSegment 2 p r]
interiorTo :: Associated p r -> [LineSegment 2 p r]
interiorTo = (NonEmpty (LineSegment 2 p r) -> [LineSegment 2 p r])
-> [NonEmpty (LineSegment 2 p r)] -> [LineSegment 2 p r]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap NonEmpty (LineSegment 2 p r) -> [LineSegment 2 p r]
forall a. NonEmpty a -> [a]
NonEmpty.toList ([NonEmpty (LineSegment 2 p r)] -> [LineSegment 2 p r])
-> (Associated p r -> [NonEmpty (LineSegment 2 p r)])
-> Associated p r
-> [LineSegment 2 p r]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map (Point 2 r, Point 2 r) (NonEmpty (LineSegment 2 p r))
-> [NonEmpty (LineSegment 2 p r)]
forall k a. Map k a -> [a]
Map.elems (Map (Point 2 r, Point 2 r) (NonEmpty (LineSegment 2 p r))
 -> [NonEmpty (LineSegment 2 p r)])
-> (Associated p r
    -> Map (Point 2 r, Point 2 r) (NonEmpty (LineSegment 2 p r)))
-> Associated p r
-> [NonEmpty (LineSegment 2 p r)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Associated p r
-> Map (Point 2 r, Point 2 r) (NonEmpty (LineSegment 2 p r))
forall p r. Associated p r -> Set' (LineSegment 2 p r)
_interiorTo


instance Ord r => Semigroup (Associated p r) where
  (Associated Set' (LineSegment 2 p r)
es Set' (LineSegment 2 p r)
is) <> :: Associated p r -> Associated p r -> Associated p r
<> (Associated Set' (LineSegment 2 p r)
es' Set' (LineSegment 2 p r)
is') = Set' (LineSegment 2 p r)
-> Set' (LineSegment 2 p r) -> Associated p r
forall p r.
Set' (LineSegment 2 p r)
-> Set' (LineSegment 2 p r) -> Associated p r
Associated (Map (Point 2 r, Point 2 r) (NonEmpty (LineSegment 2 p r))
Set' (LineSegment 2 p r)
es Map (Point 2 r, Point 2 r) (NonEmpty (LineSegment 2 p r))
-> Map (Point 2 r, Point 2 r) (NonEmpty (LineSegment 2 p r))
-> Map (Point 2 r, Point 2 r) (NonEmpty (LineSegment 2 p r))
forall a. Semigroup a => a -> a -> a
<> Map (Point 2 r, Point 2 r) (NonEmpty (LineSegment 2 p r))
Set' (LineSegment 2 p r)
es') (Map (Point 2 r, Point 2 r) (NonEmpty (LineSegment 2 p r))
Set' (LineSegment 2 p r)
is Map (Point 2 r, Point 2 r) (NonEmpty (LineSegment 2 p r))
-> Map (Point 2 r, Point 2 r) (NonEmpty (LineSegment 2 p r))
-> Map (Point 2 r, Point 2 r) (NonEmpty (LineSegment 2 p r))
forall a. Semigroup a => a -> a -> a
<> Map (Point 2 r, Point 2 r) (NonEmpty (LineSegment 2 p r))
Set' (LineSegment 2 p r)
is')

instance Ord r => Monoid (Associated p r) where
  mempty :: Associated p r
mempty = Set' (LineSegment 2 p r)
-> Set' (LineSegment 2 p r) -> Associated p r
forall p r.
Set' (LineSegment 2 p r)
-> Set' (LineSegment 2 p r) -> Associated p r
Associated Set' (LineSegment 2 p r)
forall a. Monoid a => a
mempty Set' (LineSegment 2 p r)
forall a. Monoid a => a
mempty
  mappend :: Associated p r -> Associated p r -> Associated p r
mappend = Associated p r -> Associated p r -> Associated p r
forall a. Semigroup a => a -> a -> a
(<>)

type Intersections p r = Map.Map (Point 2 r) (Associated p r)

data IntersectionPoint p r =
  IntersectionPoint { IntersectionPoint p r -> Point 2 r
_intersectionPoint :: !(Point 2 r)
                    , IntersectionPoint p r -> Associated p r
_associatedSegs    :: !(Associated p r)
                    } deriving (Int -> IntersectionPoint p r -> ShowS
[IntersectionPoint p r] -> ShowS
IntersectionPoint p r -> String
(Int -> IntersectionPoint p r -> ShowS)
-> (IntersectionPoint p r -> String)
-> ([IntersectionPoint p r] -> ShowS)
-> Show (IntersectionPoint p r)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall p r.
(Show r, Show p) =>
Int -> IntersectionPoint p r -> ShowS
forall p r. (Show r, Show p) => [IntersectionPoint p r] -> ShowS
forall p r. (Show r, Show p) => IntersectionPoint p r -> String
showList :: [IntersectionPoint p r] -> ShowS
$cshowList :: forall p r. (Show r, Show p) => [IntersectionPoint p r] -> ShowS
show :: IntersectionPoint p r -> String
$cshow :: forall p r. (Show r, Show p) => IntersectionPoint p r -> String
showsPrec :: Int -> IntersectionPoint p r -> ShowS
$cshowsPrec :: forall p r.
(Show r, Show p) =>
Int -> IntersectionPoint p r -> ShowS
Show,IntersectionPoint p r -> IntersectionPoint p r -> Bool
(IntersectionPoint p r -> IntersectionPoint p r -> Bool)
-> (IntersectionPoint p r -> IntersectionPoint p r -> Bool)
-> Eq (IntersectionPoint p r)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall p r.
(Eq r, Eq p) =>
IntersectionPoint p r -> IntersectionPoint p r -> Bool
/= :: IntersectionPoint p r -> IntersectionPoint p r -> Bool
$c/= :: forall p r.
(Eq r, Eq p) =>
IntersectionPoint p r -> IntersectionPoint p r -> Bool
== :: IntersectionPoint p r -> IntersectionPoint p r -> Bool
$c== :: forall p r.
(Eq r, Eq p) =>
IntersectionPoint p r -> IntersectionPoint p r -> Bool
Eq)
makeLenses ''IntersectionPoint


-- | reports true if there is at least one segment for which this intersection
-- point is interior.
--
-- \(O(1)\)
isEndPointIntersection :: Associated p r -> Bool
isEndPointIntersection :: Associated p r -> Bool
isEndPointIntersection = Map (Point 2 r, Point 2 r) (NonEmpty (LineSegment 2 p r)) -> Bool
forall k a. Map k a -> Bool
Map.null (Map (Point 2 r, Point 2 r) (NonEmpty (LineSegment 2 p r)) -> Bool)
-> (Associated p r
    -> Map (Point 2 r, Point 2 r) (NonEmpty (LineSegment 2 p r)))
-> Associated p r
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Associated p r
-> Map (Point 2 r, Point 2 r) (NonEmpty (LineSegment 2 p r))
forall p r. Associated p r -> Set' (LineSegment 2 p r)
_interiorTo


-- newtype E a b = E (a -> b)