{-# LANGUAGE ScopedTypeVariables #-}
-- | Line segment intersections in \(O(n^2)\) by checking
--   all pairs.
module Algorithms.Geometry.LineSegmentIntersection.Naive
  ( intersections
  ) where

import           Algorithms.Geometry.LineSegmentIntersection.Types
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.Map as M
import           Data.Vinyl
import           Data.Vinyl.CoRec


-- | Compute all intersections (naively)
--
-- \(O(n^2)\)
intersections :: forall r p. (Ord r, Fractional r)
              => [LineSegment 2 p r] -> Intersections p r
intersections :: [LineSegment 2 p r] -> Intersections p r
intersections = ((LineSegment 2 p r, LineSegment 2 p r)
 -> Intersections p r -> Intersections p r)
-> Intersections p r
-> [(LineSegment 2 p r, LineSegment 2 p r)]
-> Intersections p r
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (LineSegment 2 p r, LineSegment 2 p r)
-> Intersections p r -> Intersections p r
forall r p.
(Ord r, Fractional r) =>
(LineSegment 2 p r, LineSegment 2 p r)
-> Intersections p r -> Intersections p r
collect Intersections p r
forall a. Monoid a => a
mempty ([(LineSegment 2 p r, LineSegment 2 p r)] -> Intersections p r)
-> ([LineSegment 2 p r]
    -> [(LineSegment 2 p r, LineSegment 2 p r)])
-> [LineSegment 2 p r]
-> Intersections p r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [LineSegment 2 p r] -> [(LineSegment 2 p r, LineSegment 2 p r)]
forall a. [a] -> [(a, a)]
pairs

-- | Test if the two segments intersect, and if so add the segment to the map
collect          :: (Ord r, Fractional r)
                 => (LineSegment 2 p r, LineSegment 2 p r)
                 -> Intersections p r -> Intersections p r
collect :: (LineSegment 2 p r, LineSegment 2 p r)
-> Intersections p r -> Intersections p r
collect (LineSegment 2 p r
s,LineSegment 2 p r
s') Intersections p r
m = CoRec Identity '[NoIntersection, Point 2 r, LineSegment 2 p r]
-> Handlers
     '[NoIntersection, Point 2 r, LineSegment 2 p r] (Intersections p r)
-> Intersections p r
forall (ts :: [*]) b. CoRec Identity ts -> Handlers ts b -> b
match (LineSegment 2 p r
s 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
s') (Handlers
   '[NoIntersection, Point 2 r, LineSegment 2 p r] (Intersections p r)
 -> Intersections p r)
-> Handlers
     '[NoIntersection, Point 2 r, LineSegment 2 p r] (Intersections p r)
-> Intersections p r
forall a b. (a -> b) -> a -> b
$
     (NoIntersection -> Intersections p r)
-> Handler (Intersections p r) NoIntersection
forall b a. (a -> b) -> Handler b a
H (\NoIntersection
NoIntersection -> Intersections p r
m)
  Handler (Intersections p r) NoIntersection
-> Rec
     (Handler (Intersections p r)) '[Point 2 r, LineSegment 2 p r]
-> Handlers
     '[NoIntersection, Point 2 r, LineSegment 2 p r] (Intersections p r)
forall u (a :: u -> *) (r :: u) (rs :: [u]).
a r -> Rec a rs -> Rec a (r : rs)
:& (Point 2 r -> Intersections p r)
-> Handler (Intersections p r) (Point 2 r)
forall b a. (a -> b) -> Handler b a
H (\Point 2 r
p              -> LineSegment 2 p r
-> LineSegment 2 p r
-> Point 2 r
-> Intersections p r
-> Intersections p r
forall r p.
Ord r =>
LineSegment 2 p r
-> LineSegment 2 p r
-> Point 2 r
-> Intersections p r
-> Intersections p r
handlePoint LineSegment 2 p r
s LineSegment 2 p r
s' Point 2 r
p Intersections p r
m)
  Handler (Intersections p r) (Point 2 r)
-> Rec (Handler (Intersections p r)) '[LineSegment 2 p r]
-> Rec
     (Handler (Intersections p r)) '[Point 2 r, LineSegment 2 p r]
forall u (a :: u -> *) (r :: u) (rs :: [u]).
a r -> Rec a rs -> Rec a (r : rs)
:& (LineSegment 2 p r -> Intersections p r)
-> Handler (Intersections p r) (LineSegment 2 p r)
forall b a. (a -> b) -> Handler b a
H (\LineSegment 2 p r
s''            -> (Point 2 r -> Intersections p r -> Intersections p r)
-> Intersections p r -> [Point 2 r] -> Intersections p r
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (LineSegment 2 p r
-> LineSegment 2 p r
-> Point 2 r
-> Intersections p r
-> Intersections p r
forall r p.
Ord r =>
LineSegment 2 p r
-> LineSegment 2 p r
-> Point 2 r
-> Intersections p r
-> Intersections p r
handlePoint LineSegment 2 p r
s LineSegment 2 p r
s') Intersections p r
m [LineSegment 2 p r
s''LineSegment 2 p r
-> Getting (Point 2 r) (LineSegment 2 p r) (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))
-> 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))
-> Getting (Point 2 r) (LineSegment 2 p r) (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
s''LineSegment 2 p r
-> Getting (Point 2 r) (LineSegment 2 p r) (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))
-> 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))
-> Getting (Point 2 r) (LineSegment 2 p r) (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])
  Handler (Intersections p r) (LineSegment 2 p r)
