{-# 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.Util
import           Data.Vinyl
import           Data.Vinyl.CoRec
import qualified Data.List as List

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

-- | Compute all intersections (naively)
--
-- \(O(n^2)\)
intersections :: forall r p 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 = (Two (LineSegment 2 p r :+ e)
 -> Intersections p r e -> Intersections p r e)
-> Intersections p r e
-> [Two (LineSegment 2 p r :+ e)]
-> Intersections p r e
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Two (LineSegment 2 p r :+ e)
-> Intersections p r e -> Intersections p r e
forall r p e.
(Ord r, Fractional r) =>
Two (LineSegment 2 p r :+ e)
-> Intersections p r e -> Intersections p r e
collect Intersections p r e
forall a. Monoid a => a
mempty ([Two (LineSegment 2 p r :+ e)] -> Intersections p r e)
-> ([LineSegment 2 p r :+ e] -> [Two (LineSegment 2 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] -> [Two (LineSegment 2 p r :+ e)]
forall a. [a] -> [Two a]
uniquePairs

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


topEndPoint :: Ord r => LineSegment 2 p r -> Point 2 r
topEndPoint :: LineSegment 2 p r -> Point 2 r
topEndPoint (LineSegment' (Point 2 r
a :+ p
_) (Point 2 r
b :+ p
_)) = (Point 2 r -> Point 2 r -> Ordering) -> [Point 2 r] -> Point 2 r
forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
List.minimumBy Point 2 r -> Point 2 r -> Ordering
forall r. Ord r => Point 2 r -> Point 2 r -> Ordering
ordPoints [Point 2 r
a,Point 2 r
b]


-- | Add s and s' to the map with key p
handlePoint        :: (Ord r, Fractional r)
                   => LineSegment 2 p r :+ e
                   -> LineSegment 2 p r :+ e
                   -> Point 2 r
                   -> Intersections p r e -> Intersections p r e
handlePoint :: (LineSegment 2 p r :+ e)
-> (LineSegment 2 p r :+ e)
-> Point 2 r
-> Intersections p r e
-> Intersections p r e
handlePoint LineSegment 2 p r :+ e
s LineSegment 2 p r :+ e
s' Point 2 r
p = (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 (Point 2 r -> (LineSegment 2 p r :+ e) -> Associated p r e
forall r p e.
(Ord r, Fractional r) =>
Point 2 r -> (LineSegment 2 p r :+ e) -> Associated p r e
mkAssociated Point 2 r
p LineSegment 2 p r :+ e
s Associated p r e -> Associated p r e -> Associated p r e
forall a. Semigroup a => a -> a -> a
<> Point 2 r -> (LineSegment 2 p r :+ e) -> Associated p r e
forall r p e.
(Ord r, Fractional r) =>
Point 2 r -> (LineSegment 2 p r :+ e) -> Associated p r e
mkAssociated Point 2 r
p LineSegment 2 p r :+ e
s')


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)