{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts     #-}
{-# LANGUAGE FlexibleInstances    #-}
{-# LANGUAGE TypeFamilies         #-}
{-# LANGUAGE ViewPatterns         #-}
{-# LANGUAGE UndecidableInstances #-}

{-# 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.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 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))
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 V2 n -> V2 n -> SortedList n) -> Trace V2 n
forall (v :: * -> *) n.
(Point v n -> v n -> SortedList n) -> Trace v n
mkTrace ((Point V2 n -> V2 n -> SortedList n) -> Trace V2 n)
-> (Point V2 n -> V2 n -> SortedList n) -> Trace V2 n
forall a b. (a -> b) -> a -> b
$ \Point V2 n
p V2 n
v ->
    [n] -> SortedList n
forall a. Ord a => [a] -> SortedList a
mkSortedList ([n] -> SortedList n)
-> ([(n, n, Point V2 n)] -> [n])
-> [(n, n, Point V2 n)]
-> SortedList n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((n, n, Point V2 n) -> n) -> [(n, n, Point V2 n)] -> [n]
forall a b. (a -> b) -> [a] -> [b]
map (Getting n (n, n, Point V2 n) n -> (n, n, Point V2 n) -> n
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting n (n, n, Point V2 n) n
forall s t a b. Field1 s t a b => Lens s t a b
_1) ([(n, n, Point V2 n)] -> SortedList n)
-> [(n, n, Point V2 n)] -> SortedList n
forall a b. (a -> b) -> a -> b
$ n -> Located (V2 n) -> FixedSegment V2 n -> [(n, n, Point V2 n)]
forall n.
OrderedField n =>
n -> Located (V2 n) -> FixedSegment V2 n -> [(n, n, P2 n)]
lineSegment n
forall n. Fractional n => n
defEps (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 V2 n
p) FixedSegment V2 n
seg

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

-- | Compute the intersections between two fixed segments.
intersectPointsS :: OrderedField n => FixedSegment V2 n -> FixedSegment V2 n -> [P2 n]
intersectPointsS :: 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' :: 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
_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 :: 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' :: 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 :: 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' :: 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 :: 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' :: n -> FixedSegment V2 n -> P2 n -> [n]
closestParam' n
_ (FLinear P2 n
p0 P2 n
p1) P2 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 = P2 n
p  P2 n -> P2 n -> Diff (Point V2) n
forall (p :: * -> *) a. (Affine p, Num a) => p a -> p a -> Diff p a
.-. P2 n
p0
    v :: Diff (Point V2) n
v  = P2 n
p1 P2 n -> P2 n -> Diff (Point V2) n
forall (p :: * -> *) a. (Affine p, Num a) => p a -> p a -> Diff p a
.-. P2 n
p0
    dp :: n
dp = Diff (Point V2) n
V2 n
vp V2 n -> V2 n -> n
forall (f :: * -> *) a. (Metric f, Num a) => f a -> f a -> a
`dot` Diff (Point V2) n
V2 n
v
    t :: n
t  = n
dp n -> n -> n
forall a. Fractional a => a -> a -> a
/ V2 n -> n
forall (f :: * -> *) a. (Metric f, Num a) => f a -> a
quadrance Diff (Point V2) n
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 :: 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
_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 :: n -> Located (V2 n) -> FixedSegment V2 n -> [(n, n, P2 n)]
lineSegment n
_ Located (V2 n)
l1 p :: FixedSegment V2 n
p@(FLinear P2 n
p0 P2 n
p1)
  = ((n, n) -> (n, n, P2 n)) -> [(n, n)] -> [(n, n, P2 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, P2 n)])
-> (Maybe (n, n) -> [(n, n)]) -> Maybe (n, n) -> [(n, n, P2 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, P2 n)]) -> Maybe (n, n) -> [(n, n, P2 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 (P2 n -> P2 n -> Located (V2 n)
forall (v :: * -> *) n.
InSpace v n (v n) =>
Point v n -> Point v n -> Located (v n)
mkLine P2 n
p0 P2 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, P2 n)) -> [n] -> [(n, n, P2 n)]
forall a b. (a -> b) -> [a] -> [b]
map n -> (n, n, P2 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]
^.. (P2 n -> Const (Endo [n]) (P2 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
each ((P2 n -> Const (Endo [n]) (P2 n))
 -> FixedSegment V2 n -> Const (Endo [n]) (FixedSegment V2 n))
-> ((n -> Const (Endo [n]) n) -> P2 n -> Const (Endo [n]) (P2 n))
-> Getting (Endo [n]) (FixedSegment V2 n) n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (n -> Const (Endo [n]) n) -> P2 n -> Const (Endo [n]) (P2 n)
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, P2 n)
addPoint n
bt = (n
lt, n
bt, P2 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) P2 n -> Getting n (P2 n) n -> n
forall s a. s -> Getting a s a -> a
^. Getting n (P2 n) n
forall (t :: * -> *) a. R1 t => Lens' (t a) a
_x n -> n -> n
forall a. Fractional a => a -> a -> a
/ V2 n -> n
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 :: 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
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) -- sometimes this returns NaN
                     ([(n, n)] -> [(n, n)]) -> [(n, n)] -> [(n, n)]
forall a b. (a -> b) -> a -> b
$ 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
    | Maybe (n, n) -> Bool
forall a. Maybe a -> Bool
isNothing Maybe (n, n)
chopInterval = []

    -- This check happens before the subdivision
    -- test to avoid non-termination as values
    -- transition to within epsilon.
    | 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 (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 (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
      chopInterval :: Maybe (n, n)
chopInterval              = 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
      Just (n
tminChop, n
tmaxChop) = Maybe (n, n)
chopInterval
      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
               => n   -- ^ The accuracy
               -> BernsteinPoly n -- ^ the Bernstein coefficients of the polynomial
               -> n   -- ^ The lower bound of the interval
               -> n   -- ^ The upper bound of the interval
               -> [n] -- ^ The roots found
bezierFindRoot :: n -> BernsteinPoly n -> n -> n -> [n]
bezierFindRoot n
eps BernsteinPoly n
p n
tmin n
tmax
  | Maybe (n, n) -> Bool
forall a. Maybe a -> Bool
isNothing Maybe (n, n)
chopInterval    = []
  | 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 (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  n -> BernsteinPoly n -> n -> n -> [n]
forall n. OrderedField n => n -> BernsteinPoly n -> n -> n -> [n]
bezierFindRoot n
eps BernsteinPoly n
p1 n
tmin' n
tmid  [n] -> [n] -> [n]
forall a. [a] -> [a] -> [a]
++
                     n -> BernsteinPoly n -> n -> n -> [n]
forall n. OrderedField n => n -> BernsteinPoly n -> n -> n -> [n]
bezierFindRoot n
eps BernsteinPoly n
p2 n
tmid  n
tmax'
  | 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']
  | 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
    chopInterval :: Maybe (n, n)
chopInterval              = [n] -> Maybe (n, n)
forall n. OrderedField n => [n] -> Maybe (n, n)
chopYs (BernsteinPoly n -> [n]
forall n. BernsteinPoly n -> [n]
bernsteinCoeffs BernsteinPoly n
p)
    Just (n
tminChop, n
tmaxChop) = Maybe (n, n)
chopInterval
    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
p 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 :: 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
4n -> n -> n
forall a. Fractional a => a -> a -> a
/n
9 n -> n -> n
forall a. Num a => a -> a -> a
* n
d2,         n
4n -> 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
4n -> n -> n
forall a. Fractional a => a -> a -> a
/n
9 n -> n -> n
forall a. Num a => a -> a -> a
* n
d1,         n
4n -> 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 => [n] -> Maybe (n, n)
chopYs :: [n] -> Maybe (n, n)
chopYs [n]
ds = n -> n -> [P2 n] -> Maybe (n, n)
forall n. OrderedField n => n -> n -> [P2 n] -> Maybe (n, n)
chopHull n
0 n
0 [P2 n]
points
  where
    points :: [P2 n]
points = (n -> n -> P2 n) -> [n] -> [n] -> [P2 n]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith n -> n -> P2 n
forall n. n -> n -> P2 n
mkP2 [Int -> n
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
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 | Int
i <- [Int
0..Int
n]] [n]
ds
    n :: Int
n      = [n] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [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 :: 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 -> [Point V2 n] -> Maybe (n, n)
forall n. OrderedField n => n -> n -> [P2 n] -> Maybe (n, n)
chopHull n
dmin n
dmax [Point V2 n]
dps
  where
    dps :: [Point V2 n]
dps = (n -> n -> Point V2 n) -> [n] -> [n] -> [Point V2 n]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith n -> n -> Point V2 n
forall n. n -> n -> P2 n
mkP2 [n
0, n
1n -> n -> n
forall a. Fractional a => a -> a -> a
/n
3, n
2n -> n -> n
forall a. Fractional a => a -> a -> a
/n
3, n
1] [n]
ds
    ds :: [n]
ds  = FixedSegment V2 n
p 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
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
. (Point V2 n -> n)
-> (n -> Const (Endo [n]) n)
-> Point V2 n
-> Const (Endo [n]) (Point V2 n)
forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to Point V2 n -> n
d
    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 -> [P2 n] -> Maybe (n, n)
chopHull :: n -> n -> [P2 n] -> Maybe (n, n)
chopHull n
dmin n
dmax [P2 n]
dps = do
  n
tL <- [P2 n] -> Maybe n -> Maybe n
testBelow [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 ([P2 n] -> P2 n
forall a. [a] -> a
head [P2 n]
upper) (Maybe n -> Maybe n) -> Maybe n -> Maybe n
forall a b. (a -> b) -> a -> b
$ [P2 n] -> Maybe n
testAbove [P2 n]
lower
  n
tR <- [P2 n] -> Maybe n -> Maybe n
testBelow ([P2 n] -> [P2 n]
forall a. [a] -> [a]
reverse [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 ([P2 n] -> P2 n
forall a. [a] -> a
last [P2 n]
upper) (Maybe n -> Maybe n) -> Maybe n -> Maybe n
forall a b. (a -> b) -> a -> b
$ [P2 n] -> Maybe n
testAbove ([P2 n] -> [P2 n]
forall a. [a] -> [a]
reverse [P2 n]
lower)
  (n, n) -> Maybe (n, n)
forall a. a -> Maybe a
Just (n
tL, n
tR)
    where
      ([P2 n]
upper, [P2 n]
lower) = [P2 n] -> ([P2 n], [P2 n])
forall n. OrderedField n => [P2 n] -> ([P2 n], [P2 n])
sortedConvexHull [P2 n]
dps

      testBelow :: [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 = [P2 n] -> Maybe n -> Maybe n
testBelow (P2 n
p2P2 n -> [P2 n] -> [P2 n]
forall a. a -> [a] -> [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 [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 :: [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    = [P2 n] -> Maybe n
testAbove (P2 n
p2P2 n -> [P2 n] -> [P2 n]
forall a. a -> [a] -> [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 [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 :: 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 (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 (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
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 :: 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
x1n -> n -> n
forall a. Num a => a -> a -> a
*n
a n -> n -> n
forall a. Num a => a -> a -> a
+ n
y1n -> 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
an -> n -> n
forall a. Num a => a -> a -> a
*n
a n -> n -> n
forall a. Num a => a -> a -> a
+ n
bn -> 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 :: 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 (f :: * -> *) a. (Metric f, Floating a) => f a -> a
norm (P2 n
p1 P2 n -> P2 n -> Diff (Point V2) n
forall (p :: * -> *) a. (Affine p, Num a) => p a -> p a -> Diff p a
.-. P2 n
p3)
    | Bool
otherwise = (n
an -> n -> n
forall a. Num a => a -> a -> a
*n
x n -> n -> n
forall a. Num a => a -> a -> a
+ n
bn -> 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 :: n -> n -> n
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 :: 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 n. Num n => V2 n -> V2 n -> n
× V2 n
s
    x2 :: n
x2 = Diff (Point V2) n
V2 n
v V2 n -> V2 n -> n
forall n. Num n => V2 n -> V2 n -> n
× V2 n
r
    x3 :: n
x3 = Diff (Point V2) n
V2 n
v V2 n -> V2 n -> n
forall n. Num n => V2 n -> V2 n -> n
× 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 (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
× :: V2 n -> V2 n -> n
(×) = V2 n -> V2 n -> n
forall n. Num n => V2 n -> V2 n -> n
cross2

mkLine :: InSpace v n (v n) => Point v n -> Point v n -> Located (v n)
mkLine :: 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 (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 :: 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 :: n -> Bool
inRange n
x = n
x n -> n -> Bool
forall a. Ord a => a -> a -> Bool
< (n
1n -> 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)