{-# LANGUAGE UndecidableInstances #-}
--------------------------------------------------------------------------------
-- |
-- Module      :  Data.Geometry.BezierSpline
-- Copyright   :  (C) Frank Staals
-- License     :  see the LICENSE file
-- Maintainer  :  Frank Staals
--------------------------------------------------------------------------------
module Data.Geometry.BezierSpline(
    BezierSpline (BezierSpline)
  , controlPoints
  , fromPointSeq

  , evaluate
  , split
  , subBezier
  , tangent
  , approximate
  , parameterOf
  , snap

  , pattern Bezier2, pattern Bezier3
  ) where

import           Control.Lens hiding (Empty)
import qualified Data.Foldable as F
import           Data.Geometry.Point
import           Data.Geometry.Properties
import           Data.Geometry.Transformation
import           Data.Geometry.Vector
import           Data.LSeq (LSeq)
import qualified Data.LSeq as LSeq
import           Data.Sequence (Seq(..))
import qualified Data.Sequence as Seq
import           Data.Traversable (fmapDefault,foldMapDefault)
import           GHC.TypeNats
import qualified Test.QuickCheck as QC

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

-- | Datatype representing a Bezier curve of degree \(n\) in \(d\)-dimensional space.
newtype BezierSpline n d r = BezierSpline { BezierSpline n d r -> LSeq (1 + n) (Point d r)
_controlPoints :: LSeq (1+n) (Point d r) }
-- makeLenses ''BezierSpline

-- | Bezier control points. With n degrees, there are n+1 control points.
controlPoints :: Iso (BezierSpline n1 d1 r1) (BezierSpline n2 d2 r2) (LSeq (1+n1) (Point d1 r1)) (LSeq (1+n2) (Point d2 r2))
controlPoints :: p (LSeq (1 + n1) (Point d1 r1)) (f (LSeq (1 + n2) (Point d2 r2)))
-> p (BezierSpline n1 d1 r1) (f (BezierSpline n2 d2 r2))
controlPoints = (BezierSpline n1 d1 r1 -> LSeq (1 + n1) (Point d1 r1))
-> (LSeq (1 + n2) (Point d2 r2) -> BezierSpline n2 d2 r2)
-> Iso
     (BezierSpline n1 d1 r1)
     (BezierSpline n2 d2 r2)
     (LSeq (1 + n1) (Point d1 r1))
     (LSeq (1 + n2) (Point d2 r2))
forall s a b t. (s -> a) -> (b -> t) -> Iso s t a b
iso BezierSpline n1 d1 r1 -> LSeq (1 + n1) (Point d1 r1)
forall (n :: Nat) (d :: Nat) r.
BezierSpline n d r -> LSeq (1 + n) (Point d r)
_controlPoints LSeq (1 + n2) (Point d2 r2) -> BezierSpline n2 d2 r2
forall (n :: Nat) (d :: Nat) r.
LSeq (1 + n) (Point d r) -> BezierSpline n d r
BezierSpline

-- | Quadratic Bezier Spline
pattern Bezier2      :: Point d r -> Point d r -> Point d r -> BezierSpline 2 d r
pattern $bBezier2 :: Point d r -> Point d r -> Point d r -> BezierSpline 2 d r
$mBezier2 :: forall r (d :: Nat) r.
BezierSpline 2 d r
-> (Point d r -> Point d r -> Point d r -> r) -> (Void# -> r) -> r
Bezier2 p q r <- (F.toList . LSeq.take 3 . _controlPoints -> [p,q,r])
  where
    Bezier2 Point d r
p Point d r
q Point d r
r = Seq (Point d r) -> BezierSpline 2 d r
forall (d :: Nat) r (n :: Nat).
Seq (Point d r) -> BezierSpline n d r
fromPointSeq (Seq (Point d r) -> BezierSpline 2 d r)
-> ([Point d r] -> Seq (Point d r))
-> [Point d r]
-> BezierSpline 2 d r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Point d r] -> Seq (Point d r)
forall a. [a] -> Seq a
Seq.fromList ([Point d r] -> BezierSpline 2 d r)
-> [Point d r] -> BezierSpline 2 d r
forall a b. (a -> b) -> a -> b
$ [Point d r
p,Point d r
q,Point d r
r]
{-# COMPLETE Bezier2 #-}

-- | Cubic Bezier Spline
pattern Bezier3         :: Point d r -> Point d r -> Point d r -> Point d r -> BezierSpline 3 d r
pattern $bBezier3 :: Point d r
-> Point d r -> Point d r -> Point d r -> BezierSpline 3 d r
$mBezier3 :: forall r (d :: Nat) r.
BezierSpline 3 d r
-> (Point d r -> Point d r -> Point d r -> Point d r -> r)
-> (Void# -> r)
-> r
Bezier3 p q r s <- (F.toList . LSeq.take 4 . _controlPoints -> [p,q,r,s])
  where
    Bezier3 Point d r
p Point d r
q Point d r
r Point d r
s = Seq (Point d r) -> BezierSpline 3 d r
forall (d :: Nat) r (n :: Nat).
Seq (Point d r) -> BezierSpline n d r
fromPointSeq (Seq (Point d r) -> BezierSpline 3 d r)
-> ([Point d r] -> Seq (Point d r))
-> [Point d r]
-> BezierSpline 3 d r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Point d r] -> Seq (Point d r)
forall a. [a] -> Seq a
Seq.fromList ([Point d r] -> BezierSpline 3 d r)
-> [Point d r] -> BezierSpline 3 d r
forall a b. (a -> b) -> a -> b
$ [Point d r
p,Point d r
q,Point d r
r,Point d r
s]
{-# COMPLETE Bezier3 #-}

deriving instance (Arity d, Eq r) => Eq (BezierSpline n d r)

type instance Dimension (BezierSpline n d r) = d
type instance NumType   (BezierSpline n d r) = r


instance (Arity n, Arity d, QC.Arbitrary r) => QC.Arbitrary (BezierSpline n d r) where
  arbitrary :: Gen (BezierSpline n d r)
arbitrary = Seq (Point d r) -> BezierSpline n d r
forall (d :: Nat) r (n :: Nat).
Seq (Point d r) -> BezierSpline n d r
fromPointSeq (Seq (Point d r) -> BezierSpline n d r)
-> ([Point d r] -> Seq (Point d r))
-> [Point d r]
-> BezierSpline n d r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Point d r] -> Seq (Point d r)
forall a. [a] -> Seq a
Seq.fromList ([Point d r] -> BezierSpline n d r)
-> Gen [Point d r] -> Gen (BezierSpline n d r)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Gen [Point d r]
forall a. Arbitrary a => Int -> Gen [a]
QC.vector (Natural -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Natural -> Int) -> (C n -> Natural) -> C n -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Natural
1Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
+) (Natural -> Natural) -> (C n -> Natural) -> C n -> Natural
forall b c a. (b -> c) -> (a -> b) -> a -> c
. C n -> Natural
forall (n :: Nat) (proxy :: Nat -> *).
KnownNat n =>
proxy n -> Natural
natVal (C n -> Int) -> C n -> Int
forall a b. (a -> b) -> a -> b
$ C n
forall (n :: Nat). C n
C @n)

