brush-strokes-0.1.0.0: src/lib/Math/Bezier/Spline.hs

{-# LANGUAGE AllowAmbiguousTypes   #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE UndecidableInstances  #-}

module Math.Bezier.Spline where

-- base
import Control.Monad
  ( guard )
import Data.Bifoldable
  ( Bifoldable(..) )
import Data.Bifunctor
  ( Bifunctor(..) )
import Data.Bitraversable
  ( Bitraversable(..) )
import Data.Coerce
  ( coerce )
import Data.Functor.Const
  ( Const(..) )
import Data.Functor.Identity
  ( Identity(..) )
import Data.Kind
  ( Type, Constraint )
import Data.Monoid
  ( Ap(..) )
import Data.Semigroup
  ( First(..) )
import GHC.Generics
  ( Generic, Generic1, Generically1(..) )

-- bifunctors
import qualified Data.Bifunctor.Tannen as Biff
  ( Tannen(..) )

-- containers
import Data.Sequence
  ( Seq(..) )
import qualified Data.Sequence as Seq
  ( drop, length, singleton, splitAt )

-- deepseq
import Control.DeepSeq
  ( NFData(..), NFData1, deepseq )

-- generic-lens
import Data.Generics.Product.Fields
  ( field )
import Data.Generics.Internal.VL
  ( set )

-- transformers
import Control.Monad.Trans.Class
  ( lift )
import Control.Monad.Trans.State.Strict
  ( StateT(runStateT), modify' )

-- acts
import Data.Act
  ( Torsor (..) )

-- brush-strokes
import qualified Math.Bezier.Cubic as Cubic
  ( Bezier(..), subdivide )
import qualified Math.Bezier.Quadratic as Quadratic
  ( Bezier(..), subdivide )
import Math.Linear
  ( ℝ(..) )
import Math.Module
  ( Module, lerp )


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

data PointType
  = PathPoint
  | ControlPoint ControlPoint
  deriving stock ( Eq, Ord, Show, Generic )
  deriving anyclass NFData

data ControlPoint
  = Bez2Cp
  | Bez3Cp1
  | Bez3Cp2
  deriving stock ( Eq, Ord, Show, Generic )
  deriving anyclass NFData

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

data SplineType = Open | Closed

data SSplineType ( clo :: SplineType ) where
  SOpen   :: SSplineType Open
  SClosed :: SSplineType Closed

class ( Traversable ( NextPoint clo )
      , forall crvData. Traversable ( Curves clo crvData )
      , Bitraversable ( Curves clo )
      , forall ptData. Show ptData => Show ( NextPoint clo ptData )
      , forall ptData crvData. ( Show ptData, Show crvData ) => Show ( Curves clo crvData ptData )
      , forall ptData. NFData ptData => NFData ( NextPoint clo ptData )
      , forall ptData crvData. ( NFData ptData, NFData crvData ) => NFData ( Curves clo crvData ptData )
      )
    => SplineTypeI ( clo :: SplineType ) where
  -- | Singleton for the spline type
  ssplineType :: SSplineType clo
instance SplineTypeI Open where
  ssplineType = SOpen
instance SplineTypeI Closed where
  ssplineType = SClosed

type NextPoint :: SplineType -> Type -> Type
data    family   NextPoint clo
newtype instance NextPoint Open   ptData = NextPoint { nextPoint :: ptData }
  deriving stock    ( Show, Generic, Generic1, Functor, Foldable, Traversable )
  deriving anyclass ( NFData, NFData1 )
  deriving Applicative
    via ( Generically1 ( NextPoint Open ) )
data    instance NextPoint Closed ptData = BackToStart
  deriving stock ( Show, Generic, Generic1, Functor, Foldable, Traversable )
  deriving anyclass ( NFData, NFData1 )
  deriving Applicative
    via ( Generically1 ( NextPoint Closed ) )

fromNextPoint :: forall clo ptData. SplineTypeI clo => ptData -> NextPoint clo ptData -> ptData
fromNextPoint pt nxt
  | SOpen <- ssplineType @clo
  = case nxt of { NextPoint q -> q }
  | otherwise
  = pt

toNextPoint :: forall clo ptData. SplineTypeI clo => ptData -> NextPoint clo ptData
toNextPoint pt = case ssplineType @clo of
  SOpen   -> NextPoint pt
  SClosed -> BackToStart

type Curve :: SplineType -> Type -> Type -> Type
data Curve clo crvData ptData
  = LineTo
  { curveEnd  :: !( NextPoint clo ptData )
  , curveData :: !crvData
  }
  | Bezier2To
  { controlPoint :: !ptData
  , curveEnd     :: !( NextPoint clo ptData )
  , curveData    :: !crvData
  }
  | Bezier3To
  { controlPoint1 :: !ptData
  , controlPoint2 :: !ptData
  , curveEnd      :: !( NextPoint clo ptData )
  , curveData     :: !crvData
  }
  deriving stock ( Generic, Generic1 )

deriving stock    instance ( Show   ptData, Show   crvData, Show   ( NextPoint clo ptData ) ) => Show   ( Curve clo crvData ptData )
deriving anyclass instance ( NFData ptData, NFData crvData, NFData ( NextPoint clo ptData ) ) => NFData ( Curve clo crvData ptData )

deriving stock instance Functor     ( NextPoint clo ) => Functor     ( Curve clo crvData )
deriving stock instance Foldable    ( NextPoint clo ) => Foldable    ( Curve clo crvData )
deriving stock instance Traversable ( NextPoint clo ) => Traversable ( Curve clo crvData )

instance Functor ( NextPoint clo ) => Bifunctor ( Curve clo ) where
  bimap f g ( LineTo            np d ) = LineTo                        ( fmap g np ) ( f d )
  bimap f g ( Bezier2To     cp  np d ) = Bezier2To ( g  cp )           ( fmap g np ) ( f d )
  bimap f g ( Bezier3To cp1 cp2 np d ) = Bezier3To ( g cp1 ) ( g cp2 ) ( fmap g np ) ( f d )
instance Foldable ( NextPoint clo ) => Bifoldable ( Curve clo ) where
  bifoldMap f g ( LineTo            np d ) =                   foldMap g np <> f d
  bifoldMap f g ( Bezier2To     cp  np d ) = g cp           <> foldMap g np <> f d
  bifoldMap f g ( Bezier3To cp1 cp2 np d ) = g cp1 <> g cp2 <> foldMap g np <> f d
instance Traversable ( NextPoint clo ) => Bitraversable ( Curve clo ) where
  bitraverse f g ( LineTo            np d ) = LineTo    <$>                     traverse g np <*> f d
  bitraverse f g ( Bezier2To     cp  np d ) = Bezier2To <$> g cp            <*> traverse g np <*> f d
  bitraverse f g ( Bezier3To cp1 cp2 np d ) = Bezier3To <$> g cp1 <*> g cp2 <*> traverse g np <*> f d

openCurveEnd :: Curve Open crvData ptData -> ptData
openCurveEnd = nextPoint . curveEnd

openCurveStart :: Curve Open crvData ptData -> ptData
openCurveStart ( LineTo ( NextPoint p ) _ ) = p
openCurveStart ( Bezier2To p _ _   ) = p
openCurveStart ( Bezier3To p _ _ _ ) = p

type Curves :: SplineType -> Type -> Type -> Type
data family Curves clo

newtype instance Curves Open crvData ptData
  = OpenCurves { openCurves :: Seq ( Curve Open crvData ptData ) }
  deriving stock   ( Show, Generic, Generic1, Functor, Foldable, Traversable )
  deriving newtype ( Semigroup, Monoid, NFData )

deriving via Biff.Tannen Seq ( Curve Open )
  instance Bifunctor ( Curves Open )
deriving via Biff.Tannen Seq ( Curve Open )
  instance Bifoldable ( Curves Open )
instance Bitraversable ( Curves Open ) where
  bitraverse f g ( OpenCurves { openCurves = curves } )
    = OpenCurves <$> traverse ( bitraverse f g ) curves

data instance Curves Closed crvData ptData
  = NoCurves
  | ClosedCurves
    { prevOpenCurves  :: !( Seq ( Curve Open crvData ptData ) )
    , lastClosedCurve :: !( Curve Closed crvData ptData )
    }
  deriving stock    ( Show, Generic, Generic1, Functor, Foldable, Traversable )
  deriving anyclass NFData

nbCurves :: Curves Closed crvData ptData -> Int
nbCurves NoCurves = 0
nbCurves ( ClosedCurves { prevOpenCurves } ) = 1 + Seq.length prevOpenCurves

instance Bifunctor     ( Curves Closed ) where
  bimap _ _ NoCurves = NoCurves
  bimap f g ( ClosedCurves p l ) = ClosedCurves ( fmap ( bimap f g ) p ) ( bimap f g l )
instance Bifoldable    ( Curves Closed ) where
  bifoldMap _ _ NoCurves = mempty
  bifoldMap f g ( ClosedCurves p l ) = foldMap ( bifoldMap f g ) p <> bifoldMap f g l
instance Bitraversable ( Curves Closed ) where
  bitraverse _ _ NoCurves = pure NoCurves
  bitraverse f g ( ClosedCurves p l )
    = ClosedCurves <$> ( traverse ( bitraverse f g ) p ) <*> bitraverse f g l


data Spline ( clo :: SplineType ) crvData ptData
  = Spline
    { splineStart  :: !ptData
    , splineCurves :: !( Curves clo crvData ptData )
    }
  deriving stock ( Generic, Generic1 )

deriving stock    instance ( Show   ptData, Show   ( Curves clo crvData ptData ) )
                        => Show   ( Spline clo crvData ptData )
deriving anyclass instance ( NFData ptData, NFData ( Curves clo crvData ptData ) )
                        => NFData ( Spline clo crvData ptData )
deriving stock    instance Functor     ( Curves clo crvData ) => Functor     ( Spline clo crvData )
deriving stock    instance Foldable    ( Curves clo crvData ) => Foldable    ( Spline clo crvData )
deriving stock    instance Traversable ( Curves clo crvData ) => Traversable ( Spline clo crvData )

instance KnownSplineType clo => Bifunctor ( Spline clo ) where
  bimap fc fp = bimapSpline ( const $ bimap fc fp ) fp
instance KnownSplineType clo => Bifoldable ( Spline clo ) where
  bifoldMap fc fp = runIdentity . bifoldSpline @_ @Identity ( const $ bifoldMap ( coerce fc ) ( coerce fp ) ) ( coerce fp )
instance KnownSplineType clo => Bitraversable ( Spline clo ) where
  bitraverse fc fp = bitraverseSpline ( const $ bitraverse fc fp ) fp

type SplinePts clo = Spline clo () ( ℝ 2 )

bimapCurve
  :: Functor ( NextPoint clo )
  => ( crvData -> crvData' ) -> ( PointType -> ptData -> ptData' )
  -> Curve clo crvData ptData -> Curve clo crvData' ptData'
bimapCurve f g ( LineTo    p1       d ) = LineTo                                                                        ( g PathPoint <$> p1 ) ( f d )
bimapCurve f g ( Bezier2To p1 p2    d ) = Bezier2To ( g ( ControlPoint Bez2Cp  ) p1 )                                   ( g PathPoint <$> p2 ) ( f d )
bimapCurve f g ( Bezier3To p1 p2 p3 d ) = Bezier3To ( g ( ControlPoint Bez3Cp1 ) p1 ) ( g ( ControlPoint Bez3Cp2 ) p2 ) ( g PathPoint <$> p3 ) ( f d )

bifoldMapCurve
  :: forall m clo crvData ptData
  .  ( Monoid m, Foldable ( NextPoint clo ) )
  => ( crvData -> m ) -> ( PointType -> ptData -> m )
  -> Curve clo crvData ptData -> m
bifoldMapCurve f g ( LineTo    p1       d ) =                                                                   ( foldMap ( g PathPoint ) p1 ) <> f d
bifoldMapCurve f g ( Bezier2To p1 p2    d ) = g ( ControlPoint Bez2Cp  ) p1 <>                                  ( foldMap ( g PathPoint ) p2 ) <> f d
bifoldMapCurve f g ( Bezier3To p1 p2 p3 d ) = g ( ControlPoint Bez3Cp1 ) p1 <> g ( ControlPoint Bez3Cp2 ) p2 <> ( foldMap ( g PathPoint ) p3 ) <> f d

bitraverseCurve
  :: forall f clo crvData crvData' ptData ptData'
  .  ( Applicative f, Traversable ( NextPoint clo ) )
  => ( crvData -> f crvData' ) -> ( PointType -> ptData -> f ptData' )
  -> Curve clo crvData ptData -> f ( Curve clo crvData' ptData' )
bitraverseCurve f g ( LineTo    p1       d ) = LineTo    <$>                                                                     traverse ( g PathPoint ) p1 <*> f d
bitraverseCurve f g ( Bezier2To p1 p2    d ) = Bezier2To <$> g ( ControlPoint Bez2Cp  ) p1 <*>                                   traverse ( g PathPoint ) p2 <*> f d
bitraverseCurve f g ( Bezier3To p1 p2 p3 d ) = Bezier3To <$> g ( ControlPoint Bez3Cp1 ) p1 <*> g ( ControlPoint Bez3Cp2 ) p2 <*> traverse ( g PathPoint ) p3 <*> f d

dropCurves :: Int -> Spline Open crvData ptData -> Maybe ( Spline Open crvData ptData )
dropCurves i spline@( Spline { splineCurves = OpenCurves curves } )
  | i < 1
  = Just spline
  | otherwise
  = case Seq.drop ( i - 1 ) curves of
    prev :<| next -> Just $ Spline { splineStart = openCurveEnd prev, splineCurves = OpenCurves next }
    Empty         -> Nothing

splitSplineAt :: Int -> Spline Open crvData ptData -> ( Spline Open crvData ptData, Spline Open crvData ptData )
splitSplineAt i ( Spline { splineStart, splineCurves = OpenCurves curves } ) = case Seq.splitAt i curves of
  ( Empty, next ) ->
    ( Spline { splineStart, splineCurves = OpenCurves Empty }, Spline { splineStart, splineCurves = OpenCurves next } )
  ( prev@( _ :|> lastPrev ), next ) ->
    ( Spline { splineStart, splineCurves = OpenCurves prev  }, Spline { splineStart = openCurveEnd lastPrev, splineCurves = OpenCurves next } )

-- | Subdivide a single curve at the given Bézier parameter.
subdivideCurveAt
  :: forall diff ptData crvData
  .  ( Torsor diff ptData, Module Double diff )
  => ptData
  -> Curve Open crvData ptData
  -> Double -- ^ Bézier parameter of split
  -> ( Curve Open crvData ptData, ptData, Curve Open crvData ptData )
subdivideCurveAt p0 curve t = case curve of
  LineTo { curveEnd = NextPoint p1, curveData } ->
    let splitPt = lerp @diff t p0 p1
    in  ( LineTo { curveEnd = NextPoint splitPt, curveData }
        , splitPt
        , LineTo { curveEnd = NextPoint p1,      curveData }
        )
  Bezier2To { controlPoint = p1, curveEnd = NextPoint p2, curveData } ->
    let ( Quadratic.Bezier _ q1 splitPt, Quadratic.Bezier _ r1 _ ) =
          Quadratic.subdivide @diff ( Quadratic.Bezier { p0, p1, p2 } ) t
    in  ( Bezier2To { controlPoint = q1, curveEnd = NextPoint splitPt, curveData }
        , splitPt
        , Bezier2To { controlPoint = r1, curveEnd = NextPoint p2,      curveData }
        )
  Bezier3To { controlPoint1 = p1, controlPoint2 = p2, curveEnd = NextPoint p3, curveData } ->
    let ( Cubic.Bezier _ q1 q2 splitPt, Cubic.Bezier _ r1 r2 _ ) =
          Cubic.subdivide @diff ( Cubic.Bezier { p0, p1, p2, p3 } ) t
    in  ( Bezier3To { controlPoint1 = q1, controlPoint2 = q2, curveEnd = NextPoint splitPt, curveData }
        , splitPt
        , Bezier3To { controlPoint1 = r1, controlPoint2 = r2, curveEnd = NextPoint p3,      curveData }
        )

-- | Subdivide a spline at multiple positions, each given as a
-- @(curveIndex, t)@ pair (assumed sorted and without duplicates).
subdivideSplineAt
  :: forall diff ptData crvData
  .  ( Torsor diff ptData, Module Double diff )
  => Spline Open crvData ptData
  -> [ ( Int, Double ) ] -- ^ @(curveIndex, t)@, where @t@ is the Bézier parameter for that curve
  -> [ Spline Open crvData ptData ]
subdivideSplineAt ( Spline { splineStart, splineCurves = OpenCurves curves } ) splits =
  go splineStart splineStart Empty 0 0 curves splits
  where
    go :: ptData
       -> ptData
       -> Seq ( Curve Open crvData ptData )
       -> Int -> Double
       -> Seq ( Curve Open crvData ptData )
       -> [ ( Int, Double ) ]
       -> [ Spline Open crvData ptData ]
    go segStart _curPt acc _idx _tPrev cs [] =
      -- No more splits: absorb all remaining curves into the current segment.
      [ Spline { splineStart = segStart, splineCurves = OpenCurves ( acc <> cs ) } ]
    go segStart curPt acc idx tPrev cs ( ( i, t ) : rest_splits ) =
      case cs of
        Empty ->
          -- No more curves (shouldn't happen for valid split positions).
          [ Spline { splineStart = segStart, splineCurves = OpenCurves acc } ]
        c :<| rest
          | i > idx
          ->  -- No split in this curve; add it to the accumulator and
              -- go to the next curve, starting with Bézier parameter t=0.
              go segStart ( openCurveEnd c ) ( acc :|> c ) ( idx + 1 ) 0 rest
                ( ( i, t ) : rest_splits )
          | otherwise
          ->  -- Split falls in this curve: reparametrise the Bézier parameter
              -- for further splits.
              let t' = ( t - tPrev ) / ( 1 - tPrev )
                  ( leftC, splitPt, rightC ) = subdivideCurveAt @diff curPt c t'
              in  Spline { splineStart = segStart, splineCurves = OpenCurves ( acc :|> leftC ) }
                    : go splitPt splitPt Empty idx t ( rightC :<| rest ) rest_splits
                        -- NB: pass t, not t', here.

reverseSpline :: forall crvData ptData. Spline Open crvData ptData -> Spline Open crvData ptData
reverseSpline spline@( Spline { splineStart = p0, splineCurves = OpenCurves curves } ) = case curves of
  Empty        -> spline
  prev :|> lst -> Spline { splineStart = openCurveEnd lst, splineCurves = OpenCurves ( go prev lst ) }
    where
      go :: Seq ( Curve Open crvData ptData ) -> Curve Open crvData ptData -> Seq ( Curve Open crvData ptData )
      go Empty ( LineTo          _ dat ) = LineTo          ( NextPoint p0 ) dat :<| Empty
      go Empty ( Bezier2To p1    _ dat ) = Bezier2To    p1 ( NextPoint p0 ) dat :<| Empty
      go Empty ( Bezier3To p1 p2 _ dat ) = Bezier3To p2 p1 ( NextPoint p0 ) dat :<| Empty
      go ( crvs :|> crv ) ( LineTo          _ dat ) = LineTo                          ( curveEnd crv ) dat :<| go crvs crv
      go ( crvs :|> crv ) ( Bezier2To p1    _ dat ) = Bezier2To    p1 ( NextPoint $ openCurveEnd crv ) dat :<| go crvs crv
      go ( crvs :|> crv ) ( Bezier3To p1 p2 _ dat ) = Bezier3To p2 p1 ( NextPoint $ openCurveEnd crv ) dat :<| go crvs crv

splineEnd :: Spline Open crvData ptData -> ptData
splineEnd ( Spline { splineStart, splineCurves = OpenCurves curves } ) = case curves of
  Empty           -> splineStart
  _ :|> lastCurve -> openCurveEnd lastCurve

catMaybesSpline :: ( ptData -> ptData -> Bool ) -> crvData -> ptData -> Maybe ptData -> Maybe ptData -> ptData -> Spline Open crvData ptData
catMaybesSpline eq dat p0 mbCp1 mbCp2 p3 =
  let
    mbCp1'  = do { cp1 <- mbCp1; guard ( not $ eq cp1 p0 ); return cp1 }
    mbCp2'  = do { cp2 <- mbCp2; guard ( not $ eq cp2 p3 ); return cp2 }
    mbCp1'' = do { cp1 <- mbCp1'; guard ( case mbCp2' of { Just {} -> True ; Nothing -> not ( eq cp1 p3 ) } ); return cp1 }
    mbCp2'' = do { cp2 <- mbCp2'; guard ( case mbCp1' of { Just {} -> True ; Nothing -> not ( eq cp2 p0 ) } ); return cp2 }
  in go mbCp1'' mbCp2''
  where
   go Nothing     Nothing     = Spline { splineStart = p0, splineCurves = OpenCurves $ Seq.singleton ( LineTo          ( NextPoint p3 ) dat ) }
   go ( Just p1 ) Nothing     = Spline { splineStart = p0, splineCurves = OpenCurves $ Seq.singleton ( Bezier2To    p1 ( NextPoint p3 ) dat ) }
   go Nothing     ( Just p2 ) = Spline { splineStart = p0, splineCurves = OpenCurves $ Seq.singleton ( Bezier2To    p2 ( NextPoint p3 ) dat ) }
   go ( Just p1 ) ( Just p2 ) = Spline { splineStart = p0, splineCurves = OpenCurves $ Seq.singleton ( Bezier3To p1 p2 ( NextPoint p3 ) dat ) }

-- | Connect two open curves.
--
-- It is assumed (not checked) that the end of the first curve is the start of the second curve.
instance Semigroup ( Spline Open crvData ptData ) where
  spline1@( Spline { splineStart, splineCurves = segs1 } ) <> spline2@( Spline { splineCurves = segs2 } )
    | null segs1 = spline2
    | null segs2 = spline1
    | otherwise  = Spline { splineStart, splineCurves = segs1 <> segs2 }

-- | Create a curve containing a single (open) cubic Bézier segment.
openCubicBezierCurveSpline :: crvData -> Cubic.Bezier ptData -> Spline Open crvData ptData
openCubicBezierCurveSpline crvData ( Cubic.Bezier {..} )
  = Spline
  { splineStart  = p0
  , splineCurves = OpenCurves . Seq.singleton $
    Bezier3To
      { controlPoint1 = p1
      , controlPoint2 = p2
      , curveEnd      = NextPoint p3
      , curveData     = crvData
      }
  }

-- | Drop the end of an open curve segment to create a "closed" curve (i.e. one that returns to the start).
dropCurveEnd :: Curve Open crvData ptData -> Curve Closed crvData ptData
dropCurveEnd ( LineTo            _ dat ) = LineTo            BackToStart dat
dropCurveEnd ( Bezier2To cp      _ dat ) = Bezier2To cp      BackToStart dat
dropCurveEnd ( Bezier3To cp1 cp2 _ dat ) = Bezier3To cp1 cp2 BackToStart dat

-- | A 'Maybe' value which keeps track of whether it is 'Nothing' or 'Just' with a type-level boolean.
--
-- This is used to enable writing 'biwitherSpline' with a dependent type signature,
-- as the result type depends on whether a starting point has been found yet or not.
data CurrentStart ( hasStart :: Bool ) ptData where
  NoStartFound :: CurrentStart False ptData
  CurrentStart ::
    { wasOriginalStart :: Bool
    , startPoint :: !ptData
    } -> CurrentStart True ptData

deriving stock    instance Show ptData => Show ( CurrentStart hasStart ptData )
deriving stock    instance Functor     ( CurrentStart hasStart )
deriving stock    instance Foldable    ( CurrentStart hasStart )
deriving stock    instance Traversable ( CurrentStart hasStart )
instance NFData ptData => NFData ( CurrentStart hasStart ptData ) where
  rnf NoStartFound                 = ()
  rnf ( CurrentStart orig ptData ) = rnf orig `seq` rnf ptData

-- | The result of a wither operation on a spline.
--
--   - When a starting point has been found, we can choose whether to keep the current segment or not.
--   - When a starting point has not yet been found, we first need to determine a new start point,
--     before we can consider keeping or dismissing the curve.
data WitherResult ( hasStart :: Bool ) ( clo' :: SplineType ) crvData' ptData' where
  Dismiss       :: WitherResult hasStart clo' crvData' ptData'
  UseStartPoint :: ptData' -> Maybe ( Curve clo' crvData' ptData' ) -> WitherResult False clo' crvData' ptData'
  UseCurve      :: Curve clo' crvData' ptData' -> WitherResult True clo' crvData' ptData'

deriving stock instance ( Show ptData', Show crvData', SplineTypeI clo' ) => Show ( WitherResult hasStart clo' crvData' ptData' )
instance ( NFData ptData', NFData crvData', SplineTypeI clo' ) => NFData ( WitherResult hasStart clo' crvData' ptData' ) where
  rnf Dismiss = ()
  rnf ( UseStartPoint ptData mbCurve ) = ptData `deepseq` mbCurve `deepseq` ()
  rnf ( UseCurve curve ) = rnf curve

class SplineTypeI clo => KnownSplineType clo where

  type TraversalCt clo ( clo' :: SplineType ) :: Constraint

  -- | Last point of a spline.
  lastPoint :: Spline clo crvData ptData -> ptData

  -- | Close a spline if necessary.
  adjustSplineType :: forall clo' crvData ptData. SplineTypeI clo' => Spline clo' crvData ptData -> Spline clo crvData ptData

  -- | Indexed traversal of a spline.
  ibitraverseSpline
    :: forall f crvData ptData crvData' ptData'
    .  Applicative f
    => ( forall clo'. ( TraversalCt clo clo', SplineTypeI clo' )
       => Int -> ptData -> Curve clo' crvData ptData -> f ( Curve clo' crvData' ptData' )
       )
    -> ( ptData -> f ptData' )
    -> Spline clo crvData ptData
    -> f ( Spline clo crvData' ptData' )

  -- | Bi-witherable traversal of a spline.
  biwitherSpline
    :: forall f crvData ptData crvData' ptData'
    .  Monad f
    => ( forall clo' hasStart. ( TraversalCt clo clo', SplineTypeI clo' )
       => CurrentStart hasStart ptData' -> Curve clo' crvData ptData -> f ( WitherResult hasStart clo' crvData' ptData' )
       )
    -> ( ptData -> f ( Maybe ptData' ) )
    -> Spline clo crvData ptData
    -> f ( Maybe ( Spline clo crvData' ptData' ) )

  -- | Traversal of a spline.
  bitraverseSpline
    :: forall f crvData ptData crvData' ptData'
    .  Applicative f
    => ( forall clo'. ( TraversalCt clo clo', SplineTypeI clo' )
       => ptData -> Curve clo' crvData ptData -> f ( Curve clo' crvData' ptData' )
       )
    -> ( ptData -> f ptData' )
    -> Spline clo crvData ptData
    -> f ( Spline clo crvData' ptData' )

  bitraverseSpline fc fp = ibitraverseSpline ( const fc ) fp

  -- | Indexed fold of a spline.
  ibifoldSpline
    :: forall f m crvData ptData
    .  ( Applicative f, Monoid m )
    => ( forall clo'. ( TraversalCt clo clo', SplineTypeI clo' )
       => Int -> ptData -> Curve clo' crvData ptData -> f m
       )
    -> ( ptData -> f m )
    -> Spline clo crvData ptData
    -> f m

  ibifoldSpline fc fp
    = coerce
    . ibitraverseSpline @clo @( Const ( Ap f m ) ) ( coerce fc ) ( coerce fp )


  -- | Fold of a spline.
  bifoldSpline
    :: forall f m crvData ptData
    .  ( Applicative f, Monoid m )
    => ( forall clo'. ( TraversalCt clo clo', SplineTypeI clo' )
       => ptData -> Curve clo' crvData ptData -> f m )
    -> ( ptData -> f m )
    -> Spline clo crvData ptData
    -> f m

  bifoldSpline fc fp = ibifoldSpline ( const fc ) fp

  -- | Bifunctor fmap of a spline.
  bimapSpline
    :: forall crvData ptData crvData' ptData'
    .  ( forall clo'. ( TraversalCt clo clo', SplineTypeI clo' )
       => ptData -> Curve clo' crvData ptData -> Curve clo' crvData' ptData'
       )
    -> ( ptData -> ptData' )
    -> Spline clo crvData  ptData
    -> Spline clo crvData' ptData'
  bimapSpline fc fp
    = runIdentity
    . bitraverseSpline @clo @Identity ( coerce fc ) ( coerce fp )



instance KnownSplineType Open where

  type TraversalCt Open clo' = clo' ~ Open

  lastPoint ( Spline { splineStart, splineCurves = OpenCurves curves } ) =
    case curves of
      Empty           -> splineStart
      _ :|> lastCurve -> openCurveEnd lastCurve

  adjustSplineType :: forall clo' crvData ptData. SplineTypeI clo' => Spline clo' crvData ptData -> Spline Open crvData ptData
  adjustSplineType spline@( Spline { splineStart, splineCurves } ) = case ssplineType @clo' of
    SOpen   -> spline
    SClosed -> case splineCurves of
      NoCurves              -> Spline { splineStart, splineCurves = OpenCurves Empty }
      ClosedCurves prev lst -> Spline { splineStart, splineCurves = OpenCurves $ prev :|> set ( field @"curveEnd" ) ( NextPoint splineStart ) lst }

  ibitraverseSpline fc fp ( Spline { splineStart, splineCurves = OpenCurves curves } ) =
    ( \ p cs -> Spline p ( OpenCurves cs ) ) <$> fp splineStart <*> go 0 splineStart curves
    where
      go _ _  Empty           = pure Empty
      go i p ( seg :<| segs ) = (:<|) <$> fc i p seg <*> go ( i + 1 ) ( openCurveEnd seg ) segs

  biwitherSpline
    :: forall f crvData ptData crvData' ptData'
    .  Monad f
    => (  forall clo' hasStart. ( clo' ~ Open, SplineTypeI clo' )
       => CurrentStart hasStart ptData' -> Curve clo' crvData ptData -> f ( WitherResult hasStart clo' crvData' ptData' )
       )
    -> ( ptData -> f ( Maybe ptData' ) )
    -> Spline Open crvData ptData
    -> f ( Maybe ( Spline Open crvData' ptData' ) )
  biwitherSpline fc fp ( Spline { splineStart, splineCurves = OpenCurves curves } ) = do
    mbStart' <- fp splineStart
    ( curves', mbStart'' ) <- ( `runStateT` ( fmap First mbStart' ) ) $ go ( (, True ) <$> mbStart' ) curves
    case mbStart'' of
      Nothing -> pure Nothing
      Just ( First start' ) ->
        pure ( Just $ Spline { splineStart = start', splineCurves = OpenCurves curves' } )
      where
        go :: Maybe ( ptData', Bool ) -> Seq ( Curve Open crvData ptData ) -> StateT ( Maybe ( First ptData' ) ) f ( Seq ( Curve Open crvData' ptData' ) )
        go _       Empty            = pure Empty
        go Nothing ( crv :<| crvs ) = do
          mbCrv' <- lift $ fc NoStartFound crv
          case mbCrv' of
            Dismiss -> go Nothing crvs
            UseStartPoint ptData'' mbCrv'' -> do
              modify' ( <> Just ( First ptData'' ) )
              case mbCrv'' of
                Nothing    ->                   go ( Just ( ptData'', False ) ) crvs
                Just crv'' -> ( crv'' :<| ) <$> go ( Just ( ptData'', False ) ) crvs
        go ( Just ( ptData', orig ) ) ( crv :<| crvs ) = do
          mbCrv' <- lift $ fc ( CurrentStart orig ptData' ) crv
          case mbCrv' of
            Dismiss -> go ( Just ( ptData', False ) ) crvs
            UseCurve crv'' ->
              ( crv'' :<| ) <$> go ( Just ( openCurveEnd crv'', True ) ) crvs

instance KnownSplineType Closed where

  type TraversalCt Closed clo' = ()

  lastPoint ( Spline { splineStart } ) = splineStart

  adjustSplineType :: forall clo' crvData ptData. SplineTypeI clo' => Spline clo' crvData ptData -> Spline Closed crvData ptData
  adjustSplineType spline@( Spline { splineStart, splineCurves } ) = case ssplineType @clo' of
    SClosed -> spline
    SOpen   -> case splineCurves of
      OpenCurves ( Empty        ) -> Spline { splineStart, splineCurves = NoCurves }
      OpenCurves ( prev :|> lst ) -> Spline { splineStart, splineCurves = ClosedCurves prev ( set ( field @"curveEnd" ) BackToStart lst ) }

  ibitraverseSpline
    :: forall f crvData ptData crvData' ptData'
    .  Applicative f
    => (  forall clo'. ( (), SplineTypeI clo' )
       => Int -> ptData -> Curve clo' crvData ptData -> f ( Curve clo' crvData' ptData' )
       )
    -> ( ptData -> f ptData' )
    -> Spline Closed crvData ptData
    -> f ( Spline Closed crvData' ptData' )
  ibitraverseSpline _  fp ( Spline { splineStart = p0, splineCurves = NoCurves } ) = ( \ p -> Spline p NoCurves ) <$> fp p0
  ibitraverseSpline fc fp ( Spline { splineStart = p0, splineCurves = ClosedCurves prevCurves lastCurve } ) =
    ( \ p cs lst -> Spline p ( ClosedCurves cs lst ) ) <$> fp p0 <*> go 0 p0 prevCurves <*> fc n pn lastCurve
      where
        n :: Int
        n = length prevCurves
        pn :: ptData
        pn = case prevCurves of
          Empty          -> p0
          _ :|> lastPrev -> openCurveEnd lastPrev
        go _ _  Empty           = pure Empty
        go i p ( seg :<| segs ) = (:<|) <$> fc i p seg <*> go ( i + 1 ) ( openCurveEnd seg ) segs

  biwitherSpline fc fp closedSpline = do
    spline' <- biwitherSpline fc fp ( adjustSplineType @Open closedSpline )
    return $ adjustSplineType @Closed <$> spline'

showSplinePoints :: forall clo ptData crvData
                 .  (KnownSplineType clo, Show ptData)
                 => Spline clo crvData ptData -> String
showSplinePoints
  = runIdentity
  . bifoldSpline
      ( \ _pt crv -> Identity $ f crv )
      ( \ pt -> Identity $ "[ " <> show pt )
  where
    f :: SplineTypeI clo' => Curve clo' crvData ptData -> String
    f (LineTo end _) = " -> " ++ showEnd end
    f (Bezier2To cp end _) = " -- " ++ show cp ++ " -> " ++ showEnd end
    f (Bezier3To cp1 cp2 end _) = " -- " ++ show cp1 ++ " -- " ++ show cp2 ++ " -> " ++ showEnd end

    showEnd :: forall clo'. SplineTypeI clo' => NextPoint clo' ptData -> String
    showEnd = case ssplineType @clo' of
      SOpen   -> \ ( NextPoint pt ) -> show pt <> "\n,  "
      SClosed -> \ BackToStart      -> ". ]"