{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

-- Orphan Traced instances for Segment Closed V2 and FixedSegment V2.
-- They can't go in Traced; but they shouldn't really go in
-- Diagrams.Segment either because we only have Traced instances for
-- the special case of R2.

-- |
-- Module      :  Diagrams.TwoD.Segment
-- Copyright   :  (c) 2012 diagrams-lib team (see LICENSE)
-- License     :  BSD-style (see LICENSE)
-- Maintainer  :  diagrams-discuss@googlegroups.com
--
-- Segments in two dimensions are special since we may meaningfully
-- compute their point of intersection with a ray.
module Diagrams.TwoD.Segment (
  -- * Segment intersections
  intersectPointsS,
  intersectPointsS',

  -- * Closest point on a segment
  closestPoint,
  closestPoint',
  closestDistance,
  closestDistance',
  closestParam,
  closestParam',

  -- ** Low level functions
  segmentSegment,
  lineSegment,
)
where

import Control.Lens hiding (at, contains, transform, (#))
import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.List.NonEmpty as NE
import Data.Maybe

import Diagrams.Core

import Diagrams.Direction
import Diagrams.Located
import Diagrams.Parametric
import Diagrams.Segment
import Diagrams.TwoD.Points
import Diagrams.TwoD.Segment.Bernstein
import Diagrams.TwoD.Transform
import Diagrams.TwoD.Types hiding (p2)
import Diagrams.TwoD.Vector

import Linear.Affine
import Linear.Metric

{- All instances of Traced should maintain the invariant that the list of
   traces is sorted in increasing order.
-}

instance OrderedField n => Traced (Segment Closed V2 n) where
  getTrace :: Segment Closed V2 n
-> Trace (V (Segment Closed V2 n)) (N (Segment Closed V2 n))
getTrace = FixedSegment V2 n
-> Trace (V (FixedSegment V2 n)) (N (FixedSegment V2 n))
FixedSegment V2 n -> Trace V2 n
forall a. Traced a => a -> Trace (V a) (N a)
getTrace (FixedSegment V2 n -> Trace V2 n)
-> (Segment Closed V2 n -> FixedSegment V2 n)
-> Segment Closed V2 n
-> Trace V2 n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Located (Segment Closed V2 n) -> FixedSegment V2 n
forall n (v :: * -> *).
(Num n, Additive v) =>
Located (Segment Closed v n) -> FixedSegment v n
mkFixedSeg (Located (Segment Closed V2 n) -> FixedSegment V2 n)
-> (Segment Closed V2 n -> Located (Segment Closed V2 n))
-> Segment Closed V2 n
-> FixedSegment V2 n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Segment Closed V2 n
-> Point (V (Segment Closed V2 n)) (N (Segment Closed V2 n))
-> Located (Segment Closed V2 n)
forall a. a -> Point (V a) (N a) -> Located a
`at` Point (V (Segment Closed V2 n)) (N (Segment Closed V2 n))
Point V2 n
forall (f :: * -> *) a. (Additive f, Num a) => Point f a
origin)

instance OrderedField n => Traced (FixedSegment V2 n) where
  getTrace :: FixedSegment V2 n
-> Trace (V (FixedSegment V2 n)) (N (FixedSegment V2 n))
getTrace FixedSegment V2 n
seg = (Point (V (FixedSegment V2 n)) (N (FixedSegment V2 n))
 -> V (FixedSegment V2 n) (N (FixedSegment V2 n))
 -> SortedList (N (FixedSegment V2 n)))
-> Trace (V (FixedSegment V2 n)) (N (FixedSegment V2 n))
forall (v :: * -> *) n.
(Point v n -> v n -> SortedList n) -> Trace v n
mkTrace ((Point (V (FixedSegment V2 n)) (N (FixedSegment V2 n))
  -> V (FixedSegment V2 n) (N (FixedSegment V2 n))
  -> SortedList (N (FixedSegment V2 n)))
 -> Trace (V (FixedSegment V2 n)) (N (FixedSegment V2 n)))
-> (Point (V (FixedSegment V2 n)) (N (FixedSegment V2 n))
    -> V (FixedSegment V2 n) (N (FixedSegment V2 n))
    -> SortedList (N (FixedSegment V2 n)))
-> Trace (V (FixedSegment V2 n)) (N (FixedSegment V2 n))
forall a b. (a -> b) -> a -> b
$ \Point (V (FixedSegment V2 n)) (N (FixedSegment V2 n))
p V (FixedSegment V2 n) (N (FixedSegment V2 n))
v ->
    [n] -> SortedList n
[n] -> SortedList (N (FixedSegment V2 n))
forall a. Ord a => [a] -> SortedList a
mkSortedList ([n] -> SortedList (N (FixedSegment V2 n)))
-> ([(n, n, P2 n)] -> [n])
-> [(n, n, P2 n)]
-> SortedList (N (FixedSegment V2 n))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((n, n, P2 n) -> n) -> [(n, n, P2 n)] -> [n]
forall a b. (a -> b) -> [a] -> [b]
map (Getting n (n, n, P2 n) n -> (n, n, P2 n) -> n
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting n (n, n, P2 n) n
forall s t a b. Field1 s t a b => Lens s t a b
Lens (n, n, P2 n) (n, n, P2 n) n n
_1) ([(n, n, P2 n)] -> SortedList (N (FixedSegment V2 n)))
-> [(n, n, P2 n)] -> SortedList (N (FixedSegment V2 n))
forall a b. (a -> b) -> a -> b
$ n -> Located (V2 n) -> FixedSegment V2 n -> [(n, n, P2 n)]
forall n.
OrderedField n =>
n -> Located (V2 n) -> FixedSegment V2 n -> [(n, n, P2 n)]
lineSegment n
forall n. Fractional n => n
defEps (V (FixedSegment V2 n) (N (FixedSegment V2 n))
V2 n
v V2 n -> Point (V (V2 n)) (N (V2 n)) -> Located (V2 n)
forall a. a -> Point (V a) (N a) -> Located a
`at` Point (V (V2 n)) (N (V2 n))
Point (V (FixedSegment V2 n)) (N (FixedSegment V2 n))
p) FixedSegment V2 n
seg

defEps :: Fractional n => n
defEps :: forall n. Fractional n => n
defEps = n
1e-8

-- | Compute the intersections between two fixed segments.
intersectPointsS :: OrderedField n => FixedSegment V2 n -> FixedSegment V2 n -> [P2 n]
intersectPointsS :: forall n.
OrderedField n =>
FixedSegment V2 n -> FixedSegment V2 n -> [P2 n]
intersectPointsS = n -> FixedSegment V2 n -> FixedSegment V2 n -> [P2 n]
forall n.
OrderedField n =>
n -> FixedSegment V2 n -> FixedSegment V2 n -> [P2 n]
intersectPointsS' n
forall n. Fractional n => n
defEps

-- | Compute the intersections between two segments using the given tolerance.
intersectPointsS' :: OrderedField n => n -> FixedSegment V2 n -> FixedSegment V2 n -> [P2 n]
intersectPointsS' :: forall n.
OrderedField n =>
n -> FixedSegment V2 n -> FixedSegment V2 n -> [P2 n]
intersectPointsS' n
eps FixedSegment V2 n
s1 FixedSegment V2 n
s2 = ((n, n, P2 n) -> P2 n) -> [(n, n, P2 n)] -> [P2 n]
forall a b. (a -> b) -> [a] -> [b]
map (Getting (P2 n) (n, n, P2 n) (P2 n) -> (n, n, P2 n) -> P2 n
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (P2 n) (n, n, P2 n) (P2 n)
forall s t a b. Field3 s t a b => Lens s t a b
Lens (n, n, P2 n) (n, n, P2 n) (P2 n) (P2 n)
_3) ([(n, n, P2 n)] -> [P2 n]) -> [(n, n, P2 n)] -> [P2 n]
forall a b. (a -> b) -> a -> b
$ n -> FixedSegment V2 n -> FixedSegment V2 n -> [(n, n, P2 n)]
forall n.
OrderedField n =>
n -> FixedSegment V2 n -> FixedSegment V2 n -> [(n, n, P2 n)]
segmentSegment n
eps FixedSegment V2 n
s1 FixedSegment V2 n
s2

-- | Get the closest distance(s) from a point to a 'FixedSegment'.
closestDistance :: OrderedField n => FixedSegment V2 n -> P2 n -> [n]
closestDistance :: forall n. OrderedField n => FixedSegment V2 n -> P2 n -> [n]
closestDistance = n -> FixedSegment V2 n -> P2 n -> [n]
forall n. OrderedField n => n -> FixedSegment V2 n -> P2 n -> [n]
closestDistance' n
forall n. Fractional n => n
defEps

-- | Get the closest distance(s) from a point to a 'FixedSegment' within given
--   tolerance.
closestDistance' :: OrderedField n => n -> FixedSegment V2 n -> P2 n -> [n]
closestDistance' :: forall n. OrderedField n => n -> FixedSegment V2 n -> P2 n -> [n]
closestDistance' n
eps FixedSegment V2 n
seg P2 n
p = (P2 n -> n) -> [P2 n] -> [n]
forall a b. (a -> b) -> [a] -> [b]
map (P2 n -> P2 n -> n
forall a (p :: * -> *).
(Floating a, Foldable (Diff p), Affine p) =>
p a -> p a -> a
distanceA P2 n
p) ([P2 n] -> [n]) -> [P2 n] -> [n]
forall a b. (a -> b) -> a -> b
$ n -> FixedSegment V2 n -> P2 n -> [P2 n]
forall n.
OrderedField n =>
n -> FixedSegment V2 n -> P2 n -> [P2 n]
closestPoint' n
eps FixedSegment V2 n
seg P2 n
p

-- | Get the closest point(s) on a 'FixedSegment' from a point.
closestPoint :: OrderedField n => FixedSegment V2 n -> P2 n -> [P2 n]
closestPoint :: forall n. OrderedField n => FixedSegment V2 n -> P2 n -> [P2 n]
closestPoint = n -> FixedSegment V2 n -> P2 n -> [P2 n]
forall n.
OrderedField n =>
n -> FixedSegment V2 n -> P2 n -> [P2 n]
closestPoint' n
forall n. Fractional n => n
defEps

-- | Get the closest point(s) on a 'FixedSegment' from a point within given
--   tolerance.
closestPoint' :: OrderedField n => n -> FixedSegment V2 n -> P2 n -> [P2 n]
closestPoint' :: forall n.
OrderedField n =>
n -> FixedSegment V2 n -> P2 n -> [P2 n]
closestPoint' n
eps FixedSegment V2 n
seg = (n -> P2 n) -> [n] -> [P2 n]
forall a b. (a -> b) -> [a] -> [b]
map (FixedSegment V2 n
seg FixedSegment V2 n
-> N (FixedSegment V2 n)
-> Codomain (FixedSegment V2 n) (N (FixedSegment V2 n))
forall p. Parametric p => p -> N p -> Codomain p (N p)
`atParam`) ([n] -> [P2 n]) -> (P2 n -> [n]) -> P2 n -> [P2 n]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. n -> FixedSegment V2 n -> P2 n -> [n]
forall n. OrderedField n => n -> FixedSegment V2 n -> P2 n -> [n]
closestParam' n
eps FixedSegment V2 n
seg

-- | Find the closest value(s) on the Bêzier to the given point.
closestParam :: OrderedField n => FixedSegment V2 n -> P2 n -> [n]
closestParam :: forall n. OrderedField n => FixedSegment V2 n -> P2 n -> [n]
closestParam = n -> FixedSegment V2 n -> P2 n -> [n]
forall n. OrderedField n => n -> FixedSegment V2 n -> P2 n -> [n]
closestParam' n
forall n. Fractional n => n
defEps

-- | Find the closest value(s) on the Bêzier to the given point within given
--   tolerance.
closestParam' :: OrderedField n => n -> FixedSegment V2 n -> P2 n -> [n]
closestParam' :: forall n. OrderedField n => n -> FixedSegment V2 n -> P2 n -> [n]
closestParam' n
_ (FLinear Point V2 n
p0 Point V2 n
p1) Point V2 n
p
  | n
t n -> n -> Bool
forall a. Ord a => a -> a -> Bool
< n
0 = [n
0]
  | n
t n -> n -> Bool
forall a. Ord a => a -> a -> Bool
> n
1 = [n
1]
  | Bool
otherwise = [n
t]
 where
  vp :: Diff (Point V2) n
vp = Point V2 n
p Point V2 n -> Point V2 n -> Diff (Point V2) n
forall a. Num a => Point V2 a -> Point V2 a -> Diff (Point V2) a
forall (p :: * -> *) a. (Affine p, Num a) => p a -> p a -> Diff p a
.-. Point V2 n
p0
  v :: Diff (Point V2) n
v = Point V2 n
p1 Point V2 n -> Point V2 n -> Diff (Point V2) n
forall a. Num a => Point V2 a -> Point V2 a -> Diff (Point V2) a
forall (p :: * -> *) a. (Affine p, Num a) => p a -> p a -> Diff p a
.-. Point V2 n
p0
  dp :: n
dp = V2 n
Diff (Point V2) n
vp V2 n -> V2 n -> n
forall a. Num a => V2 a -> V2 a -> a
forall (f :: * -> *) a. (Metric f, Num a) => f a -> f a -> a
`dot` V2 n
Diff (Point V2) n
v
  t :: n
t = n
dp n -> n -> n
forall a. Fractional a => a -> a -> a
/ V2 n -> n
forall a. Num a => V2 a -> a
forall (f :: * -> *) a. (Metric f, Num a) => f a -> a
quadrance V2 n
Diff (Point V2) n
v
closestParam' n
eps FixedSegment V2 n
cb (P (V2 n
px n
py)) = n -> BernsteinPoly n -> n -> n -> [n]
forall n. OrderedField n => n -> BernsteinPoly n -> n -> n -> [n]
bezierFindRoot n
eps BernsteinPoly n
poly n
0 n
1
 where
  (BernsteinPoly n
bx, BernsteinPoly n
by) = FixedSegment V2 n -> (BernsteinPoly n, BernsteinPoly n)
forall n.
Fractional n =>
FixedSegment V2 n -> (BernsteinPoly n, BernsteinPoly n)
bezierToBernstein FixedSegment V2 n
cb
  bx' :: BernsteinPoly n
bx' = BernsteinPoly n -> BernsteinPoly n
forall n. Fractional n => BernsteinPoly n -> BernsteinPoly n
bernsteinDeriv BernsteinPoly n
bx
  by' :: BernsteinPoly n
by' = BernsteinPoly n -> BernsteinPoly n
forall n. Fractional n => BernsteinPoly n -> BernsteinPoly n
bernsteinDeriv BernsteinPoly n
by
  poly :: BernsteinPoly n
poly =
    (BernsteinPoly n
bx BernsteinPoly n -> BernsteinPoly n -> BernsteinPoly n
forall a. Num a => a -> a -> a
- [n] -> BernsteinPoly n
forall n. Fractional n => [n] -> BernsteinPoly n
listToBernstein [n
px, n
px, n
px, n
px]) BernsteinPoly n -> BernsteinPoly n -> BernsteinPoly n
forall a. Num a => a -> a -> a
* BernsteinPoly n
bx'
      BernsteinPoly n -> BernsteinPoly n -> BernsteinPoly n
forall a. Num a => a -> a -> a
+ (BernsteinPoly n
by BernsteinPoly n -> BernsteinPoly n -> BernsteinPoly n
forall a. Num a => a -> a -> a
- [n] -> BernsteinPoly n
forall n. Fractional n => [n] -> BernsteinPoly n
listToBernstein [n
py, n
py, n
py, n
py]) BernsteinPoly n -> BernsteinPoly n -> BernsteinPoly n
forall a. Num a => a -> a -> a
* BernsteinPoly n
by'

------------------------------------------------------------------------
-- Low level
------------------------------------------------------------------------

-- | Return the intersection points with the parameters at which each segment
--   intersects.
segmentSegment :: OrderedField n => n -> FixedSegment V2 n -> FixedSegment V2 n -> [(n, n, P2 n)]
segmentSegment :: forall n.
OrderedField n =>
n -> FixedSegment V2 n -> FixedSegment V2 n -> [(n, n, P2 n)]
segmentSegment n
eps FixedSegment V2 n
s1 FixedSegment V2 n
s2 =
  case (FixedSegment V2 n
s1, FixedSegment V2 n
s2) of
    (FCubic {}, FCubic {}) ->
      ((n, n) -> (n, n, P2 n)) -> [(n, n)] -> [(n, n, P2 n)]
forall a b. (a -> b) -> [a] -> [b]
map (\(n
t1, n
t2) -> (n
t1, n
t2, FixedSegment V2 n
s1 FixedSegment V2 n
-> N (FixedSegment V2 n)
-> Codomain (FixedSegment V2 n) (N (FixedSegment V2 n))
forall p. Parametric p => p -> N p -> Codomain p (N p)
`atParam` n
N (FixedSegment V2 n)
t1)) ([(n, n)] -> [(n, n, P2 n)]) -> [(n, n)] -> [(n, n, P2 n)]
forall a b. (a -> b) -> a -> b
$
        n -> FixedSegment V2 n -> FixedSegment V2 n -> [(n, n)]
forall n.
OrderedField n =>
n -> FixedSegment V2 n -> FixedSegment V2 n -> [(n, n)]
bezierClip n
eps FixedSegment V2 n
s1 FixedSegment V2 n
s2
    (FCubic {}, FLinear {}) -> ((n, n, P2 n) -> (n, n, P2 n)) -> [(n, n, P2 n)] -> [(n, n, P2 n)]
forall a b. (a -> b) -> [a] -> [b]
map (n, n, P2 n) -> (n, n, P2 n)
forall {b} {a} {c}. (b, a, c) -> (a, b, c)
flip12 ([(n, n, P2 n)] -> [(n, n, P2 n)])
-> [(n, n, P2 n)] -> [(n, n, P2 n)]
forall a b. (a -> b) -> a -> b
$ Located (V2 n) -> FixedSegment V2 n -> [(n, n, P2 n)]
linearSeg (FixedSegment V2 n -> Located (V2 n)
forall (v :: * -> *) n.
InSpace v n (v n) =>
FixedSegment v n -> Located (v n)
segLine FixedSegment V2 n
s2) FixedSegment V2 n
s1
    (FixedSegment V2 n, FixedSegment V2 n)
_ -> Located (V2 n) -> FixedSegment V2 n -> [(n, n, P2 n)]
linearSeg (FixedSegment V2 n -> Located (V2 n)
forall (v :: * -> *) n.
InSpace v n (v n) =>
FixedSegment v n -> Located (v n)
segLine FixedSegment V2 n
s1) FixedSegment V2 n
s2 -- s1 is linear
 where
  linearSeg :: Located (V2 n) -> FixedSegment V2 n -> [(n, n, P2 n)]
linearSeg Located (V2 n)
l FixedSegment V2 n
s = ((n, n, P2 n) -> Bool) -> [(n, n, P2 n)] -> [(n, n, P2 n)]
forall a. (a -> Bool) -> [a] -> [a]
filter (n -> Bool
forall n. (Fractional n, Ord n) => n -> Bool
inRange (n -> Bool) -> ((n, n, P2 n) -> n) -> (n, n, P2 n) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting n (n, n, P2 n) n -> (n, n, P2 n) -> n
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting n (n, n, P2 n) n
forall s t a b. Field1 s t a b => Lens s t a b
Lens (n, n, P2 n) (n, n, P2 n) n n
_1) ([(n, n, P2 n)] -> [(n, n, P2 n)])
-> [(n, n, P2 n)] -> [(n, n, P2 n)]
forall a b. (a -> b) -> a -> b
$ n -> Located (V2 n) -> FixedSegment V2 n -> [(n, n, P2 n)]
forall n.
OrderedField n =>
n -> Located (V2 n) -> FixedSegment V2 n -> [(n, n, P2 n)]
lineSegment n
eps Located (V2 n)
l FixedSegment V2 n
s
  flip12 :: (b, a, c) -> (a, b, c)
flip12 (b
a, a
b, c
c) = (a
b, b
a, c
c)

-- | Return the intersection points with the parameters at which the line and segment
--   intersect.
lineSegment :: OrderedField n => n -> Located (V2 n) -> FixedSegment V2 n -> [(n, n, P2 n)]
lineSegment :: forall n.
OrderedField n =>
n -> Located (V2 n) -> FixedSegment V2 n -> [(n, n, P2 n)]
lineSegment n
_ Located (V2 n)
l1 p :: FixedSegment V2 n
p@(FLinear Point V2 n
p0 Point V2 n
p1) =
  ((n, n) -> (n, n, Point V2 n)) -> [(n, n)] -> [(n, n, Point V2 n)]
forall a b. (a -> b) -> [a] -> [b]
map (\(n
tl, n
tp) -> (n
tl, n
tp, FixedSegment V2 n
p FixedSegment V2 n
-> N (FixedSegment V2 n)
-> Codomain (FixedSegment V2 n) (N (FixedSegment V2 n))
forall p. Parametric p => p -> N p -> Codomain p (N p)
`atParam` n
N (FixedSegment V2 n)
tp))
    ([(n, n)] -> [(n, n, Point V2 n)])
-> (Maybe (n, n) -> [(n, n)])
-> Maybe (n, n)
-> [(n, n, Point V2 n)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((n, n) -> Bool) -> [(n, n)] -> [(n, n)]
forall a. (a -> Bool) -> [a] -> [a]
filter (n -> Bool
forall n. (Fractional n, Ord n) => n -> Bool
inRange (n -> Bool) -> ((n, n) -> n) -> (n, n) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (n, n) -> n
forall a b. (a, b) -> b
snd)
    ([(n, n)] -> [(n, n)])
-> (Maybe (n, n) -> [(n, n)]) -> Maybe (n, n) -> [(n, n)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe (n, n) -> [(n, n)]
forall a. Maybe a -> [a]
maybeToList
    (Maybe (n, n) -> [(n, n, Point V2 n)])
-> Maybe (n, n) -> [(n, n, Point V2 n)]
forall a b. (a -> b) -> a -> b
$ Located (V2 n) -> Located (V2 n) -> Maybe (n, n)
forall n.
(Fractional n, Eq n) =>
Located (V2 n) -> Located (V2 n) -> Maybe (n, n)
lineLine Located (V2 n)
l1 (Point V2 n -> Point V2 n -> Located (V2 n)
forall (v :: * -> *) n.
InSpace v n (v n) =>
Point v n -> Point v n -> Located (v n)
mkLine Point V2 n
p0 Point V2 n
p1)
lineSegment n
eps (Located (V2 n) -> (Point (V (V2 n)) (N (V2 n)), V2 n)
forall a. Located a -> (Point (V a) (N a), a)
viewLoc -> (Point (V (V2 n)) (N (V2 n))
p, V2 n
r)) FixedSegment V2 n
cb = (n -> (n, n, Point V2 n)) -> [n] -> [(n, n, Point V2 n)]
forall a b. (a -> b) -> [a] -> [b]
map n -> (n, n, Point V2 n)
addPoint [n]
params
 where
  params :: [n]
params = n -> BernsteinPoly n -> n -> n -> [n]
forall n. OrderedField n => n -> BernsteinPoly n -> n -> n -> [n]
bezierFindRoot n
eps ([n] -> BernsteinPoly n
forall n. Fractional n => [n] -> BernsteinPoly n
listToBernstein ([n] -> BernsteinPoly n) -> [n] -> BernsteinPoly n
forall a b. (a -> b) -> a -> b
$ FixedSegment V2 n
cb' FixedSegment V2 n
-> Getting (Endo [n]) (FixedSegment V2 n) n -> [n]
forall s a. s -> Getting (Endo [a]) s a -> [a]
^.. (Point V2 n -> Const (Endo [n]) (Point V2 n))
-> FixedSegment V2 n -> Const (Endo [n]) (FixedSegment V2 n)
forall s t a b. Each s t a b => Traversal s t a b
Traversal
  (FixedSegment V2 n) (FixedSegment V2 n) (Point V2 n) (Point V2 n)
each ((Point V2 n -> Const (Endo [n]) (Point V2 n))
 -> FixedSegment V2 n -> Const (Endo [n]) (FixedSegment V2 n))
-> ((n -> Const (Endo [n]) n)
    -> Point V2 n -> Const (Endo [n]) (Point V2 n))
-> Getting (Endo [n]) (FixedSegment V2 n) n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (n -> Const (Endo [n]) n)
-> Point V2 n -> Const (Endo [n]) (Point V2 n)
forall a. Lens' (Point V2 a) a
forall (t :: * -> *) a. R2 t => Lens' (t a) a
_y) n
0 n
1
  cb' :: FixedSegment V2 n
cb' = Transformation (V (FixedSegment V2 n)) (N (FixedSegment V2 n))
-> FixedSegment V2 n -> FixedSegment V2 n
forall t. Transformable t => Transformation (V t) (N t) -> t -> t
transform (Transformation V2 n -> Transformation V2 n
forall (v :: * -> *) n.
(Functor v, Num n) =>
Transformation v n -> Transformation v n
inv (Direction V2 n -> Transformation V2 n
forall n. OrderedField n => Direction V2 n -> T2 n
rotationTo (Direction V2 n -> Transformation V2 n)
-> Direction V2 n -> Transformation V2 n
forall a b. (a -> b) -> a -> b
$ V2 n -> Direction V2 n
forall (v :: * -> *) n. v n -> Direction v n
dir V2 n
r)) (FixedSegment V2 n -> FixedSegment V2 n)
-> (FixedSegment V2 n -> FixedSegment V2 n)
-> FixedSegment V2 n
-> FixedSegment V2 n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Point (V (FixedSegment V2 n)) (N (FixedSegment V2 n))
-> FixedSegment V2 n -> FixedSegment V2 n
forall t. HasOrigin t => Point (V t) (N t) -> t -> t
moveOriginTo Point (V (V2 n)) (N (V2 n))
Point (V (FixedSegment V2 n)) (N (FixedSegment V2 n))
p (FixedSegment V2 n -> FixedSegment V2 n)
-> FixedSegment V2 n -> FixedSegment V2 n
forall a b. (a -> b) -> a -> b
$ FixedSegment V2 n
cb
  --
  addPoint :: n -> (n, n, Point V2 n)
addPoint n
bt = (n
lt, n
bt, Point V2 n
Codomain (FixedSegment V2 n) (N (FixedSegment V2 n))
intersect)
   where
    intersect :: Codomain (FixedSegment V2 n) (N (FixedSegment V2 n))
intersect = FixedSegment V2 n
cb FixedSegment V2 n
-> N (FixedSegment V2 n)
-> Codomain (FixedSegment V2 n) (N (FixedSegment V2 n))
forall p. Parametric p => p -> N p -> Codomain p (N p)
`atParam` n
N (FixedSegment V2 n)
bt
    lt :: n
lt = (FixedSegment V2 n
cb' FixedSegment V2 n
-> N (FixedSegment V2 n)
-> Codomain (FixedSegment V2 n) (N (FixedSegment V2 n))
forall p. Parametric p => p -> N p -> Codomain p (N p)
`atParam` n
N (FixedSegment V2 n)
bt) Point V2 n -> Getting n (Point V2 n) n -> n
forall s a. s -> Getting a s a -> a
^. Getting n (Point V2 n) n
forall a. Lens' (Point V2 a) a
forall (t :: * -> *) a. R1 t => Lens' (t a) a
_x n -> n -> n
forall a. Fractional a => a -> a -> a
/ V2 n -> n
forall a. Floating a => V2 a -> a
forall (f :: * -> *) a. (Metric f, Floating a) => f a -> a
norm V2 n
r

-- Adapted from from kuribas's cubicbezier package https://github.com/kuribas/cubicbezier

-- | Use the Bêzier clipping algorithm to return the parameters at which the
--   Bêzier curves intersect.
bezierClip :: OrderedField n => n -> FixedSegment V2 n -> FixedSegment V2 n -> [(n, n)]
bezierClip :: forall n.
OrderedField n =>
n -> FixedSegment V2 n -> FixedSegment V2 n -> [(n, n)]
bezierClip n
eps FixedSegment V2 n
p_ FixedSegment V2 n
q_ =
  ((n, n) -> Bool) -> [(n, n)] -> [(n, n)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Getting All (n, n) n -> (n -> Bool) -> (n, n) -> Bool
forall s a. Getting All s a -> (a -> Bool) -> s -> Bool
allOf Getting All (n, n) n
Traversal (n, n) (n, n) n n
forall (r :: * -> * -> *) a b.
Bitraversable r =>
Traversal (r a a) (r b b) a b
both n -> Bool
forall n. (Fractional n, Ord n) => n -> Bool
inRange) ([(n, n)] -> [(n, n)]) -> [(n, n)] -> [(n, n)]
forall a b. (a -> b) -> a -> b
$ -- sometimes this returns NaN
    FixedSegment V2 n
-> FixedSegment V2 n -> n -> n -> n -> n -> n -> Bool -> [(n, n)]
go FixedSegment V2 n
p_ FixedSegment V2 n
q_ n
0 n
1 n
0 n
1 n
0 Bool
False
 where
  go :: FixedSegment V2 n
-> FixedSegment V2 n -> n -> n -> n -> n -> n -> Bool -> [(n, n)]
go FixedSegment V2 n
p FixedSegment V2 n
q n
tmin n
tmax n
umin n
umax n
clip Bool
revCurves = case FixedSegment V2 n -> FixedSegment V2 n -> Maybe (n, n)
forall n.
OrderedField n =>
FixedSegment V2 n -> FixedSegment V2 n -> Maybe (n, n)
chopCubics FixedSegment V2 n
p FixedSegment V2 n
q of
    Maybe (n, n)
Nothing -> []
    -- This check happens before the subdivision
    -- test to avoid non-termination as values
    -- transition to within epsilon.
    Just (n
tminChop, n
tmaxChop)
      | n -> n -> n
forall a. Ord a => a -> a -> a
max (n
umax n -> n -> n
forall a. Num a => a -> a -> a
- n
umin) (n
tmax' n -> n -> n
forall a. Num a => a -> a -> a
- n
tmin') n -> n -> Bool
forall a. Ord a => a -> a -> Bool
< n
eps ->
          if Bool
revCurves -- return parameters in correct order
            then [(n -> n -> n
forall a. Fractional a => a -> a -> a
avg n
umin n
umax, n -> n -> n
forall a. Fractional a => a -> a -> a
avg n
tmin' n
tmax')]
            else [(n -> n -> n
forall a. Fractional a => a -> a -> a
avg n
tmin' n
tmax', n -> n -> n
forall a. Fractional a => a -> a -> a
avg n
umin n
umax)]
      -- split the curve if there isn't enough reduction
      | n
clip n -> n -> Bool
forall a. Ord a => a -> a -> Bool
> n
0.8 Bool -> Bool -> Bool
&& n
clip' n -> n -> Bool
forall a. Ord a => a -> a -> Bool
> n
0.8 ->
          if n
tmax' n -> n -> n
forall a. Num a => a -> a -> a
- n
tmin' n -> n -> Bool
forall a. Ord a => a -> a -> Bool
> n
umax n -> n -> n
forall a. Num a => a -> a -> a
- n
umin -- split the longest segment
            then
              let (FixedSegment V2 n
pl, FixedSegment V2 n
pr) = FixedSegment V2 n
p' FixedSegment V2 n
-> N (FixedSegment V2 n) -> (FixedSegment V2 n, FixedSegment V2 n)
forall p. Sectionable p => p -> N p -> (p, p)
`splitAtParam` n
N (FixedSegment V2 n)
0.5
                  tmid :: n
tmid = n -> n -> n
forall a. Fractional a => a -> a -> a
avg n
tmin' n
tmax'
               in FixedSegment V2 n
-> FixedSegment V2 n -> n -> n -> n -> n -> n -> Bool -> [(n, n)]
go FixedSegment V2 n
q FixedSegment V2 n
pl n
umin n
umax n
tmin' n
tmid n
clip' (Bool -> Bool
not Bool
revCurves)
                    [(n, n)] -> [(n, n)] -> [(n, n)]
forall a. [a] -> [a] -> [a]
++ FixedSegment V2 n
-> FixedSegment V2 n -> n -> n -> n -> n -> n -> Bool -> [(n, n)]
go FixedSegment V2 n
q FixedSegment V2 n
pr n
umin n
umax n
tmid n
tmax' n
clip' (Bool -> Bool
not Bool
revCurves)
            else
              let (FixedSegment V2 n
ql, FixedSegment V2 n
qr) = FixedSegment V2 n
q FixedSegment V2 n
-> N (FixedSegment V2 n) -> (FixedSegment V2 n, FixedSegment V2 n)
forall p. Sectionable p => p -> N p -> (p, p)
`splitAtParam` n
N (FixedSegment V2 n)
0.5
                  umid :: n
umid = n -> n -> n
forall a. Fractional a => a -> a -> a
avg n
umin n
umax
               in FixedSegment V2 n
-> FixedSegment V2 n -> n -> n -> n -> n -> n -> Bool -> [(n, n)]
go FixedSegment V2 n
ql FixedSegment V2 n
p' n
umin n
umid n
tmin' n
tmax' n
clip' (Bool -> Bool
not Bool
revCurves)
                    [(n, n)] -> [(n, n)] -> [(n, n)]
forall a. [a] -> [a] -> [a]
++ FixedSegment V2 n
-> FixedSegment V2 n -> n -> n -> n -> n -> n -> Bool -> [(n, n)]
go FixedSegment V2 n
qr FixedSegment V2 n
p' n
umid n
umax n
tmin' n
tmax' n
clip' (Bool -> Bool
not Bool
revCurves)
      -- iterate with the curves reversed.
      | Bool
otherwise -> FixedSegment V2 n
-> FixedSegment V2 n -> n -> n -> n -> n -> n -> Bool -> [(n, n)]
go FixedSegment V2 n
q FixedSegment V2 n
p' n
umin n
umax n
tmin' n
tmax' n
clip' (Bool -> Bool
not Bool
revCurves)
     where
      p' :: FixedSegment V2 n
p' = FixedSegment V2 n
-> N (FixedSegment V2 n)
-> N (FixedSegment V2 n)
-> FixedSegment V2 n
forall p. Sectionable p => p -> N p -> N p -> p
section FixedSegment V2 n
p n
N (FixedSegment V2 n)
tminChop n
N (FixedSegment V2 n)
tmaxChop
      clip' :: n
clip' = n
tmaxChop n -> n -> n
forall a. Num a => a -> a -> a
- n
tminChop
      tmin' :: n
tmin' = n
tmax n -> n -> n
forall a. Num a => a -> a -> a
* n
tminChop n -> n -> n
forall a. Num a => a -> a -> a
+ n
tmin n -> n -> n
forall a. Num a => a -> a -> a
* (n
1 n -> n -> n
forall a. Num a => a -> a -> a
- n
tminChop)
      tmax' :: n
tmax' = n
tmax n -> n -> n
forall a. Num a => a -> a -> a
* n
tmaxChop n -> n -> n
forall a. Num a => a -> a -> a
+ n
tmin n -> n -> n
forall a. Num a => a -> a -> a
* (n
1 n -> n -> n
forall a. Num a => a -> a -> a
- n
tmaxChop)

-- | Find the zero of a 1D Bêzier curve of any degree.  Note that this
--   can be used as a Bernstein polynomial root solver by converting from
--   the power basis to the Bernstein basis.
bezierFindRoot ::
  OrderedField n =>
  -- | The accuracy
  n ->
  -- | the Bernstein coefficients of the polynomial
  BernsteinPoly n ->
  -- | The lower bound of the interval
  n ->
  -- | The upper bound of the interval
  n ->
  -- | The roots found
  [n]
bezierFindRoot :: forall n. OrderedField n => n -> BernsteinPoly n -> n -> n -> [n]
bezierFindRoot n
eps BernsteinPoly n
p n
initMin n
initMax
  -- If we generated the max number of roots and tmax is also a root
  -- (which is not among the generated ones), there must in fact be an
  -- infinite number of roots, so just include tmax.
  | [n] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [n]
roots Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== BernsteinPoly n -> Int
forall n. BernsteinPoly n -> Int
bernsteinDegree BernsteinPoly n
p Bool -> Bool -> Bool
&& [n] -> n
forall a. HasCallStack => [a] -> a
last [n]
roots n -> n -> Bool
forall a. Eq a => a -> a -> Bool
/= n
initMax Bool -> Bool -> Bool
&& n -> n
forall a. Num a => a -> a
abs (BernsteinPoly n -> n -> n
forall n. Fractional n => BernsteinPoly n -> n -> n
evaluateBernstein BernsteinPoly n
p n
initMax) n -> n -> Bool
forall a. Ord a => a -> a -> Bool
<= n
eps =
      [n]
roots [n] -> [n] -> [n]
forall a. [a] -> [a] -> [a]
++ [n
initMax]
  | Bool
otherwise = [n]
roots
 where
  -- Lazily take a number of roots at most the degree of the bernstein
  -- polynomial, to avoid generating a ton of roots in the case of a
  -- straight Bezier segment along the x-axis. See https://github.com/diagrams/diagrams-contrib/issues/91 .
  roots :: [n]
roots = Int -> [n] -> [n]
forall a. Int -> [a] -> [a]
take (BernsteinPoly n -> Int
forall n. BernsteinPoly n -> Int
bernsteinDegree BernsteinPoly n
p) ([n] -> [n]) -> [n] -> [n]
forall a b. (a -> b) -> a -> b
$ BernsteinPoly n -> n -> n -> [n]
go BernsteinPoly n
p n
initMin n
initMax
  go :: BernsteinPoly n -> n -> n -> [n]
go BernsteinPoly n
pInit n
tmin n
tmax = case NonEmpty n -> Maybe (n, n)
forall n. OrderedField n => NonEmpty n -> Maybe (n, n)
chopYs (BernsteinPoly n -> NonEmpty n
forall n. BernsteinPoly n -> NonEmpty n
bernsteinCoeffs BernsteinPoly n
pInit) of
    Maybe (n, n)
Nothing -> []
    Just (n
tminChop, n
tmaxChop)
      | n
tmax' n -> n -> n
forall a. Num a => a -> a -> a
- n
tmin' n -> n -> Bool
forall a. Ord a => a -> a -> Bool
< n
eps -> [n -> n -> n
forall a. Fractional a => a -> a -> a
avg n
tmin' n
tmax']
      | n
clip n -> n -> Bool
forall a. Ord a => a -> a -> Bool
> n
0.8 ->
          let (BernsteinPoly n
p1, BernsteinPoly n
p2) = BernsteinPoly n
-> N (BernsteinPoly n) -> (BernsteinPoly n, BernsteinPoly n)
forall p. Sectionable p => p -> N p -> (p, p)
splitAtParam BernsteinPoly n
newP n
N (BernsteinPoly n)
0.5
              tmid :: n
tmid = n
tmin' n -> n -> n
forall a. Num a => a -> a -> a
+ (n
tmax' n -> n -> n
forall a. Num a => a -> a -> a
- n
tmin') n -> n -> n
forall a. Fractional a => a -> a -> a
/ n
2
           in BernsteinPoly n -> n -> n -> [n]
go BernsteinPoly n
p1 n
tmin' n
tmid
                [n] -> [n] -> [n]
forall a. [a] -> [a] -> [a]
++ BernsteinPoly n -> n -> n -> [n]
go BernsteinPoly n
p2 n
tmid n
tmax'
      | Bool
otherwise -> n -> BernsteinPoly n -> n -> n -> [n]
forall n. OrderedField n => n -> BernsteinPoly n -> n -> n -> [n]
bezierFindRoot n
eps BernsteinPoly n
newP n
tmin' n
tmax'
     where
      newP :: BernsteinPoly n
newP = BernsteinPoly n
-> N (BernsteinPoly n) -> N (BernsteinPoly n) -> BernsteinPoly n
forall p. Sectionable p => p -> N p -> N p -> p
section BernsteinPoly n
pInit n
N (BernsteinPoly n)
tminChop n
N (BernsteinPoly n)
tmaxChop
      clip :: n
clip = n
tmaxChop n -> n -> n
forall a. Num a => a -> a -> a
- n
tminChop
      tmin' :: n
tmin' = n
tmax n -> n -> n
forall a. Num a => a -> a -> a
* n
tminChop n -> n -> n
forall a. Num a => a -> a -> a
+ n
tmin n -> n -> n
forall a. Num a => a -> a -> a
* (n
1 n -> n -> n
forall a. Num a => a -> a -> a
- n
tminChop)
      tmax' :: n
tmax' = n
tmax n -> n -> n
forall a. Num a => a -> a -> a
* n
tmaxChop n -> n -> n
forall a. Num a => a -> a -> a
+ n
tmin n -> n -> n
forall a. Num a => a -> a -> a
* (n
1 n -> n -> n
forall a. Num a => a -> a -> a
- n
tmaxChop)

------------------------------------------------------------------------
-- Internal
------------------------------------------------------------------------

-- | An approximation of the fat line for a cubic Bêzier segment. Returns
--   @(0,0)@ for a linear segment.
fatLine :: OrderedField n => FixedSegment V2 n -> (n, n)
fatLine :: forall n. OrderedField n => FixedSegment V2 n -> (n, n)
fatLine (FCubic Point V2 n
p0 Point V2 n
p1 Point V2 n
p2 Point V2 n
p3) =
  case (n
d1 n -> n -> Bool
forall a. Ord a => a -> a -> Bool
> n
0, n
d2 n -> n -> Bool
forall a. Ord a => a -> a -> Bool
> n
0) of
    (Bool
True, Bool
True) -> (n
0, n
0.75 n -> n -> n
forall a. Num a => a -> a -> a
* n -> n -> n
forall a. Ord a => a -> a -> a
max n
d1 n
d2)
    (Bool
False, Bool
False) -> (n
0.75 n -> n -> n
forall a. Num a => a -> a -> a
* n -> n -> n
forall a. Ord a => a -> a -> a
min n
d1 n
d2, n
0)
    (Bool
True, Bool
False) -> (n
4 n -> n -> n
forall a. Fractional a => a -> a -> a
/ n
9 n -> n -> n
forall a. Num a => a -> a -> a
* n
d2, n
4 n -> n -> n
forall a. Fractional a => a -> a -> a
/ n
9 n -> n -> n
forall a. Num a => a -> a -> a
* n
d1)
    (Bool
False, Bool
True) -> (n
4 n -> n -> n
forall a. Fractional a => a -> a -> a
/ n
9 n -> n -> n
forall a. Num a => a -> a -> a
* n
d1, n
4 n -> n -> n
forall a. Fractional a => a -> a -> a
/ n
9 n -> n -> n
forall a. Num a => a -> a -> a
* n
d2)
 where
  d :: Point V2 n -> n
d = Point V2 n -> Point V2 n -> Point V2 n -> n
forall n. (Ord n, Floating n) => P2 n -> P2 n -> P2 n -> n
lineDistance Point V2 n
p0 Point V2 n
p3
  d1 :: n
d1 = Point V2 n -> n
d Point V2 n
p1
  d2 :: n
d2 = Point V2 n -> n
d Point V2 n
p2
fatLine FixedSegment V2 n
_ = (n
0, n
0)

chopYs :: OrderedField n => NonEmpty n -> Maybe (n, n)
chopYs :: forall n. OrderedField n => NonEmpty n -> Maybe (n, n)
chopYs NonEmpty n
ds = n -> n -> NonEmpty (P2 n) -> Maybe (n, n)
forall n.
OrderedField n =>
n -> n -> NonEmpty (P2 n) -> Maybe (n, n)
chopHull n
0 n
0 NonEmpty (P2 n)
points
 where
  points :: NonEmpty (P2 n)
points = (n -> n -> P2 n) -> NonEmpty n -> NonEmpty n -> NonEmpty (P2 n)
forall a b c.
(a -> b -> c) -> NonEmpty a -> NonEmpty b -> NonEmpty c
NE.zipWith n -> n -> P2 n
forall n. n -> n -> P2 n
mkP2 ((Integer -> n -> n) -> NonEmpty Integer -> NonEmpty n -> NonEmpty n
forall a b c.
(a -> b -> c) -> NonEmpty a -> NonEmpty b -> NonEmpty c
NE.zipWith (\Integer
i n
_ -> forall a b. (Integral a, Num b) => a -> b
fromIntegral @Integer Integer
i n -> n -> n
forall a. Fractional a => a -> a -> a
/ Int -> n
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n) (Integer
0 Integer -> [Integer] -> NonEmpty Integer
forall a. a -> [a] -> NonEmpty a
:| [Integer
1 ..]) NonEmpty n
ds) NonEmpty n
ds
  n :: Int
n = NonEmpty n -> Int
forall a. NonEmpty a -> Int
NE.length NonEmpty n
ds Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1

chopCubics :: OrderedField n => FixedSegment V2 n -> FixedSegment V2 n -> Maybe (n, n)
chopCubics :: forall n.
OrderedField n =>
FixedSegment V2 n -> FixedSegment V2 n -> Maybe (n, n)
chopCubics FixedSegment V2 n
p q :: FixedSegment V2 n
q@(FCubic Point V2 n
q0 Point V2 n
_ Point V2 n
_ Point V2 n
q3) =
  n -> n -> NonEmpty (Point V2 n) -> Maybe (n, n)
forall n.
OrderedField n =>
n -> n -> NonEmpty (P2 n) -> Maybe (n, n)
chopHull n
dmin n
dmax NonEmpty (Point V2 n)
dps
 where
  dps :: NonEmpty (Point V2 n)
dps = (n -> n -> Point V2 n)
-> NonEmpty n -> NonEmpty n -> NonEmpty (Point V2 n)
forall a b c.
(a -> b -> c) -> NonEmpty a -> NonEmpty b -> NonEmpty c
NE.zipWith n -> n -> Point V2 n
forall n. n -> n -> P2 n
mkP2 (n
0 n -> [n] -> NonEmpty n
forall a. a -> [a] -> NonEmpty a
:| [n
1 n -> n -> n
forall a. Fractional a => a -> a -> a
/ n
3, n
2 n -> n -> n
forall a. Fractional a => a -> a -> a
/ n
3, n
1]) NonEmpty n
ds
  ds :: NonEmpty n
ds = (Point V2 n -> n) -> NonEmpty (Point V2 n) -> NonEmpty n
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
NE.map Point V2 n -> n
d (NonEmpty (Point V2 n) -> NonEmpty n)
-> NonEmpty (Point V2 n) -> NonEmpty n
forall a b. (a -> b) -> a -> b
$ case FixedSegment V2 n
p of
    FLinear Point V2 n
p0 Point V2 n
p1 -> Point V2 n
p0 Point V2 n -> [Point V2 n] -> NonEmpty (Point V2 n)
forall a. a -> [a] -> NonEmpty a
:| [Point V2 n
p1]
    FCubic Point V2 n
p0 Point V2 n
p1 Point V2 n
p2 Point V2 n
p3 -> Point V2 n
p0 Point V2 n -> [Point V2 n] -> NonEmpty (Point V2 n)
forall a. a -> [a] -> NonEmpty a
:| [Point V2 n
p1, Point V2 n
p2, Point V2 n
p3]
  d :: Point V2 n -> n
d = Point V2 n -> Point V2 n -> Point V2 n -> n
forall n. (Ord n, Floating n) => P2 n -> P2 n -> P2 n -> n
lineDistance Point V2 n
q0 Point V2 n
q3
  --
  (n
dmin, n
dmax) = FixedSegment V2 n -> (n, n)
forall n. OrderedField n => FixedSegment V2 n -> (n, n)
fatLine FixedSegment V2 n
q
chopCubics FixedSegment V2 n
_ FixedSegment V2 n
_ = Maybe (n, n)
forall a. Maybe a
Nothing

-- Reduce the interval which the intersection is known to lie in using the fat
-- line of one curve and convex hull of the points formed from the distance to
-- the thin line of the other
chopHull :: OrderedField n => n -> n -> NonEmpty (P2 n) -> Maybe (n, n)
chopHull :: forall n.
OrderedField n =>
n -> n -> NonEmpty (P2 n) -> Maybe (n, n)
chopHull n
dmin n
dmax NonEmpty (P2 n)
dps = do
  n
tL <- NonEmpty (P2 n) -> Maybe n -> Maybe n
testBelow NonEmpty (P2 n)
upper (Maybe n -> Maybe n) -> Maybe n -> Maybe n
forall a b. (a -> b) -> a -> b
$ P2 n -> Maybe n -> Maybe n
testBetween (NonEmpty (P2 n) -> P2 n
forall a. NonEmpty a -> a
NE.head NonEmpty (P2 n)
upper) (Maybe n -> Maybe n) -> Maybe n -> Maybe n
forall a b. (a -> b) -> a -> b
$ NonEmpty (P2 n) -> Maybe n
testAbove NonEmpty (P2 n)
lower
  n
tR <- NonEmpty (P2 n) -> Maybe n -> Maybe n
testBelow (NonEmpty (P2 n) -> NonEmpty (P2 n)
forall a. NonEmpty a -> NonEmpty a
NE.reverse NonEmpty (P2 n)
upper) (Maybe n -> Maybe n) -> Maybe n -> Maybe n
forall a b. (a -> b) -> a -> b
$ P2 n -> Maybe n -> Maybe n
testBetween (NonEmpty (P2 n) -> P2 n
forall a. NonEmpty a -> a
NE.last NonEmpty (P2 n)
upper) (Maybe n -> Maybe n) -> Maybe n -> Maybe n
forall a b. (a -> b) -> a -> b
$ NonEmpty (P2 n) -> Maybe n
testAbove (NonEmpty (P2 n) -> NonEmpty (P2 n)
forall a. NonEmpty a -> NonEmpty a
NE.reverse NonEmpty (P2 n)
lower)
  (n, n) -> Maybe (n, n)
forall a. a -> Maybe a
Just (n
tL, n
tR)
 where
  (NonEmpty (P2 n)
upper, NonEmpty (P2 n)
lower) = NonEmpty (P2 n) -> (NonEmpty (P2 n), NonEmpty (P2 n))
forall n.
OrderedField n =>
NonEmpty (P2 n) -> (NonEmpty (P2 n), NonEmpty (P2 n))
sortedConvexHull NonEmpty (P2 n)
dps

  testBelow :: NonEmpty (P2 n) -> Maybe n -> Maybe n
testBelow (p1 :: P2 n
p1@(P (V2 n
_ n
y1)) :| p2 :: P2 n
p2@(P (V2 n
_ n
y2)) : [P2 n]
ps) Maybe n
continue
    | n
y1 n -> n -> Bool
forall a. Ord a => a -> a -> Bool
>= n
dmin = Maybe n
continue
    | n
y1 n -> n -> Bool
forall a. Ord a => a -> a -> Bool
> n
y2 = Maybe n
forall a. Maybe a
Nothing
    | n
y2 n -> n -> Bool
forall a. Ord a => a -> a -> Bool
< n
dmin = NonEmpty (P2 n) -> Maybe n -> Maybe n
testBelow (P2 n
p2 P2 n -> [P2 n] -> NonEmpty (P2 n)
forall a. a -> [a] -> NonEmpty a
:| [P2 n]
ps) Maybe n
continue
    | Bool
otherwise = n -> Maybe n
forall a. a -> Maybe a
Just (n -> Maybe n) -> n -> Maybe n
forall a b. (a -> b) -> a -> b
$ n -> P2 n -> P2 n -> n
forall {a}. Fractional a => a -> Point V2 a -> Point V2 a -> a
intersectPt n
dmin P2 n
p1 P2 n
p2
  testBelow NonEmpty (P2 n)
_ Maybe n
_ = Maybe n
forall a. Maybe a
Nothing

  testBetween :: P2 n -> Maybe n -> Maybe n
testBetween (P (V2 n
x n
y)) Maybe n
continue
    | n
y n -> n -> Bool
forall a. Ord a => a -> a -> Bool
<= n
dmax = n -> Maybe n
forall a. a -> Maybe a
Just n
x
    | Bool
otherwise = Maybe n
continue

  testAbove :: NonEmpty (P2 n) -> Maybe n
testAbove (p1 :: P2 n
p1@(P (V2 n
_ n
y1)) :| p2 :: P2 n
p2@(P (V2 n
_ n
y2)) : [P2 n]
ps)
    | n
y1 n -> n -> Bool
forall a. Ord a => a -> a -> Bool
< n
y2 = Maybe n
forall a. Maybe a
Nothing
    | n
y2 n -> n -> Bool
forall a. Ord a => a -> a -> Bool
> n
dmax = NonEmpty (P2 n) -> Maybe n
testAbove (P2 n
p2 P2 n -> [P2 n] -> NonEmpty (P2 n)
forall a. a -> [a] -> NonEmpty a
:| [P2 n]
ps)
    | n
y2 n -> n -> n
forall a. Num a => a -> a -> a
- n
y1 n -> n -> Bool
forall a. Eq a => a -> a -> Bool
== n
0 = Maybe n
forall a. Maybe a
Nothing -- Check this condition to prevent
    -- division by zero in `intersectPt`.
    | Bool
otherwise = n -> Maybe n
forall a. a -> Maybe a
Just (n -> Maybe n) -> n -> Maybe n
forall a b. (a -> b) -> a -> b
$ n -> P2 n -> P2 n -> n
forall {a}. Fractional a => a -> Point V2 a -> Point V2 a -> a
intersectPt n
dmax P2 n
p1 P2 n
p2
  testAbove NonEmpty (P2 n)
_ = Maybe n
forall a. Maybe a
Nothing

  -- find the x value where the line through the two points
  -- intersect the line y=d.  Note that `y2 - y1 != 0` due
  -- to checks above.
  intersectPt :: a -> Point V2 a -> Point V2 a -> a
intersectPt a
d (P (V2 a
x1 a
y1)) (P (V2 a
x2 a
y2)) =
    a
x1 a -> a -> a
forall a. Num a => a -> a -> a
+ (a
d a -> a -> a
forall a. Num a => a -> a -> a
- a
y1) a -> a -> a
forall a. Num a => a -> a -> a
* (a
x2 a -> a -> a
forall a. Num a => a -> a -> a
- a
x1) a -> a -> a
forall a. Fractional a => a -> a -> a
/ (a
y2 a -> a -> a
forall a. Num a => a -> a -> a
- a
y1)

bezierToBernstein :: Fractional n => FixedSegment V2 n -> (BernsteinPoly n, BernsteinPoly n)
bezierToBernstein :: forall n.
Fractional n =>
FixedSegment V2 n -> (BernsteinPoly n, BernsteinPoly n)
bezierToBernstein FixedSegment V2 n
seg =
  ([n] -> BernsteinPoly n
forall n. Fractional n => [n] -> BernsteinPoly n
listToBernstein ([n] -> BernsteinPoly n) -> [n] -> BernsteinPoly n
forall a b. (a -> b) -> a -> b
$ (Point V2 n -> n) -> [Point V2 n] -> [n]
forall a b. (a -> b) -> [a] -> [b]
map (Getting n (Point V2 n) n -> Point V2 n -> n
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting n (Point V2 n) n
forall a. Lens' (Point V2 a) a
forall (t :: * -> *) a. R1 t => Lens' (t a) a
_x) [Point V2 n]
coeffs, [n] -> BernsteinPoly n
forall n. Fractional n => [n] -> BernsteinPoly n
listToBernstein ([n] -> BernsteinPoly n) -> [n] -> BernsteinPoly n
forall a b. (a -> b) -> a -> b
$ (Point V2 n -> n) -> [Point V2 n] -> [n]
forall a b. (a -> b) -> [a] -> [b]
map (Getting n (Point V2 n) n -> Point V2 n -> n
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting n (Point V2 n) n
forall a. Lens' (Point V2 a) a
forall (t :: * -> *) a. R2 t => Lens' (t a) a
_y) [Point V2 n]
coeffs)
 where
  coeffs :: [Point V2 n]
coeffs = Getting (Endo [Point V2 n]) (FixedSegment V2 n) (Point V2 n)
-> FixedSegment V2 n -> [Point V2 n]
forall a s. Getting (Endo [a]) s a -> s -> [a]
toListOf Getting (Endo [Point V2 n]) (FixedSegment V2 n) (Point V2 n)
forall s t a b. Each s t a b => Traversal s t a b
Traversal
  (FixedSegment V2 n) (FixedSegment V2 n) (Point V2 n) (Point V2 n)
each FixedSegment V2 n
seg

------------------------------------------------------------------------
-- Lines
------------------------------------------------------------------------

-- Could split this into a separate module.

-- | Returns @(a, b, c, d)@ such that @ax + by + c = 0@ is the line going through
--   @p1@ and @p2@ with @(a^2)/d + (b^2)/d = 1@.  We delay the division by
--   @d@ as it may not be needed in all cases and @d@ may be zero.
lineEquation :: Floating n => P2 n -> P2 n -> (n, n, n, n)
lineEquation :: forall n. Floating n => P2 n -> P2 n -> (n, n, n, n)
lineEquation (P (V2 n
x1 n
y1)) (P (V2 n
x2 n
y2)) = (n
a, n
b, n
c, n
d)
 where
  c :: n
c = -(n
x1 n -> n -> n
forall a. Num a => a -> a -> a
* n
a n -> n -> n
forall a. Num a => a -> a -> a
+ n
y1 n -> n -> n
forall a. Num a => a -> a -> a
* n
b)
  a :: n
a = n
y1 n -> n -> n
forall a. Num a => a -> a -> a
- n
y2
  b :: n
b = n
x2 n -> n -> n
forall a. Num a => a -> a -> a
- n
x1
  d :: n
d = n
a n -> n -> n
forall a. Num a => a -> a -> a
* n
a n -> n -> n
forall a. Num a => a -> a -> a
+ n
b n -> n -> n
forall a. Num a => a -> a -> a
* n
b

-- | Return the distance from a point to the line.
lineDistance :: (Ord n, Floating n) => P2 n -> P2 n -> P2 n -> n
lineDistance :: forall n. (Ord n, Floating n) => P2 n -> P2 n -> P2 n -> n
lineDistance P2 n
p1 P2 n
p2 p3 :: P2 n
p3@(P (V2 n
x n
y))
  -- I have included the check that d' <= 0 in case
  -- there exists some d > 0 where sqrt d == 0.  I don't
  -- think this can happen as sqrt is at least recommended
  -- to be within one value of correct for sqrt and near
  -- zero values get bigger.
  | n
d n -> n -> Bool
forall a. Ord a => a -> a -> Bool
<= n
0 Bool -> Bool -> Bool
|| n
d' n -> n -> Bool
forall a. Ord a => a -> a -> Bool
<= n
0 = V2 n -> n
forall a. Floating a => V2 a -> a
forall (f :: * -> *) a. (Metric f, Floating a) => f a -> a
norm (P2 n
p1 P2 n -> P2 n -> Diff (Point V2) n
forall a. Num a => Point V2 a -> Point V2 a -> Diff (Point V2) a
forall (p :: * -> *) a. (Affine p, Num a) => p a -> p a -> Diff p a
.-. P2 n
p3)
  | Bool
otherwise = (n
a n -> n -> n
forall a. Num a => a -> a -> a
* n
x n -> n -> n
forall a. Num a => a -> a -> a
+ n
b n -> n -> n
forall a. Num a => a -> a -> a
* n
y n -> n -> n
forall a. Num a => a -> a -> a
+ n
c) n -> n -> n
forall a. Fractional a => a -> a -> a
/ n
d'
 where
  (n
a, n
b, n
c, n
d) = P2 n -> P2 n -> (n, n, n, n)
forall n. Floating n => P2 n -> P2 n -> (n, n, n, n)
lineEquation P2 n
p1 P2 n
p2
  d' :: n
d' = n -> n
forall a. Floating a => a -> a
sqrt n
d

-- clockwise :: (Num n, Ord n) => V2 n -> V2 n -> Bool
-- clockwise a b = a `cross2` b <= 0

avg :: Fractional n => n -> n -> n
avg :: forall a. Fractional a => a -> a -> a
avg n
a n
b = (n
a n -> n -> n
forall a. Num a => a -> a -> a
+ n
b) n -> n -> n
forall a. Fractional a => a -> a -> a
/ n
2

lineLine :: (Fractional n, Eq n) => Located (V2 n) -> Located (V2 n) -> Maybe (n, n)
lineLine :: forall n.
(Fractional n, Eq n) =>
Located (V2 n) -> Located (V2 n) -> Maybe (n, n)
lineLine (Located (V2 n) -> (Point (V (V2 n)) (N (V2 n)), V2 n)
forall a. Located a -> (Point (V a) (N a), a)
viewLoc -> (Point (V (V2 n)) (N (V2 n))
p, V2 n
r)) (Located (V2 n) -> (Point (V (V2 n)) (N (V2 n)), V2 n)
forall a. Located a -> (Point (V a) (N a), a)
viewLoc -> (Point (V (V2 n)) (N (V2 n))
q, V2 n
s))
  | n
x1 n -> n -> Bool
forall a. Eq a => a -> a -> Bool
== n
0 Bool -> Bool -> Bool
&& n
x2 n -> n -> Bool
forall a. Eq a => a -> a -> Bool
/= n
0 = Maybe (n, n)
forall a. Maybe a
Nothing -- parallel
  | Bool
otherwise = (n, n) -> Maybe (n, n)
forall a. a -> Maybe a
Just (n
x3 n -> n -> n
forall a. Fractional a => a -> a -> a
/ n
x1, n
x2 n -> n -> n
forall a. Fractional a => a -> a -> a
/ n
x1) -- intersecting or collinear
 where
  x1 :: n
x1 = V2 n
r V2 n -> V2 n -> n
forall a. Num a => V2 a -> V2 a -> a
× V2 n
s
  x2 :: n
x2 = V2 n
Diff (Point V2) n
v V2 n -> V2 n -> n
forall a. Num a => V2 a -> V2 a -> a
× V2 n
r
  x3 :: n
x3 = V2 n
Diff (Point V2) n
v V2 n -> V2 n -> n
forall a. Num a => V2 a -> V2 a -> a
× V2 n
s
  v :: Diff (Point V2) n
v = Point (V (V2 n)) (N (V2 n))
Point V2 n
q Point V2 n -> Point V2 n -> Diff (Point V2) n
forall a. Num a => Point V2 a -> Point V2 a -> Diff (Point V2) a
forall (p :: * -> *) a. (Affine p, Num a) => p a -> p a -> Diff p a
.-. Point (V (V2 n)) (N (V2 n))
Point V2 n
p

(×) :: Num n => V2 n -> V2 n -> n
× :: forall a. Num a => V2 a -> V2 a -> a
(×) = V2 n -> V2 n -> n
forall a. Num a => V2 a -> V2 a -> a
cross2

mkLine :: InSpace v n (v n) => Point v n -> Point v n -> Located (v n)
mkLine :: forall (v :: * -> *) n.
InSpace v n (v n) =>
Point v n -> Point v n -> Located (v n)
mkLine Point v n
p0 Point v n
p1 = (Point v n
p1 Point v n -> Point v n -> Diff (Point v) n
forall a. Num a => Point v a -> Point v a -> Diff (Point v) a
forall (p :: * -> *) a. (Affine p, Num a) => p a -> p a -> Diff p a
.-. Point v n
p0) v n -> Point (V (v n)) (N (v n)) -> Located (v n)
forall a. a -> Point (V a) (N a) -> Located a
`at` Point v n
Point (V (v n)) (N (v n))
p0

segLine :: InSpace v n (v n) => FixedSegment v n -> Located (v n)
segLine :: forall (v :: * -> *) n.
InSpace v n (v n) =>
FixedSegment v n -> Located (v n)
segLine (FLinear Point v n
p0 Point v n
p1) = Point v n -> Point v n -> Located (v n)
forall (v :: * -> *) n.
InSpace v n (v n) =>
Point v n -> Point v n -> Located (v n)
mkLine Point v n
p0 Point v n
p1
segLine (FCubic Point v n
p0 Point v n
_ Point v n
_ Point v n
p3) = Point v n -> Point v n -> Located (v n)
forall (v :: * -> *) n.
InSpace v n (v n) =>
Point v n -> Point v n -> Located (v n)
mkLine Point v n
p0 Point v n
p3

-- This function uses `defEps`, but is used in functions
-- above that take an epsilon parameter.  It would be nice
-- to clearify the meaning of each of these epsilons.
inRange :: (Fractional n, Ord n) => n -> Bool
inRange :: forall n. (Fractional n, Ord n) => n -> Bool
inRange n
x = n
x n -> n -> Bool
forall a. Ord a => a -> a -> Bool
< (n
1 n -> n -> n
forall a. Num a => a -> a -> a
+ n
forall n. Fractional n => n
defEps) Bool -> Bool -> Bool
&& n
x n -> n -> Bool
forall a. Ord a => a -> a -> Bool
> (-n
forall n. Fractional n => n
defEps)