-- | Constructs the Bezier Spline from a given sequence of points.
fromPointSeq :: Seq (Point d r) -> BezierSpline n d r
fromPointSeq :: Seq (Point d r) -> BezierSpline n d r
fromPointSeq = LSeq (1 + n) (Point d r) -> BezierSpline n d r
forall (n :: Nat) (d :: Nat) r.
LSeq (1 + n) (Point d r) -> BezierSpline n d r
BezierSpline (LSeq (1 + n) (Point d r) -> BezierSpline n d r)
-> (Seq (Point d r) -> LSeq (1 + n) (Point d r))
-> Seq (Point d r)
-> BezierSpline n d r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LSeq 0 (Point d r) -> LSeq (1 + n) (Point d r)
forall (m :: Nat) (n :: Nat) a. LSeq m a -> LSeq n a
LSeq.promise (LSeq 0 (Point d r) -> LSeq (1 + n) (Point d r))
-> (Seq (Point d r) -> LSeq 0 (Point d r))
-> Seq (Point d r)
-> LSeq (1 + n) (Point d r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Seq (Point d r) -> LSeq 0 (Point d r)
forall a. Seq a -> LSeq 0 a
LSeq.fromSeq


instance (Arity d, Show r) => Show (BezierSpline n d r) where
  show :: BezierSpline n d r -> String
show (BezierSpline LSeq (1 + n) (Point d r)
ps) =
    [String] -> String
forall a. Monoid a => [a] -> a
mconcat [ String
"BezierSpline", Int -> String
forall a. Show a => a -> String
show (Int -> String) -> Int -> String
forall a b. (a -> b) -> a -> b
$ LSeq (1 + n) (Point d r) -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length LSeq (1 + n) (Point d r)
ps Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1, String
" ", [Point d r] -> String
forall a. Show a => a -> String
show (LSeq (1 + n) (Point d r) -> [Point d r]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList LSeq (1 + n) (Point d r)
ps) ]

instance Arity d => Functor (BezierSpline n d) where
  fmap :: (a -> b) -> BezierSpline n d a -> BezierSpline n d b
fmap = (a -> b) -> BezierSpline n d a -> BezierSpline n d b
forall (t :: * -> *) a b. Traversable t => (a -> b) -> t a -> t b
fmapDefault

instance Arity d => Foldable (BezierSpline n d) where
  foldMap :: (a -> m) -> BezierSpline n d a -> m
foldMap = (a -> m) -> BezierSpline n d a -> m
forall (t :: * -> *) m a.
(Traversable t, Monoid m) =>
(a -> m) -> t a -> m
foldMapDefault

instance Arity d => Traversable (BezierSpline n d) where
  traverse :: (a -> f b) -> BezierSpline n d a -> f (BezierSpline n d b)
traverse a -> f b
f (BezierSpline LSeq (1 + n) (Point d a)
ps) = LSeq (1 + n) (Point d b) -> BezierSpline n d b
forall (n :: Nat) (d :: Nat) r.
LSeq (1 + n) (Point d r) -> BezierSpline n d r
BezierSpline (LSeq (1 + n) (Point d b) -> BezierSpline n d b)
-> f (LSeq (1 + n) (Point d b)) -> f (BezierSpline n d b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Point d a -> f (Point d b))
-> LSeq (1 + n) (Point d a) -> f (LSeq (1 + n) (Point d b))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((a -> f b) -> Point d a -> f (Point d b)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse a -> f b
f) LSeq (1 + n) (Point d a)
ps

instance (Fractional r, Arity d, Arity (d + 1), Arity n)
          => IsTransformable (BezierSpline n d r) where
  transformBy :: Transformation
  (Dimension (BezierSpline n d r)) (NumType (BezierSpline n d r))
-> BezierSpline n d r -> BezierSpline n d r
transformBy = Transformation
  (Dimension (BezierSpline n d r)) (NumType (BezierSpline n d r))
-> BezierSpline n d r -> BezierSpline n d r
forall (g :: * -> *) r (d :: Nat).
(PointFunctor g, Fractional r, d ~ Dimension (g r), Arity d,
 Arity (d + 1)) =>
Transformation d r -> g r -> g r
transformPointFunctor

instance PointFunctor (BezierSpline n d) where
  pmap :: (Point (Dimension (BezierSpline n d r)) r
 -> Point (Dimension (BezierSpline n d s)) s)
-> BezierSpline n d r -> BezierSpline n d s
pmap Point (Dimension (BezierSpline n d r)) r
-> Point (Dimension (BezierSpline n d s)) s
f = ASetter
  (BezierSpline n d r)
  (BezierSpline n d s)
  (LSeq (1 + n) (Point d r))
  (LSeq (1 + n) (Point d s))
-> (LSeq (1 + n) (Point d r) -> LSeq (1 + n) (Point d s))
-> BezierSpline n d r
-> BezierSpline n d s
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter
  (BezierSpline n d r)
  (BezierSpline n d s)
  (LSeq (1 + n) (Point d r))
  (LSeq (1 + n) (Point d s))
forall (n1 :: Nat) (d1 :: Nat) r1 (n2 :: Nat) (d2 :: Nat) r2.
Iso
  (BezierSpline n1 d1 r1)
  (BezierSpline n2 d2 r2)
  (LSeq (1 + n1) (Point d1 r1))
  (LSeq (1 + n2) (Point d2 r2))
controlPoints ((Point d r -> Point d s)
-> LSeq (1 + n) (Point d r) -> LSeq (1 + n) (Point d s)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Point d r -> Point d s
Point (Dimension (BezierSpline n d r)) r
-> Point (Dimension (BezierSpline n d s)) s
f)

-- | Evaluate a BezierSpline curve at time t in [0, 1]
--
-- pre: \(t \in [0,1]\)
evaluate    :: (Arity d, Ord r, Num r) => BezierSpline n d r -> r -> Point d r
evaluate :: BezierSpline n d r -> r -> Point d r
evaluate BezierSpline n d r
b r
t = Seq (Point d r) -> Point d r
evaluate' (BezierSpline n d r
bBezierSpline n d r
-> Getting (Seq (Point d r)) (BezierSpline n d r) (Seq (Point d r))
-> Seq (Point d r)
forall s a. s -> Getting a s a -> a
^.(LSeq (1 + n) (Point d r)
 -> Const (Seq (Point d r)) (LSeq (1 + n) (Point d r)))
-> BezierSpline n d r
-> Const (Seq (Point d r)) (BezierSpline n d r)
forall (n1 :: Nat) (d1 :: Nat) r1 (n2 :: Nat) (d2 :: Nat) r2.
Iso
  (BezierSpline n1 d1 r1)
  (BezierSpline n2 d2 r2)
  (LSeq (1 + n1) (Point d1 r1))
  (LSeq (1 + n2) (Point d2 r2))
controlPoints((LSeq (1 + n) (Point d r)
  -> Const (Seq (Point d r)) (LSeq (1 + n) (Point d r)))
 -> BezierSpline n d r
 -> Const (Seq (Point d r)) (BezierSpline n d r))
-> ((Seq (Point d r) -> Const (Seq (Point d r)) (Seq (Point d r)))
    -> LSeq (1 + n) (Point d r)
    -> Const (Seq (Point d r)) (LSeq (1 + n) (Point d r)))
-> Getting (Seq (Point d r)) (BezierSpline n d r) (Seq (Point d r))
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(LSeq (1 + n) (Point d r) -> Seq (Point d r))
-> (Seq (Point d r) -> Const (Seq (Point d r)) (Seq (Point d r)))
-> LSeq (1 + n) (Point d r)
-> Const (Seq (Point d r)) (LSeq (1 + n) (Point d r))
forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to LSeq (1 + n) (Point d r) -> Seq (Point d r)
forall (n :: Nat) a. LSeq n a -> Seq a
LSeq.toSeq)
  where
    evaluate' :: Seq (Point d r) -> Point d r