-> Rec (Handler (Intersections p r)) '[]
-> Rec (Handler (Intersections p r)) '[LineSegment 2 p r]
forall u (a :: u -> *) (r :: u) (rs :: [u]).
a r -> Rec a rs -> Rec a (r : rs)
:& Rec (Handler (Intersections p r)) '[]
forall u (a :: u -> *). Rec a '[]
RNil

-- | Add s and s' to the map with key p
handlePoint        :: Ord r
                   => LineSegment 2 p r -> LineSegment 2 p r -> Point 2 r
                   -> Intersections p r -> Intersections p r
handlePoint :: LineSegment 2 p r
-> LineSegment 2 p r
-> Point 2 r
-> Intersections p r
-> Intersections p r
handlePoint LineSegment 2 p r
s LineSegment 2 p r
s' Point 2 r
p = Point 2 r
-> LineSegment 2 p r -> Intersections p r -> Intersections p r
forall r p.
Ord r =>
Point 2 r
-> LineSegment 2 p r -> Intersections p r -> Intersections p r
addTo Point 2 r
p LineSegment 2 p r
s (Intersections p r -> Intersections p r)
-> (Intersections p r -> Intersections p r)
-> Intersections p r
-> Intersections p r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Point 2 r
-> LineSegment 2 p r -> Intersections p r -> Intersections p r
forall r p.
Ord r =>
Point 2 r
-> LineSegment 2 p r -> Intersections p r -> Intersections p r
addTo Point 2 r
p LineSegment 2 p r
s'

-- | figure out which map to add the point to
addTo                  :: Ord r => Point 2 r -> LineSegment 2 p r
                       -> Intersections p r -> Intersections p r
addTo :: Point 2 r
-> LineSegment 2 p r -> Intersections p r -> Intersections p r
addTo Point 2 r
p LineSegment 2 p r
s
  | Point 2 r
p Point 2 r -> LineSegment 2 p r -> Bool
forall r p. Eq r => Point 2 r -> LineSegment 2 p r -> Bool
`isEndPointOf` LineSegment 2 p r
s = (Associated p r -> Associated p r -> Associated p r)
-> Point 2 r
-> Associated p r
-> Intersections p r
-> Intersections p r
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
M.insertWith Associated p r -> Associated p r -> Associated p r
forall a. Semigroup a => a -> a -> a
(<>) Point 2 r
p ([LineSegment 2 p r] -> [LineSegment 2 p r] -> Associated p r
forall r p.
Ord r =>
[LineSegment 2 p r] -> [LineSegment 2 p r] -> Associated p r
associated [LineSegment 2 p r
s] [])
  | Bool
otherwise          = (Associated p r -> Associated p r -> Associated p r)
-> Point 2 r
-> Associated p r
-> Intersections p r
-> Intersections p r
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
M.insertWith Associated p r -> Associated p r -> Associated p r
forall a. Semigroup a => a -> a -> a
(<>) Point 2 r
p ([LineSegment 2 p r] -> [LineSegment 2 p r] -> Associated p r
forall r p.
Ord r =>
[LineSegment 2 p r] -> [LineSegment 2 p r] -> Associated p r
associated [] [LineSegment 2 p r
s])

isEndPointOf       :: Eq r => Point 2 r -> LineSegment 2 p r -> Bool
Point 2 r
p isEndPointOf :: Point 2 r -> LineSegment 2 p r -> Bool
`isEndPointOf` LineSegment 2 p r
s = Point 2 r
p Point 2 r -> Point 2 r -> Bool
forall a. Eq a => a -> a -> Bool
== LineSegment 2 p r
sLineSegment 2 p r
-> Getting (Point 2 r) (LineSegment 2 p r) (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))
-> 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))
-> Getting (Point 2 r) (LineSegment 2 p r) (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 Bool -> Bool -> Bool
|| Point 2 r
p Point 2 r -> Point 2 r -> Bool
forall a. Eq a => a -> a -> Bool
== LineSegment 2 p r
sLineSegment 2 p r
-> Getting (Point 2 r) (LineSegment 2 p r) (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))
-> 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))
-> Getting (Point 2 r) (LineSegment 2 p r) (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


pairs        :: [a] -> [(a, a)]
pairs :: [a] -> [(a, a)]
pairs []     = []
pairs (a
x:[a]
xs) = (a -> (a, a)) -> [a] -> [(a, a)]
forall a b. (a -> b) -> [a] -> [b]
map (a
x,) [a]
xs [(a, a)] -> [(a, a)] -> [(a, a)]
forall a. [a] -> [a] -> [a]
++ [a] -> [(a, a)]
forall a. [a] -> [(a, a)]
pairs [a]
xs