--------------------------------------------------------------------------------
-- |
-- Module      :  Algorithms.Geometry.ConvexHull.JarvisMarch
-- Copyright   :  (C) Frank Staals
-- License     :  see the LICENSE file
-- Maintainer  :  Frank Staals
--------------------------------------------------------------------------------
module Algorithms.Geometry.ConvexHull.JarvisMarch(
    convexHull

  , upperHull, upperHull'
  , lowerHull, lowerHull'
  , steepestCcwFrom, steepestCwFrom
  ) where

import           Control.Lens ((^.))
import           Data.Bifunctor
import           Data.Ext
import           Data.Foldable
import           Data.Geometry.Point
import           Data.Geometry.Polygon
import           Data.Geometry.Polygon.Convex (ConvexPolygon(..))
import           Data.Geometry.Vector
import qualified Data.List as List
import           Data.List.NonEmpty (NonEmpty(..), (<|))
import qualified Data.List.NonEmpty as NonEmpty
import           Data.Ord (comparing, Down(..))
import           Data.Semigroup.Foldable

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

-- | Compute the convexhull using JarvisMarch. The resulting polygon
-- is given in clockwise order.
--
-- running time: \(O(nh)\), where \(n\) is the number of input points
-- and \(h\) is the complexity of the hull.
convexHull            :: (Ord r, Num r)
                      => NonEmpty (Point 2 r :+ p) -> ConvexPolygon p r
convexHull :: NonEmpty (Point 2 r :+ p) -> ConvexPolygon p r
convexHull (Point 2 r :+ p
p :| []) = SimplePolygon p r -> ConvexPolygon p r
forall p r. SimplePolygon p r -> ConvexPolygon p r
ConvexPolygon (SimplePolygon p r -> ConvexPolygon p r)
-> ([Point 2 r :+ p] -> SimplePolygon p r)
-> [Point 2 r :+ p]
-> ConvexPolygon p r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Point 2 r :+ p] -> SimplePolygon p r
forall r p. [Point 2 r :+ p] -> SimplePolygon p r
unsafeFromPoints ([Point 2 r :+ p] -> ConvexPolygon p r)
-> [Point 2 r :+ p] -> ConvexPolygon p r
forall a b. (a -> b) -> a -> b
$ [Point 2 r :+ p
p]
convexHull NonEmpty (Point 2 r :+ p)
pts       = SimplePolygon p r -> ConvexPolygon p r
forall p r. SimplePolygon p r -> ConvexPolygon p r
ConvexPolygon (SimplePolygon p r -> ConvexPolygon p r)
-> ([Point 2 r :+ p] -> SimplePolygon p r)
-> [Point 2 r :+ p]
-> ConvexPolygon p r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Point 2 r :+ p] -> SimplePolygon p r
forall r p. [Point 2 r :+ p] -> SimplePolygon p r
unsafeFromPoints ([Point 2 r :+ p] -> ConvexPolygon p r)
-> [Point 2 r :+ p] -> ConvexPolygon p r
forall a b. (a -> b) -> a -> b
$ [Point 2 r :+ p]
uh [Point 2 r :+ p] -> [Point 2 r :+ p] -> [Point 2 r :+ p]
forall a. Semigroup a => a -> a -> a
<> [Point 2 r :+ p] -> [Point 2 r :+ p]
forall a. [a] -> [a]
reverse [Point 2 r :+ p]
lh
  where
    lh :: [Point 2 r :+ p]
lh = case [Point 2 r :+ p] -> Maybe (NonEmpty (Point 2 r :+ p))
forall a. [a] -> Maybe (NonEmpty a)
NonEmpty.nonEmpty (NonEmpty (Point 2 r :+ p) -> [Point 2 r :+ p]
forall a. NonEmpty a -> [a]
NonEmpty.init (NonEmpty (Point 2 r :+ p) -> [Point 2 r :+ p])
-> NonEmpty (Point 2 r :+ p) -> [Point 2 r :+ p]
forall a b. (a -> b) -> a -> b
$ NonEmpty (Point 2 r :+ p) -> NonEmpty (Point 2 r :+ p)
forall r p.
(Num r, Ord r) =>
NonEmpty (Point 2 r :+ p) -> NonEmpty (Point 2 r :+ p)
lowerHull NonEmpty (Point 2 r :+ p)
pts) of
           Maybe (NonEmpty (Point 2 r :+ p))