evaluate' = \case
      (Point d r
p :<| Seq (Point d r)
Empty)  -> Point d r
p
      pts :: Seq (Point d r)
pts@(Point d r
_ :<| Seq (Point d r)
tl) -> let (Seq (Point d r)
ini :|> Point d r
_) = Seq (Point d r)
pts in Seq (Point d r) -> Point d r
evaluate' (Seq (Point d r) -> Point d r) -> Seq (Point d r) -> Point d r
forall a b. (a -> b) -> a -> b
$ (Point d r -> Point d r -> Point d r)
-> Seq (Point d r) -> Seq (Point d r) -> Seq (Point d r)
forall a b c. (a -> b -> c) -> Seq a -> Seq b -> Seq c
Seq.zipWith Point d r -> Point d r -> Point d r
blend Seq (Point d r)
ini Seq (Point d r)
tl
      Seq (Point d r)
_              -> String -> Point d r
forall a. HasCallStack => String -> a
error String
"evaluate: absurd"

    blend :: Point d r -> Point d r -> Point d r
blend Point d r
p Point d r
q = Point d r
p Point d r -> Diff (Point d) r -> Point d r
forall (p :: * -> *) a. (Affine p, Num a) => p a -> Diff p a -> p a
.+^ r
t r -> Vector d r -> Vector d r
forall (f :: * -> *) a. (Functor f, Num a) => a -> f a -> f a
*^ (Point d r
q Point d r -> Point d r -> Diff (Point d) r
forall (p :: * -> *) a. (Affine p, Num a) => p a -> p a -> Diff p a
.-. Point d r
p)

