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

import Data.Maybe(fromJust)
import Control.Lens((^.))
import Data.Ext
import Data.Geometry
import Algorithms.Geometry.ConvexHull.GrahamScan
import Data.List.NonEmpty(NonEmpty(..))
import qualified Data.List.NonEmpty as NonEmpty
import Data.Geometry.Duality
import Data.Vinyl.CoRec

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

type Envelope a r = NonEmpty (Line 2 r :+ a)

-- | Given a list of non-vertical lines, computes the lower envelope using
-- duality. The lines are given in left to right order.
--
-- \(O(n\log n)\)
lowerEnvelope :: (Ord r, Fractional r) => NonEmpty (Line 2 r :+ a) -> Envelope a r
lowerEnvelope :: NonEmpty (Line 2 r :+ a) -> NonEmpty (Line 2 r :+ a)
lowerEnvelope = NonEmpty (Line 2 r :+ a) -> NonEmpty (Line 2 r :+ a)
forall a. NonEmpty a -> NonEmpty a
NonEmpty.reverse (NonEmpty (Line 2 r :+ a) -> NonEmpty (Line 2 r :+ a))
-> (NonEmpty (Line 2 r :+ a) -> NonEmpty (Line 2 r :+ a))
-> NonEmpty (Line 2 r :+ a)
-> NonEmpty (Line 2 r :+ a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UpperHullAlgorithm (Line 2 r :+ a) r
-> NonEmpty (Line 2 r :+ a) -> NonEmpty (Line 2 r :+ a)
forall r a.
(Fractional r, Eq r) =>
UpperHullAlgorithm (Line 2 r :+ a) r
-> NonEmpty (Line 2 r :+ a) -> NonEmpty (Line 2 r :+ a)
lowerEnvelopeWith UpperHullAlgorithm (Line 2 r :+ a) r
forall r p.
(Ord r, Num r) =>
NonEmpty (Point 2 r :+ p) -> NonEmpty (Point 2 r :+ p)
upperHull


type UpperHullAlgorithm a r = NonEmpty (Point 2 r :+ a) -> NonEmpty (Point 2 r :+ a)

-- | Given a list of non-vertical lines, computes the lower envelope by computing
-- the upper convex hull. It uses the given algorithm to do so
--
-- running time: O(time required by the given upper hull algorithm)
lowerEnvelopeWith        :: (Fractional r, Eq r)
                         => UpperHullAlgorithm (Line 2 r :+ a) r
                         -> NonEmpty (Line 2 r :+ a) -> Envelope a r
lowerEnvelopeWith :: UpperHullAlgorithm (Line 2 r :+ a) r
-> NonEmpty (Line 2 r :+ a) -> NonEmpty (Line 2 r :+ a)
lowerEnvelopeWith UpperHullAlgorithm (Line 2 r :+ a) r
chAlgo = NonEmpty (Point 2 r :+ (Line 2 r :+ a)) -> NonEmpty (Line 2 r :+ a)
forall core extra. NonEmpty (core :+ extra) -> NonEmpty extra
fromPts (NonEmpty (Point 2 r :+ (Line 2 r :+ a))
 -> NonEmpty (Line 2 r :+ a))
-> (NonEmpty (Line 2 r :+ a)
    -> NonEmpty (Point 2 r :+ (Line 2 r :+ a)))
-> NonEmpty (Line 2 r :+ a)
-> NonEmpty (Line 2 r :+ a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UpperHullAlgorithm (Line 2 r :+ a) r
chAlgo UpperHullAlgorithm (Line 2 r :+ a) r
-> (NonEmpty (Line 2 r :+ a)
    -> NonEmpty (Point 2 r :+ (Line 2 r :+ a)))
-> NonEmpty (Line 2 r :+ a)
-> NonEmpty (Point 2 r :+ (Line 2 r :+ a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty (Line 2 r :+ a) -> NonEmpty (Point 2 r :+ (Line 2 r :+ a))
forall extra.
NonEmpty (Line 2 r :+ extra)
-> NonEmpty (Point 2 r :+ (Line 2 r :+ extra))
toPts
  where
    toPts :: NonEmpty (Line 2 r :+ extra)
-> NonEmpty (Point 2 r :+ (Line 2 r :+ extra))
toPts   = ((Line 2 r :+ extra) -> Point 2 r :+ (Line 2 r :+ extra))
-> NonEmpty (Line 2 r :+ extra)
-> NonEmpty (Point 2 r :+ (Line 2 r :+ extra))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Line 2 r :+ extra
l -> Line 2 r -> Point 2 r
forall r. (Fractional r, Eq r) => Line 2 r -> Point 2 r
dualPoint' (Line 2 r :+ extra
l(Line 2 r :+ extra)
-> Getting (Line 2 r) (Line 2 r :+ extra) (Line 2 r) -> Line 2 r
forall s a. s -> Getting a s a -> a
^.Getting (Line 2 r) (Line 2 r :+ extra) (Line 2 r)
forall core extra core'.
Lens (core :+ extra) (core' :+ extra) core core'
core) Point 2 r
-> (Line 2 r :+ extra) -> Point 2 r :+ (Line 2 r :+ extra)
forall core extra. core -> extra -> core :+ extra
:+ Line 2 r :+ extra
l)
    fromPts :: NonEmpty (core :+ extra) -> NonEmpty extra
fromPts = ((core :+ extra) -> extra)
-> NonEmpty (core :+ extra) -> NonEmpty extra
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((core :+ extra) -> Getting extra (core :+ extra) extra -> extra
forall s a. s -> Getting a s a -> a
^.Getting extra (core :+ extra) extra
forall core extra extra'.
Lens (core :+ extra) (core :+ extra') extra extra'
extra)

-- | Computes the vertices of the envelope, in left to right order
vertices   :: (Ord r, Fractional r) => Envelope a r -> [Point 2 r :+ (a,a)]
vertices :: Envelope a r -> [Point 2 r :+ (a, a)]
vertices Envelope a r
e = ((Line 2 r :+ a) -> (Line 2 r :+ a) -> Point 2 r :+ (a, a))
-> [Line 2 r :+ a] -> [Line 2 r :+ a] -> [Point 2 r :+ (a, a)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Line 2 r :+ a) -> (Line 2 r :+ a) -> Point 2 r :+ (a, a)
forall r a.
(Ord r, Fractional r) =>
(Line 2 r :+ a) -> (Line 2 r :+ a) -> Point 2 r :+ (a, a)
intersect' (Envelope a r -> [Line 2 r :+ a]
forall a. NonEmpty a -> [a]
NonEmpty.toList Envelope a r
e) (Envelope a r -> [Line 2 r :+ a]
forall a. NonEmpty a -> [a]
NonEmpty.tail Envelope a r
e)


-- | Given two non-parallel lines, compute the intersection point and
-- return the pair of a's associated with the lines
intersect'                     :: forall r a. (Ord r, Fractional r)
                               => Line 2 r :+ a -> Line 2 r :+ a -> Point 2 r :+ (a,a)
intersect' :: (Line 2 r :+ a) -> (Line 2 r :+ a) -> Point 2 r :+ (a, a)
intersect' (Line 2 r
l :+ a
le) (Line 2 r
r :+ a
re) = (Point 2 r -> (a, a) -> Point 2 r :+ (a, a)
forall core extra. core -> extra -> core :+ extra
:+ (a
le,a
re)) (Point 2 r -> Point 2 r :+ (a, a))
-> (CoRec Identity '[NoIntersection, Point 2 r, Line 2 r]
    -> Point 2 r)
-> CoRec Identity '[NoIntersection, Point 2 r, Line 2 r]
-> Point 2 r :+ (a, a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe (Point 2 r) -> Point 2 r
forall a. HasCallStack => Maybe a -> a
fromJust
                               (Maybe (Point 2 r) -> Point 2 r)
-> (CoRec Identity '[NoIntersection, Point 2 r, Line 2 r]
    -> Maybe (Point 2 r))
-> CoRec Identity '[NoIntersection, Point 2 r, Line 2 r]
-> Point 2 r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (ts :: [*]).
NatToInt (RIndex (Point 2 r) ts) =>
CoRec Identity ts -> Maybe (Point 2 r)
forall t (ts :: [*]).
NatToInt (RIndex t ts) =>
CoRec Identity ts -> Maybe t
asA @(Point 2 r) (CoRec Identity '[NoIntersection, Point 2 r, Line 2 r]
 -> Point 2 r :+ (a, a))
-> CoRec Identity '[NoIntersection, Point 2 r, Line 2 r]
-> Point 2 r :+ (a, a)
forall a b. (a -> b) -> a -> b
$ Line 2 r
l Line 2 r -> Line 2 r -> Intersection (Line 2 r) (Line 2 r)
forall g h. IsIntersectableWith g h => g -> h -> Intersection g h
`intersect` Line 2 r
r