Nothing       -> []
           Just (Point 2 r :+ p
_:|[Point 2 r :+ p]
lh') -> [Point 2 r :+ p]
lh'
    uh :: [Point 2 r :+ p]
uh = NonEmpty (Point 2 r :+ p) -> [Point 2 r :+ p]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (NonEmpty (Point 2 r :+ p) -> [Point 2 r :+ p])
-> NonEmpty (Point 2 r :+ p) -> [Point 2 r :+ p]
forall a b. (a -> b) -> a -> b
$ NonEmpty (Point 2 r :+ p) -> NonEmpty (Point 2 r :+ p)
forall r p.
(Num r, Ord r) =>
NonEmpty (Point 2 r :+ p) -> NonEmpty (Point 2 r :+ p)
upperHull NonEmpty (Point 2 r :+ p)
pts

                       -- note that fromList is afe since ps contains at least two elements
  -- where
  --   SP p@(c :+ _) pts = minViewBy incXdecY ps
  --   takeWhile' pf (x :| xs) = x : takeWhile pf xs

upperHull     ::  (Num r, Ord r) =>  NonEmpty (Point 2 r :+ p) -> NonEmpty (Point 2 r :+ p)
upperHull :: NonEmpty (Point 2 r :+ p) -> NonEmpty (Point 2 r :+ p)
upperHull NonEmpty (Point 2 r :+ p)
pts = ((Point 2 r :+ p) -> (Point 2 r :+ p) -> Ordering)
-> ((Point 2 r :+ p)
    -> NonEmpty (Point 2 r :+ p) -> Point 2 r :+ p)
-> (Point 2 r :+ p)
-> [Point 2 r :+ p]
-> NonEmpty (Point 2 r :+ p)
forall a.
(a -> a -> Ordering)
-> (a -> NonEmpty a -> a) -> a -> [a] -> NonEmpty a
repeatedly (Point 2 r :+ p) -> (Point 2 r :+ p) -> Ordering
forall extra.
(Point 2 r :+ extra) -> (Point 2 r :+ extra) -> Ordering
cmp (Point 2 r :+ p) -> NonEmpty (Point 2 r :+ p) -> Point 2 r :+ p
forall r a b.
(Ord r, Num r) =>
(Point 2 r :+ a) -> NonEmpty (Point 2 r :+ b) -> Point 2 r :+ b
steepestCwFrom Point 2 r :+ p
s [Point 2 r :+ p]
rest
  where
    (Point 2 r :+ p
s:[Point 2 r :+ p]
_ :+ [Point 2 r :+ p]
rest) = ((Point 2 r :+ p) -> (Point 2 r :+ p) -> Ordering)
-> [Point 2 r :+ p] -> [Point 2 r :+ p] :+ [Point 2 r :+ p]
forall a. (a -> a -> Ordering) -> [a] -> [a] :+ [a]
extractMinimaBy (Point 2 r :+ p) -> (Point 2 r :+ p) -> Ordering
forall extra.
(Point 2 r :+ extra) -> (Point 2 r :+ extra) -> Ordering
cmp (NonEmpty (Point 2 r :+ p) -> [Point 2 r :+ p]
forall a. NonEmpty a -> [a]
NonEmpty.toList NonEmpty (Point 2 r :+ p)
pts)
    cmp :: (Point 2 r :+ extra) -> (Point 2 r :+ extra) -> Ordering
cmp           = ((Point 2 r :+ extra) -> (r, Down r))
-> (Point 2 r :+ extra) -> (Point 2 r :+ extra) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (\(Point2 r
x r
y :+ extra
_) -> (r
x, r -> Down r
forall a. a -> Down a
Down r
y))
                    -- start from the topmost point that has minimum x-coord
                    -- also use cmp as the comparator, so that we also select the last
                    -- vertical segment.

-- | Upepr hull from left to right, without any vertical segments.
upperHull'     ::  (Num r, Ord r) =>  NonEmpty (Point 2 r :+ p) -> NonEmpty (Point 2 r :+ p)
upperHull' :: NonEmpty (Point 2 r :+ p) -> NonEmpty (Point 2 r :+ p)
upperHull' NonEmpty (Point 2 r :+ p)
pts = NonEmpty (Point 2 r :+ p) -> NonEmpty (Point 2 r :+ p)
forall r p.
Eq r =>
NonEmpty (Point 2 r :+ p) -> NonEmpty (Point 2 r :+ p)
pruneVertical (NonEmpty (Point 2 r :+ p) -> NonEmpty (Point 2 r :+ p))
-> NonEmpty (Point 2 r :+ p) -> NonEmpty (Point 2 r :+ p)
forall a b. (a -> b) -> a -> b
$ ((Point 2 r :+ p) -> (Point 2 r :+ p) -> Ordering)
-> ((Point 2 r :+ p)
    -> NonEmpty (Point 2 r :+ p) -> Point 2 r :+ p)
-> (Point 2 r :+ p)
-> [Point 2 r :+ p]
-> NonEmpty (Point 2 r :+ p)
forall a.
(a -> a -> Ordering)
-> (a -> NonEmpty a -> a) -> a -> [a] -> NonEmpty a
repeatedly (Point 2 r :+ p) -> (Point 2 r :+ p) -> Ordering
forall extra.
(Point 2 r :+ extra) -> (Point 2 r :+ extra) -> Ordering
cmp (Point 2 r :+ p) -> NonEmpty (Point 2 r :+ p) -> Point 2 r :+ p
forall r a b.
(Ord r, Num r) =>
(Point 2 r :+ a) -> NonEmpty (Point 2 r :+ b) -> Point 2 r :+ b
steepestCwFrom Point 2 r :+ p
s [Point 2 r :+ p]
rest
  where
    (Point 2 r :+ p
s:[Point 2 r :+ p]
_ :+ [Point 2 r :+ p]
rest) = ((Point 2 r :+ p) -> (Point 2 r :+ p) -> Ordering)
-> [Point 2 r :+ p] -> [Point 2 r :+ p] :+ [Point 2 r :+ p]
forall a. (a -> a -> Ordering) -> [a] -> [a] :+ [a]
extractMinimaBy (Point 2 r :+ p) -> (Point 2 r :+ p) -> Ordering
forall extra.
(Point 2 r :+ extra) -> (Point 2 r :+ extra) -> Ordering
cmp0 (NonEmpty (Point 2 r :+ p) -> [Point 2 r :+ p]
forall a. NonEmpty a -> [a]
NonEmpty.toList NonEmpty (Point 2 r :+ p)
pts)
    cmp0 :: (Point 2 r :+ extra) -> (Point 2 r :+ extra) -> Ordering
cmp0          = ((Point 2 r :+ extra) -> (r, Down r))
-> (Point 2 r :+ extra) -> (Point 2 r :+ extra) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (\(Point2 r
x r
y :+ extra
_) -> (r
x, r -> Down r
forall a. a -> Down a
Down r
y))
                    -- start from the topmost point that has minimum x-coord
    cmp :: (Point 2 r :+ extra) -> (Point 2 r :+ extra) -> Ordering
cmp           = ((Point 2 r :+ extra) -> Point 2 r)
-> (Point 2 r :+ extra) -> (Point 2 r :+ extra) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing ((Point 2 r :+ extra)
-> Getting (Point 2 r) (Point 2 r :+ extra) (Point 2 r)
-> Point 2 r
forall s a. s -> Getting a s a -> a
^.Getting (Point 2 r) (Point 2 r :+ extra) (Point 2 r)
forall core extra core'.
Lens (core :+ extra) (core' :+ extra) core core'
core)
                    -- for the rest select them in normal
                    -- lexicographic order, this causes the last
                    -- vertical segment to be ignored.

-- | Computes the lower hull, from left to right. Includes vertical
-- segments at the start.
--
-- running time: \(O(nh)\), where \(h\) is the complexity of the hull.
lowerHull     ::  (Num r, Ord r) =>  NonEmpty (Point 2 r :+ p) -> NonEmpty (Point 2 r :+ p)
lowerHull :: NonEmpty (Point 2 r :+ p) -> NonEmpty (Point 2 r :+ p)
lowerHull NonEmpty (Point 2 r :+ p)
pts = NonEmpty (Point 2 r :+ p) -> NonEmpty (Point 2 r :+ p)
forall r p.
Eq r =>
NonEmpty (Point 2 r :+ p) -> NonEmpty (Point 2 r :+ p)
pruneVertical (NonEmpty (Point 2 r :+ p) -> NonEmpty (Point 2 r :+ p))
-> NonEmpty (Point 2 r :+ p) -> NonEmpty (Point 2 r :+ p)
forall a b. (a -> b) -> a -> b
$ ((Point 2 r :+ p) -> (Point 2 r :+ p) -> Ordering)
-> ((Point 2 r :+ p)
    -> NonEmpty (Point 2 r :+ p) -> Point 2 r :+ p)
-> (Point 2 r :+ p)
-> [Point 2 r :+ p]
-> NonEmpty (Point 2 r :+ p)
forall a.
(a -> a -> Ordering)
-> (a -> NonEmpty a -> a) -> a -> [a] -> NonEmpty a
repeatedly (Point 2 r :+ p) -> (Point 2 r :+ p) -> Ordering
forall extra.
(Point 2 r :+ extra) -> (Point 2 r :+ extra) -> Ordering
cmp (Point 2 r :+ p) -> NonEmpty (Point 2 r :+ p) -> Point 2 r :+ p
forall r a b.
(Ord r, Num r) =>
(Point 2 r :+ a) -> NonEmpty (Point 2 r :+ b) -> Point 2 r :+ b
steepestCcwFrom Point 2 r :+ p
s [Point 2 r :+ p]
rest
  where
    (Point 2 r :+ p
s:[Point 2 r :+ p]
_ :+ [Point 2 r :+ p]
rest) = ((Point 2 r :+ p) -> (Point 2 r :+ p) -> Ordering)
-> [Point 2 r :+ p] -> [Point 2 r :+ p] :+ [Point 2 r :+ p]
forall a. (a -> a -> Ordering) -> [a] -> [a] :+ [a]
extractMinimaBy (Point 2 r :+ p) -> (Point 2 r :+ p) -> Ordering
forall extra.
(Point 2 r :+ extra) -> (Point 2 r :+ extra) -> Ordering
cmp0 (NonEmpty (Point 2 r :+ p) -> [Point 2 r :+ p]
forall a. NonEmpty a -> [a]
NonEmpty.toList NonEmpty (Point 2 r :+ p)
pts)
    cmp0 :: (Point 2 r :+ extra) -> (Point 2 r :+ extra) -> Ordering
cmp0          = ((Point 2 r :+ extra) -> (r, Down r))
-> (Point 2 r :+ extra) -> (Point 2 r :+ extra) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (\(Point2 r
x r
y :+ extra
_) -> (r
x, r -> Down r
forall a. a -> Down a
Down r
y))
                    -- start from the topmost point that has minimum x-coord
    cmp :: (Point 2 r :+ extra) -> (Point 2 r :+ extra) -> Ordering
cmp           = ((Point 2 r :+ extra) -> Point 2 r)
-> (Point 2 r :+ extra) -> (Point 2 r :+ extra) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing ((Point 2 r :+ extra)
-> Getting (Point 2 r) (Point 2 r :+ extra) (Point 2 r)
-> Point 2 r
forall s a. s -> Getting a s a -> a
^.Getting (Point 2 r) (Point 2 r :+ extra) (Point 2 r)
forall core extra core'.
Lens (core :+ extra) (core' :+ extra) core core'
core)
                    -- for the rest of the comparions use the normal
                    -- lexicographic comparing order.

-- | Jarvis March to compute the lower hull, without any vertical segments.
--
--
-- running time: \(O(nh)\), where \(h\) is the complexity of the hull.
lowerHull'     :: (Num r, Ord r) => NonEmpty (Point 2 r :+ p) -> NonEmpty (Point 2 r :+ p)
lowerHull' :: NonEmpty (Point 2 r :+ p) -> NonEmpty (Point 2 r :+ p)
lowerHull' NonEmpty (Point 2 r :+ p)
pts = NonEmpty (Point 2 r :+ p) -> NonEmpty (Point 2 r :+ p)
forall r p.
Eq r =>
NonEmpty (Point 2 r :+ p) -> NonEmpty (Point 2 r :+ p)
pruneVertical (NonEmpty (Point 2 r :+ p) -> NonEmpty (Point 2 r :+ p))
-> NonEmpty (Point 2 r :+ p) -> NonEmpty (Point 2 r :+ p)
forall a b. (a -> b) -> a -> b
$ ((Point 2 r :+ p) -> (Point 2 r :+ p) -> Ordering)
-> ((Point 2 r :+ p)
    -> NonEmpty (Point 2 r :+ p) -> Point 2 r :+ p)
-> (Point 2 r :+ p)
-> [Point 2 r :+ p]
-> NonEmpty (Point 2 r :+ p)
forall a.
(a -> a -> Ordering)
-> (a -> NonEmpty a -> a) -> a -> [a] -> NonEmpty a
repeatedly (Point 2 r :+ p) -> (Point 2 r :+ p) -> Ordering
forall extra.
(Point 2 r :+ extra) -> (Point 2 r :+ extra) -> Ordering
cmp (Point 2 r :+ p) -> NonEmpty (Point 2 r :+ p) -> Point 2 r :+ p
forall r a b.
(Ord r, Num r) =>
(Point 2 r :+ a) -> NonEmpty (Point 2 r :+ b) -> Point 2 r :+ b
steepestCcwFrom Point 2 r :+ p
s [Point 2 r :+ p]
rest
  where
    (Point 2 r :+ p
s:[Point 2 r :+ p]
_ :+ [Point 2 r :+ p]
rest) = ((Point 2 r :+ p) -> (Point 2 r :+ p) -> Ordering)
-> [Point 2 r :+ p] -> [Point 2 r :+ p] :+ [Point 2 r :+ p]
forall a. (a -> a -> Ordering) -> [a] -> [a] :+ [a]
extractMinimaBy (Point 2 r :+ p) -> (Point 2 r :+ p) -> Ordering
forall extra.
(Point 2 r :+ extra) -> (Point 2 r :+ extra) -> Ordering
cmp (NonEmpty (Point 2 r :+ p) -> [Point 2 r :+ p]
forall a. NonEmpty a -> [a]
NonEmpty.toList NonEmpty (Point 2 r :+ p)
pts)
    cmp :: (Point 2 r :+ extra) -> (Point 2 r :+ extra) -> Ordering
cmp           = ((Point 2 r :+ extra) -> Point 2 r)
-> (Point 2 r :+ extra) -> (Point 2 r :+ extra) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing ((Point 2 r :+ extra)
-> Getting (Point 2 r) (Point 2 r :+ extra) (Point 2 r)
-> Point 2 r
forall s a. s -> Getting a s a -> a
^.Getting (Point 2 r) (Point 2 r :+ extra) (Point 2 r)
forall core extra core'.
Lens (core :+ extra) (core' :+ extra) core core'
core)


-- | Find the next point in counter clockwise order, i.e. the point
-- with minimum slope w.r.t. the given point.
steepestCcwFrom   :: (Ord r, Num r)
               => (Point 2 r :+ a) -> NonEmpty (Point 2 r :+ b)  -> Point 2 r :+ b
steepestCcwFrom :: (Point 2 r :+ a) -> NonEmpty (Point 2 r :+ b) -> Point 2 r :+ b
steepestCcwFrom Point 2 r :+ a
p = ((Point 2 r :+ b) -> (Point 2 r :+ b) -> Ordering)
-> NonEmpty (Point 2 r :+ b) -> Point 2 r :+ b
forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
List.minimumBy (Vector 2 r
-> (Point 2 r :+ a)
-> (Point 2 r :+ b)
-> (Point 2 r :+ b)
-> Ordering
forall r c a b.
(Ord r, Num r) =>
Vector 2 r
-> (Point 2 r :+ c)
-> (Point 2 r :+ a)
-> (Point 2 r :+ b)
-> Ordering
ccwCmpAroundWith' (r -> r -> Vector 2 r
forall r. r -> r -> Vector 2 r
Vector2 r
0 (-r
1)) Point 2 r :+ a
p)

-- | Find the next point in clockwise order, i.e. the point
-- with maximum slope w.r.t. the given point.
steepestCwFrom   :: (Ord r, Num r)
               => (Point 2 r :+ a) -> NonEmpty (Point 2 r :+ b)  -> Point 2 r :+ b
steepestCwFrom :: (Point 2 r :+ a) -> NonEmpty (Point 2 r :+ b) -> Point 2 r :+ b
steepestCwFrom Point 2 r :+ a
p = ((Point 2 r :+ b) -> (Point 2 r :+ b) -> Ordering)
-> NonEmpty (Point 2 r :+ b) -> Point 2 r :+ b
forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
List.minimumBy (Vector 2 r
-> (Point 2 r :+ a)
-> (Point 2 r :+ b)
-> (Point 2 r :+ b)
-> Ordering
forall r c a b.
(Ord r, Num r) =>
Vector 2 r
-> (Point 2 r :+ c)
-> (Point 2 r :+ a)
-> (Point 2 r :+ b)
-> Ordering
cwCmpAroundWith' (r -> r -> Vector 2 r
forall r. r -> r -> Vector 2 r
Vector2 r
0 r
1) Point 2 r :+ a
p)

repeatedly       :: (a -> a -> Ordering) -> (a -> NonEmpty a -> a) -> a -> [a] -> NonEmpty a
repeatedly :: (a -> a -> Ordering)
-> (a -> NonEmpty a -> a) -> a -> [a] -> NonEmpty a
repeatedly a -> a -> Ordering
cmp a -> NonEmpty a -> a
f = a -> [a] -> NonEmpty a
go
  where
    go :: a -> [a] -> NonEmpty a
go a
m [a]
xs' = case [a] -> Maybe (NonEmpty a)
forall a. [a] -> Maybe (NonEmpty a)
NonEmpty.nonEmpty [a]
xs' of
      Maybe (NonEmpty a)
Nothing -> a
m a -> [a] -> NonEmpty a
forall a. a -> [a] -> NonEmpty a
:| []
      Just NonEmpty a
xs -> let p :: a
p = a -> NonEmpty a -> a
f a
m NonEmpty a
xs
                 in a
m a -> NonEmpty a -> NonEmpty a
forall a. a -> NonEmpty a -> NonEmpty a
<| a -> [a] -> NonEmpty a
go a
p ((a -> Bool) -> NonEmpty a -> [a]
forall a. (a -> Bool) -> NonEmpty a -> [a]
NonEmpty.filter (\a
x -> a
p a -> a -> Ordering
`cmp` a
x Ordering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
== Ordering
LT) NonEmpty a
xs)


-- | Removes the topmost vertical points, if they exist
pruneVertical :: Eq r => NonEmpty (Point 2 r :+ p) -> NonEmpty (Point 2 r :+ p)
pruneVertical :: NonEmpty (Point 2 r :+ p) -> NonEmpty (Point 2 r :+ p)
pruneVertical = (NonEmpty (Point 2 r :+ p) -> NonEmpty (Point 2 r :+ p))
-> (NonEmpty (Point 2 r :+ p) -> NonEmpty (Point 2 r :+ p))
-> Either (NonEmpty (Point 2 r :+ p)) (NonEmpty (Point 2 r :+ p))
-> NonEmpty (Point 2 r :+ p)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either NonEmpty (Point 2 r :+ p) -> NonEmpty (Point 2 r :+ p)
forall a. a -> a
id NonEmpty (Point 2 r :+ p) -> NonEmpty (Point 2 r :+ p)
forall a. a -> a
id (Either (NonEmpty (Point 2 r :+ p)) (NonEmpty (Point 2 r :+ p))
 -> NonEmpty (Point 2 r :+ p))
-> (NonEmpty (Point 2 r :+ p)
    -> Either (NonEmpty (Point 2 r :+ p)) (NonEmpty (Point 2 r :+ p)))
-> NonEmpty (Point 2 r :+ p)
-> NonEmpty (Point 2 r :+ p)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Point 2 r :+ p)
 -> Either (NonEmpty (Point 2 r :+ p)) (NonEmpty (Point 2 r :+ p))
 -> Either (NonEmpty (Point 2 r :+ p)) (NonEmpty (Point 2 r :+ p)))
