{-# LANGUAGE StandaloneDeriving, FlexibleContexts, UndecidableInstances, TypeFamilies #-}
module Math.NURBS
    ( NURBS
    , nurbs, toNURBS
    , evalNURBS, nurbsDomain
    , nurbsDegree, nurbsKnotVector, nurbsControlPoints
    , splitNURBS
    ) where

import Data.VectorSpace
import Math.Spline.Class (Spline, toBSpline)
import Math.Spline.BSpline.Internal
import Math.Spline.BSpline
import Math.Spline.Knots

newtype NURBS v = NURBS (BSpline (Scalar v, v))

deriving instance (Eq   v, Eq   (Scalar v), Eq   (Scalar (Scalar v))) => Eq   (NURBS v)
deriving instance (Ord  v, Ord  (Scalar v), Ord  (Scalar (Scalar v))) => Ord  (NURBS v)
instance (Show v, Show (Scalar v), Show (Scalar (Scalar v))) => Show (NURBS v) where
    showsPrec p (NURBS spline) = showParen (p>11)
        ( showString "nurbs "
        . showsPrec 11 spline
        )

toNURBS :: (Spline s v, Scalar v ~ Scalar (Scalar v)) => s v -> NURBS v
toNURBS = NURBS . mapControlPoints (\p -> (1,p)) . toBSpline

nurbs :: (VectorSpace v, Scalar v ~ w,
          VectorSpace w, Scalar w ~ w)
       => Knots (Scalar v) -> [(w, v)] -> NURBS v
nurbs kts cps = NURBS (bSpline kts cps)

-- |Constructs the homogeneous-coordinates B-spline that corresponds to this
-- NURBS curve
nurbsAsSpline (NURBS spline) = spline 
    { controlPoints = map homogenize (controlPoints spline) }
    where
        homogenize (w,v) = (w, w *^ v)

-- |Constructs the NURBS curve corresponding to a homogeneous-coordinates B-spline
splineAsNURBS spline = NURBS spline 
    { controlPoints = map unHomogenize (controlPoints spline) }
    where
        unHomogenize (w,v) = (w, recip w *^ v)


evalNURBS
  :: (VectorSpace v, Scalar v ~ w,
      VectorSpace w, Scalar w ~ w,
      Fractional w, Ord w) =>
     NURBS v -> w -> v
evalNURBS nurbs = project . evalBSpline (nurbsAsSpline nurbs)
    where
        project (w,v) = recip w *^ v


-- |Returns the domain of a NURBS - that is, the range of parameter values
-- over which a spline with this degree and knot vector has a full basis set.
nurbsDomain :: Scalar v ~ Scalar (Scalar v) => 
    NURBS v -> Maybe (Scalar v, Scalar v)
nurbsDomain (NURBS spline) = knotDomain (knotVector spline) (degree spline)

nurbsDegree :: NURBS v -> Int
nurbsDegree (NURBS spline) = degree spline

nurbsKnotVector :: Scalar v ~ Scalar (Scalar v) => NURBS v -> Knots (Scalar v)
nurbsKnotVector (NURBS spline) = knotVector spline

nurbsControlPoints :: NURBS v -> [(Scalar v, v)]
nurbsControlPoints (NURBS spline) = controlPoints spline

splitNURBS :: (VectorSpace v, Scalar v ~ w,
               VectorSpace w, Scalar w ~ w,
               Ord w, Fractional w)
    => NURBS v -> Scalar v -> Maybe (NURBS v, NURBS v)
splitNURBS nurbs t = do
    (s0, s1) <- splitBSpline (nurbsAsSpline nurbs) t
    return (splineAsNURBS s0, splineAsNURBS s1)