-- | Tangent to the bezier spline at the starting point.
tangent   :: (Arity d, Num r, 1 <= n) => BezierSpline n d r -> Vector d r
tangent :: BezierSpline n d r -> Vector d r
tangent BezierSpline n d r
b = BezierSpline n d r
bBezierSpline n d r
-> Getting (Endo (Point d r)) (BezierSpline n d r) (Point d r)
-> Point d r
forall s a. HasCallStack => s -> Getting (Endo a) s a -> a
^?!(LSeq (1 + n) (Point d r)
 -> Const (Endo (Point d r)) (LSeq (1 + n) (Point d r)))
-> BezierSpline n d r
-> Const (Endo (Point d r)) (BezierSpline n d r)
forall (n1 :: Nat) (d1 :: Nat) r1 (n2 :: Nat) (d2 :: Nat) r2.
Iso
  (BezierSpline n1 d1 r1)
  (BezierSpline n2 d2 r2)
  (LSeq (1 + n1) (Point d1 r1))
  (LSeq (1 + n2) (Point d2 r2))
controlPoints((LSeq (1 + n) (Point d r)
  -> Const (Endo (Point d r)) (LSeq (1 + n) (Point d r)))
 -> BezierSpline n d r
 -> Const (Endo (Point d r)) (BezierSpline n d r))
-> ((Point d r -> Const (Endo (Point d r)) (Point d r))
    -> LSeq (1 + n) (Point d r)
    -> Const (Endo (Point d r)) (LSeq (1 + n) (Point d r)))