-> ((Point 2 r :+ p)
    -> Either (NonEmpty (Point 2 r :+ p)) (NonEmpty (Point 2 r :+ p)))
-> NonEmpty (Point 2 r :+ p)
-> Either (NonEmpty (Point 2 r :+ p)) (NonEmpty (Point 2 r :+ p))
forall (f :: * -> *) a b.
Foldable1 f =>
(a -> b -> b) -> (a -> b) -> f a -> b
foldr1With (Point 2 r :+ p)
-> Either (NonEmpty (Point 2 r :+ p)) (NonEmpty (Point 2 r :+ p))
-> Either (NonEmpty (Point 2 r :+ p)) (NonEmpty (Point 2 r :+ p))
forall (d :: Nat) a (point :: Nat -> * -> *) extra.
(ImplicitPeano (Peano d), Eq a,
 ArityPeano (Peano (FromPeano (Peano d))),
 KnownNat (FromPeano (Peano d)), KnownNat d, AsAPoint point,
 (1 <=? d) ~ 'True,
 Peano (FromPeano (Peano d) + 1)
 ~ 'S (Peano (FromPeano (Peano d)))) =>
(point d a :+ extra)
-> Either
     (NonEmpty (point d a :+ extra)) (NonEmpty (point d a :+ extra))
-> Either
     (NonEmpty (point d a :+ extra)) (NonEmpty (point d a :+ extra))
f (\Point 2 r :+ p
q -> NonEmpty (Point 2 r :+ p)
-> Either (NonEmpty (Point 2 r :+ p)) (NonEmpty (Point 2 r :+ p))
forall a b. a -> Either a b
Left (NonEmpty (Point 2 r :+ p)
 -> Either (NonEmpty (Point 2 r :+ p)) (NonEmpty (Point 2 r :+ p)))
-> NonEmpty (Point 2 r :+ p)
-> Either (NonEmpty (Point 2 r :+ p)) (NonEmpty (Point 2 r :+ p))
forall a b. (a -> b) -> a -> b
$ Point 2 r :+ p
q(Point 2 r :+ p) -> [Point 2 r :+ p] -> NonEmpty (Point 2 r :+ p)
forall a. a -> [a] -> NonEmpty a
:|[])
  where
    f :: (point d a :+ extra)
-> Either
     (NonEmpty (point d a :+ extra)) (NonEmpty (point d a :+ extra))
-> Either
     (NonEmpty (point d a :+ extra)) (NonEmpty (point d a :+ extra))
f point d a :+ extra
p = \case
      Left (point d a :+ extra
q:|[point d a :+ extra]
qs) | point d a :+ extra
p(point d a :+ extra) -> Getting a (point d a :+ extra) a -> a
forall s a. s -> Getting a s a -> a
^.(point d a -> Const a (point d a))
-> (point d a :+ extra) -> Const a (point d a :+ extra)
forall core extra core'.
Lens (core :+ extra) (core' :+ extra) core core'
core((point d a -> Const a (point d a))
 -> (point d a :+ extra) -> Const a (point d a :+ extra))
-> ((a -> Const a a) -> point d a -> Const a (point d a))
-> Getting a (point d a :+ extra) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(a -> Const a a) -> point d a -> Const a (point d a)
forall (d :: Nat) (point :: Nat -> * -> *) r.
(1 <= d, Arity d, AsAPoint point) =>
Lens' (point d r) r
xCoord a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== point d a :+ extra
q(point d a :+ extra) -> Getting a (point d a :+ extra) a -> a
forall s a. s -> Getting a s a -> a
^.(point d a -> Const a (point d a))
-> (point d a :+ extra) -> Const a (point d a :+ extra)
forall core extra core'.
Lens (core :+ extra) (core' :+ extra) core core'
core((point d a -> Const a (point d a))
 -> (point d a :+ extra) -> Const a (point d a :+ extra))
-> ((a -> Const a a) -> point d a -> Const a (point d a))
-> Getting a (point d a :+ extra) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(a -> Const a a) -> point d a -> Const a (point d a)
forall (d :: Nat) (point :: Nat -> * -> *) r.
(1 <= d, Arity d, AsAPoint point) =>
Lens' (point d r) r
xCoord -> NonEmpty (point d a :+ extra)
-> Either
     (NonEmpty (point d a :+ extra)) (NonEmpty (point d a :+ extra))
forall a b. a -> Either a b
Left  (point d a :+ extra
p (point d a :+ extra)
-> [point d a :+ extra] -> NonEmpty (point d a :+ extra)
forall a. a -> [a] -> NonEmpty a
:| [point d a :+ extra]
qs)
                   | Bool
otherwise                        -> NonEmpty (point d a :+ extra)
-> Either
     (NonEmpty (point d a :+ extra)) (NonEmpty (point d a :+ extra))
forall a b. b -> Either a b
Right (point d a :+ extra
p (point d a :+ extra)
-> [point d a :+ extra] -> NonEmpty (point d a :+ extra)
forall a. a -> [a] -> NonEmpty a
:| point d a :+ extra
q(point d a :+ extra)
-> [point d a :+ extra] -> [point d a :+ extra]
forall a. a -> [a] -> [a]
:[point d a :+ extra]
qs)
      Right NonEmpty (point d a :+ extra)
pts                                       -> NonEmpty (point d a :+ extra)
-> Either
     (NonEmpty (point d a :+ extra)) (NonEmpty (point d a :+ extra))
forall a b. b -> Either a b
Right (point d a :+ extra
p (point d a :+ extra)
-> NonEmpty (point d a :+ extra) -> NonEmpty (point d a :+ extra)
forall a. a -> NonEmpty a -> NonEmpty a
<| NonEmpty (point d a :+ extra)
pts)

-- | Foldr, but start by applying some function on the rightmost
-- element to get the starting value.
foldr1With     :: Foldable1 f => (a -> b -> b) -> (a -> b) -> f a -> b
foldr1With :: (a -> b -> b) -> (a -> b) -> f a -> b
foldr1With a -> b -> b
f a -> b
b = NonEmpty a -> b
go (NonEmpty a -> b) -> (f a -> NonEmpty a) -> f a -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f a -> NonEmpty a
forall (t :: * -> *) a. Foldable1 t => t a -> NonEmpty a
toNonEmpty
  where
    go :: NonEmpty a -> b
go (a
x :| [a]
xs) = case [a] -> Maybe (NonEmpty a)
forall a. [a] -> Maybe (NonEmpty a)
NonEmpty.nonEmpty [a]
xs of
                     Maybe (NonEmpty a)
Nothing  -> a -> b
b a
x
                     Just NonEmpty a
xs' -> a
x a -> b -> b
`f` NonEmpty a -> b
go NonEmpty a
xs'

-- | extracts all minima from the list. The result consists of the
-- list of minima, and all remaining points. Both lists are returned
-- in the order in which they occur in the input.
--
-- >>> extractMinimaBy compare [1,2,3,0,1,2,3,0,1,2,0,2]
-- [0,0,0] :+ [2,3,1,2,3,1,2,1,2]
extractMinimaBy     :: (a -> a -> Ordering) -> [a] -> [a] :+ [a]
extractMinimaBy :: (a -> a -> Ordering) -> [a] -> [a] :+ [a]
extractMinimaBy a -> a -> Ordering
cmp = \case
  []     -> [] [a] -> [a] -> [a] :+ [a]
forall core extra. core -> extra -> core :+ extra
:+ []
  (a
x:[a]
xs) -> (NonEmpty a -> [a]) -> (NonEmpty a :+ [a]) -> [a] :+ [a]
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first NonEmpty a -> [a]
forall a. NonEmpty a -> [a]
NonEmpty.toList ((NonEmpty a :+ [a]) -> [a] :+ [a])
-> (NonEmpty a :+ [a]) -> [a] :+ [a]
forall a b. (a -> b) -> a -> b
$ (a -> (NonEmpty a :+ [a]) -> NonEmpty a :+ [a])
-> (NonEmpty a :+ [a]) -> [a] -> NonEmpty a :+ [a]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\a
y (mins :: NonEmpty a
mins@(a
m:|[a]
_) :+ [a]
rest) ->
                                             case a
m a -> a -> Ordering
`cmp` a
y of
                                               Ordering
LT -> NonEmpty a
mins NonEmpty a -> [a] -> NonEmpty a :+ [a]
forall core extra. core -> extra -> core :+ extra
:+ a
ya -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
rest
                                               Ordering
EQ -> (a
y a -> NonEmpty a -> NonEmpty a
forall a. a -> NonEmpty a -> NonEmpty a
NonEmpty.<| NonEmpty a
mins) NonEmpty a -> [a] -> NonEmpty a :+ [a]
forall core extra. core -> extra -> core :+ extra
:+ [a]
rest
                                               Ordering
GT -> (a
ya -> [a] -> NonEmpty a
forall a. a -> [a] -> NonEmpty a
:|[]) NonEmpty a -> [a] -> NonEmpty a :+ [a]
forall core extra. core -> extra -> core :+ extra
:+ NonEmpty a -> [a]
forall a. NonEmpty a -> [a]
NonEmpty.toList NonEmpty a
mins [a] -> [a] -> [a]
forall a. Semigroup a => a -> a -> a
<> [a]
rest
                                          ) ((a
xa -> [a] -> NonEmpty a
forall a. a -> [a] -> NonEmpty a
:|[]) NonEmpty a -> [a] -> NonEmpty a :+ [a]
forall core extra. core -> extra -> core :+ extra
:+ []) [a]
xs