-> Getting (Endo (Point d r)) (BezierSpline n d r) (Point d r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Index (LSeq (1 + n) (Point d r))
-> Traversal'
     (LSeq (1 + n) (Point d r)) (IxValue (LSeq (1 + n) (Point d r)))
forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix Index (LSeq (1 + n) (Point d r))
1  Point d r -> Point d r -> Diff (Point d) r
forall (p :: * -> *) a. (Affine p, Num a) => p a -> p a -> Diff p a
.-. BezierSpline n d r
bBezierSpline n d r
-> Getting (Endo (Point d r)) (BezierSpline n d r) (Point d r)
-> Point d r
forall s a. HasCallStack => s -> Getting (Endo a) s a -> a
^?!(LSeq (1 + n) (Point d r)
 -> Const (Endo (Point d r)) (LSeq (1 + n) (Point d r)))
-> BezierSpline n d r
-> Const (Endo (Point d r)) (BezierSpline n d r)
forall (n1 :: Nat) (d1 :: Nat) r1 (n2 :: Nat) (d2 :: Nat) r2.
Iso
  (BezierSpline n1 d1 r1)
  (BezierSpline n2 d2 r2)
  (LSeq (1 + n1) (Point d1 r1))
  (LSeq (1 + n2) (Point d2 r2))
controlPoints((LSeq (1 + n) (Point d r)
  -> Const (Endo (Point d r)) (LSeq (1 + n) (Point d r)))
 -> BezierSpline n d r
 -> Const (Endo (Point d r)) (BezierSpline n d r))
-> ((Point d r -> Const (Endo (Point d r)) (Point d r))
    -> LSeq (1 + n) (Point d r)
    -> Const (Endo (Point d r)) (LSeq (1 + n) (Point d r)))
-> Getting (Endo (Point d r)) (BezierSpline n d r) (Point d r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Index (LSeq (1 + n) (Point d r))
-> Traversal'
     (LSeq (1 + n) (Point d r)) (IxValue (LSeq (1 + n) (Point d r)))
forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix Index (LSeq (1 + n) (Point d r))
0

-- | Restrict a Bezier curve to th,e piece between parameters t < u in [0, 1].
subBezier     :: (KnownNat n, Arity d, Ord r, Num r)
              => r -> r -> BezierSpline n d r -> BezierSpline n d r
subBezier :: r -> r -> BezierSpline n d r -> BezierSpline n d r
subBezier r
t r
u = (BezierSpline n d r, BezierSpline n d r) -> BezierSpline n d r
forall a b. (a, b) -> a
fst ((BezierSpline n d r, BezierSpline n d r) -> BezierSpline n d r)
-> (BezierSpline n d r -> (BezierSpline n d r, BezierSpline n d r))
-> BezierSpline n d r
-> BezierSpline n d r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. r -> BezierSpline n d r -> (BezierSpline n d r, BezierSpline n d r)
forall (n :: Nat) (d :: Nat) r.
(KnownNat n, Arity d, Ord r, Num r) =>
r -> BezierSpline n d r -> (BezierSpline n d r, BezierSpline n d r)
split r
u (BezierSpline n d r -> (BezierSpline n d r, BezierSpline n d r))
-> (BezierSpline n d r -> BezierSpline n d r)
-> BezierSpline n d r
-> (BezierSpline n d r, BezierSpline n d r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (BezierSpline n d r, BezierSpline n d r) -> BezierSpline n d r
forall a b. (a, b) -> b
snd ((BezierSpline n d r, BezierSpline n d r) -> BezierSpline n d r)
-> (BezierSpline n d r -> (BezierSpline n d r, BezierSpline n d r))
-> BezierSpline n d r
-> BezierSpline n d r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. r -> BezierSpline n d r -> (BezierSpline n d r, BezierSpline n d r)
forall (n :: Nat) (d :: Nat) r.
(KnownNat n, Arity d, Ord r, Num r) =>
r -> BezierSpline n d r -> (BezierSpline n d r, BezierSpline n d r)
split r
t

-- | Split a Bezier curve at time t in [0, 1] into two pieces.
split :: forall n d r. (KnownNat n, Arity d, Ord r, Num r)
      => r -> BezierSpline n d r -> (BezierSpline n d r, BezierSpline n d r)
split :: r -> BezierSpline n d r -> (BezierSpline n d r, BezierSpline n d r)
split r
t BezierSpline n d r
b | r
t r -> r -> Bool
forall a. Ord a => a -> a -> Bool
< r
0 Bool -> Bool -> Bool
|| r
t r -> r -> Bool
forall a. Ord a => a -> a -> Bool
> r
1 = String -> (BezierSpline n d r, BezierSpline n d r)
forall a. HasCallStack => String -> a
error String
"Split parameter out of bounds."
          | Bool
otherwise      = let n :: Int
n  = Natural -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Natural -> Int) -> Natural -> Int
forall a b. (a -> b) -> a -> b
$ C n -> Natural
forall (n :: Nat) (proxy :: Nat -> *).
KnownNat n =>
proxy n -> Natural
natVal (C n
forall (n :: Nat). C n
C @n)
                                 ps :: Seq (Point d r)
ps = r -> LSeq (1 + n) (Point d r) -> Seq (Point d r)
forall (d :: Nat) r (n :: Nat).
(Arity d, Ord r, Num r) =>
r -> LSeq n (Point d r) -> Seq (Point d r)
collect r
t (LSeq (1 + n) (Point d r) -> Seq (Point d r))
-> LSeq (1 + n) (Point d r) -> Seq (Point d r)
forall a b. (a -> b) -> a -> b
$ BezierSpline n d r
bBezierSpline n d r
-> Getting
     (LSeq (1 + n) (Point d r))
     (BezierSpline n d r)
     (LSeq (1 + n) (Point d r))
-> LSeq (1 + n) (Point d r)
forall s a. s -> Getting a s a -> a
^.Getting
  (LSeq (1 + n) (Point d r))
  (BezierSpline n d r)
  (LSeq (1 + n) (Point d r))
forall (n1 :: Nat) (d1 :: Nat) r1 (n2 :: Nat) (d2 :: Nat) r2.
Iso
  (BezierSpline n1 d1 r1)
  (BezierSpline n2 d2 r2)
  (LSeq (1 + n1) (Point d1 r1))
  (LSeq (1 + n2) (Point d2 r2))
controlPoints
                             in ( Seq (Point d r) -> BezierSpline n d r
forall (d :: Nat) r (n :: Nat).
Seq (Point d r) -> BezierSpline n d r
fromPointSeq (Seq (Point d r) -> BezierSpline n d r)
-> (Seq (Point d r) -> Seq (Point d r))
-> Seq (Point d r)
-> BezierSpline n d r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Seq (Point d r) -> Seq (Point d r)
forall a. Int -> Seq a -> Seq a
Seq.take (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (Seq (Point d r) -> BezierSpline n d r)
-> Seq (Point d r) -> BezierSpline n d r
forall a b. (a -> b) -> a -> b
$ Seq (Point d r)
ps
                                , Seq (Point d r) -> BezierSpline n d r
forall (d :: Nat) r (n :: Nat).
Seq (Point d r) -> BezierSpline n d r
fromPointSeq (Seq (Point d r) -> BezierSpline n d r)
-> (Seq (Point d r) -> Seq (Point d r))
-> Seq (Point d r)
-> BezierSpline n d r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Seq (Point d r) -> Seq (Point d r)
forall a. Int -> Seq a -> Seq a
Seq.drop Int
n       (Seq (Point d r) -> BezierSpline n d r)
-> Seq (Point d r) -> BezierSpline n d r
forall a b. (a -> b) -> a -> b
$ Seq (Point d r)
ps
                                )

collect   :: (Arity d, Ord r, Num r) => r -> LSeq n (Point d r) -> Seq (Point d r)
collect :: r -> LSeq n (Point d r) -> Seq (Point d r)
collect r
t = Seq (Point d r) -> Seq (Point d r)
go (Seq (Point d r) -> Seq (Point d r))
-> (LSeq n (Point d r) -> Seq (Point d r))
-> LSeq n (Point d r)
-> Seq (Point d r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LSeq n (Point d r) -> Seq (Point d r)
forall (n :: Nat) a. LSeq n a -> Seq a
LSeq.toSeq
  where
    go :: Seq (Point d r) -> Seq (Point d r)
go = \case
      ps :: Seq (Point d r)
ps@(Point d r
_ :<| Seq (Point d r)
Empty) -> Seq (Point d r)
ps
      ps :: Seq (Point d r)
ps@(Point d r
p :<| Seq (Point d r)
tl)    -> let (Seq (Point d r)
ini :|> Point d r
q) = Seq (Point d r)
ps in (Point d r
p Point d r -> Seq (Point d r) -> Seq (Point d r)
forall a. a -> Seq a -> Seq a
:<| Seq (Point d r) -> Seq (Point d r)
go ((Point d r -> Point d r -> Point d r)
-> Seq (Point d r) -> Seq (Point d r) -> Seq (Point d r)
forall a b c. (a -> b -> c) -> Seq a -> Seq b -> Seq c
Seq.zipWith Point d r -> Point d r -> Point d r
blend Seq (Point d r)
ini Seq (Point d r)
tl)) Seq (Point d r) -> Point d r -> Seq (Point d r)
forall a. Seq a -> a -> Seq a
:|> Point d r
q
      Seq (Point d r)
_                -> String -> Seq (Point d r)
forall a. HasCallStack => String -> a
error String
"collect: absurd"

    blend :: Point d r -> Point d r -> Point d r
blend Point d r
p Point d r
q = Point d r
p Point d r -> Diff (Point d) r -> Point d r
forall (p :: * -> *) a. (Affine p, Num a) => p a -> Diff p a -> p a
.+^ r
t r -> Vector d r -> Vector d r
forall (f :: * -> *) a. (Functor f, Num a) => a -> f a -> f a
*^ (Point d r
q Point d r -> Point d r -> Diff (Point d) r
forall (p :: * -> *) a. (Affine p, Num a) => p a -> p a -> Diff p a
.-. Point d r
p)

-- {-

-- -- | Merge to Bezier pieces. Assumes they can be merged into a single piece of the same degree
-- --   (as would e.g. be the case for the result of a 'split' operation).
-- --   Does not test whether this is the case!
-- merge :: (Arity d, Ord r, Num r) => (Bezier d r, Bezier d r) -> Bezier d r

-- -}

-- | Approximate Bezier curve by Polyline with given resolution.
approximate :: forall n d r. (KnownNat n, Arity d, Ord r, Fractional r)
            => r -> BezierSpline n d r -> [Point d r]
approximate :: r -> BezierSpline n d r -> [Point d r]
approximate r
eps BezierSpline n d r
b
    | Point d r -> Point d r -> r
forall r (d :: Nat).
(Num r, Arity d) =>
Point d r -> Point d r -> r
squaredEuclideanDist Point d r
p Point d r
q r -> r -> Bool
forall a. Ord a => a -> a -> Bool
< r
epsr -> Integer -> r
forall a b. (Num a, Integral b) => a -> b -> a
^Integer
2 = [Point d r
p,Point d r
q]
    | Bool
otherwise                        = let (BezierSpline n d r
b1, BezierSpline n d r
b2) = r -> BezierSpline n d r -> (BezierSpline n d r, BezierSpline n d r)
forall (n :: Nat) (d :: Nat) r.
(KnownNat n, Arity d, Ord r, Num r) =>
r -> BezierSpline n d r -> (BezierSpline n d r, BezierSpline n d r)
split r
0.5 BezierSpline n d r
b
                                         in r -> BezierSpline n d r -> [Point d r]
forall (n :: Nat) (d :: Nat) r.
(KnownNat n, Arity d, Ord r, Fractional r) =>
r -> BezierSpline n d r -> [Point d r]
approximate r
eps BezierSpline n d r
b1 [Point d r] -> [Point d r] -> [Point d r]
forall a. [a] -> [a] -> [a]
++ [Point d r] -> [Point d r]
forall a. [a] -> [a]
tail (r -> BezierSpline n d r -> [Point d r]
forall (n :: Nat) (d :: Nat) r.
(KnownNat n, Arity d, Ord r, Fractional r) =>
r -> BezierSpline n d r -> [Point d r]
approximate r
eps BezierSpline n d r
b2)
  where
    p :: Point d r
p = BezierSpline n d r
bBezierSpline n d r
-> Getting (Point d r) (BezierSpline n d r) (Point d r)
-> Point d r
forall s a. s -> Getting a s a -> a
^.(LSeq (1 + n) (Point d r)
 -> Const (Point d r) (LSeq (1 + n) (Point d r)))
-> BezierSpline n d r -> Const (Point d r) (BezierSpline n d r)
forall (n1 :: Nat) (d1 :: Nat) r1 (n2 :: Nat) (d2 :: Nat) r2.
Iso
  (BezierSpline n1 d1 r1)
  (BezierSpline n2 d2 r2)
  (LSeq (1 + n1) (Point d1 r1))
  (LSeq (1 + n2) (Point d2 r2))
controlPoints((LSeq (1 + n) (Point d r)
  -> Const (Point d r) (LSeq (1 + n) (Point d r)))
 -> BezierSpline n d r -> Const (Point d r) (BezierSpline n d r))
-> ((Point d r -> Const (Point d r) (Point d r))
    -> LSeq (1 + n) (Point d r)
    -> Const (Point d r) (LSeq (1 + n) (Point d r)))
-> Getting (Point d r) (BezierSpline n d r) (Point d r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(LSeq (1 + n) (Point d r) -> Point d r)
-> (Point d r -> Const (Point d r) (Point d r))
-> LSeq (1 + n) (Point d r)
-> Const (Point d r) (LSeq (1 + n) (Point d r))
forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to LSeq (1 + n) (Point d r) -> Point d r
forall (n :: Nat) a. LSeq (1 + n) a -> a
LSeq.head
    q :: Point d r
q = BezierSpline n d r
bBezierSpline n d r
-> Getting (Point d r) (BezierSpline n d r) (Point d r)
-> Point d r
forall s a. s -> Getting a s a -> a
^.(LSeq (1 + n) (Point d r)
 -> Const (Point d r) (LSeq (1 + n) (Point d r)))
-> BezierSpline n d r -> Const (Point d r) (BezierSpline n d r)
forall (n1 :: Nat) (d1 :: Nat) r1 (n2 :: Nat) (d2 :: Nat) r2.
Iso
  (BezierSpline n1 d1 r1)
  (BezierSpline n2 d2 r2)
  (LSeq (1 + n1) (Point d1 r1))
  (LSeq (1 + n2) (Point d2 r2))
controlPoints((LSeq (1 + n) (Point d r)
  -> Const (Point d r) (LSeq (1 + n) (Point d r)))
 -> BezierSpline n d r -> Const (Point d r) (BezierSpline n d r))
-> ((Point d r -> Const (Point d r) (Point d r))
    -> LSeq (1 + n) (Point d r)
    -> Const (Point d r) (LSeq (1 + n) (Point d r)))
-> Getting (Point d r) (BezierSpline n d r) (Point d r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(LSeq (1 + n) (Point d r) -> Point d r)
-> (Point d r -> Const (Point d r) (Point d r))
-> LSeq (1 + n) (Point d r)
-> Const (Point d r) (LSeq (1 + n) (Point d r))
forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to LSeq (1 + n) (Point d r) -> Point d r
forall (n :: Nat) a. LSeq (1 + n) a -> a
LSeq.last

-- | Given a point on (or close to) a Bezier curve, return the corresponding parameter value.
--   (For points far away from the curve, the function will return the parameter value of
--   an approximate locally closest point to the input point.)
parameterOf      :: (Arity d, Ord r, Fractional r) => BezierSpline n d r -> Point d r -> r
parameterOf :: BezierSpline n d r -> Point d r -> r
parameterOf BezierSpline n d r
b Point d r
p = (r -> r) -> r -> r -> r
forall r. (Ord r, Fractional r) => (r -> r) -> r -> r -> r
binarySearch (Point d r -> Point d r -> r
forall (p :: * -> *) a.
(Affine p, Foldable (Diff p), Num a) =>
p a -> p a -> a
qdA Point d r
p (Point d r -> r) -> (r -> Point d r) -> r -> r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BezierSpline n d r -> r -> Point d r
forall (d :: Nat) r (n :: Nat).
(Arity d, Ord r, Num r) =>
BezierSpline n d r -> r -> Point d r
evaluate BezierSpline n d r
b) r
treshold (r
1 r -> r -> r
forall a. Num a => a -> a -> a
- r
treshold)
  where treshold :: r
treshold = r
0.0001

binarySearch                                    :: (Ord r, Fractional r) => (r -> r) -> r -> r -> r
binarySearch :: (r -> r) -> r -> r -> r
binarySearch r -> r
f r
l r
r | r -> r
forall a. Num a => a -> a
abs (r -> r
f r
l r -> r -> r
forall a. Num a => a -> a -> a
- r -> r
f r
r) r -> r -> Bool
forall a. Ord a => a -> a -> Bool
< r
treshold = r
m
                   | (r -> r) -> r -> r
forall r. Fractional r => (r -> r) -> r -> r
derivative r -> r
f r
m  r -> r -> Bool
forall a. Ord a => a -> a -> Bool
> r
0        = (r -> r) -> r -> r -> r
forall r. (Ord r, Fractional r) => (r -> r) -> r -> r -> r
binarySearch r -> r
f r
l r
m
                   | Bool
otherwise                  = (r -> r) -> r -> r -> r
forall r. (Ord r, Fractional r) => (r -> r) -> r -> r -> r
binarySearch r -> r
f r
m r
r
  where m :: r
m = (r
l r -> r -> r
forall a. Num a => a -> a -> a
+ r
r) r -> r -> r
forall a. Fractional a => a -> a -> a
/ r
2
        treshold :: r
treshold = r
0.0001

derivative     :: Fractional r => (r -> r) -> r -> r
derivative :: (r -> r) -> r -> r
derivative r -> r
f r
x = (r -> r
f (r
x r -> r -> r
forall a. Num a => a -> a -> a
+ r
delta) r -> r -> r
forall a. Num a => a -> a -> a
- r -> r
f r
x) r -> r -> r
forall a. Fractional a => a -> a -> a
/ r
delta
  where delta :: r
delta = r
0.00001

-- | Snap a point close to a Bezier curve to the curve.
snap   :: (Arity d, Ord r, Fractional r) => BezierSpline n d r -> Point d r -> Point d r
snap :: BezierSpline n d r -> Point d r -> Point d r
snap BezierSpline n d r
b = BezierSpline n d r -> r -> Point d r
forall (d :: Nat) r (n :: Nat).
(Arity d, Ord r, Num r) =>
BezierSpline n d r -> r -> Point d r
evaluate BezierSpline n d r
b (r -> Point d r) -> (Point d r -> r) -> Point d r -> Point d r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BezierSpline n d r -> Point d r -> r
forall (d :: Nat) r (n :: Nat).
(Arity d, Ord r, Fractional r) =>
BezierSpline n d r -> Point d r -> r
parameterOf BezierSpline n d r
b