Support NURBS surface.HEADmaster

2 files changed, 58 insertions, 6 deletions

diff --git a/src/Wavefront.hs b/src/Wavefront.hs
index 3c4eff0..e6b31ec 100644
--- a/src/Wavefront.hs
+++ b/src/Wavefront.hs
@@ -2,8 +2,8 @@
 {-# LANGUAGE RankNTypes       #-}
 module Wavefront where
 
-import Wavefront.Types
-import Wavefront.Lex
+import Wavefront.Types as Types
+import Wavefront.Lex   as Lex
 
 import Control.Arrow
 import Control.Monad.State
@@ -75,10 +75,17 @@ mkn cs = Normal x y z where (x:y:z:_) = map realToFrac cs ++ repeat 0
 mkl :: RefTriple -> RefTriple -> Line
 mkl (RefTriple a at _) (RefTriple b bt _) = Line (LineIndex a at) (LineIndex b bt)
 
--- I'd have thought these would be Coercible, but I guess not.
 mkF :: RefTriple -> FaceIndex
 mkF (RefTriple a at an) = FaceIndex a at an
 
+-- 'mkF' and 'mkTyp' are a little awkward, but it increases modularity.
+mkTyp :: Lex.CSType -> Types.CSType
+mkTyp Lex.Bmatrix  = Types.Bmatrix
+mkTyp Lex.Bezier   = Types.Bezier
+mkTyp Lex.Bspline  = Types.Bspline
+mkTyp Lex.Cardinal = Types.Cardinal
+mkTyp Lex.Taylor   = Types.Taylor
+
 elemental :: Element () -> x -> Element x
 elemental element x = fmap (const x) element
 
@@ -88,26 +95,33 @@ modifyFirst = modify' . (\f s -> s { pstObj = f (pstObj s) })
 modifySecond :: MonadState ParserState m => (Element () -> Element ()) -> m ()
 modifySecond = modify' . (\f s -> s { pstElm = f (pstElm s) })
 
+modifyFF :: MonadState ParserState m => (FreeForm -> FreeForm) -> m ()
+modifyFF = modify' . (\f s -> s { pstFF = f (pstFF s) })
+
 (*.*) :: (OBJ DList -> a) -> (Element () -> b) -> ParserState -> (a, b)
 fld *.* elm = \s -> (fld (pstObj s), elm (pstElm s))
 
 data FFPts = Curv Float Float [Int]
            | Curv2 [Int]
-           | Surf Float Float Float Float [RefTriple]
+           | Surf Float Float Float Float [FaceIndex]
 
 data FreeForm = FreeForm
     { ffRat :: Bool
-    , ffTyp :: CSType
+    , ffTyp :: Types.CSType
     , ffDeg :: (Int,Int)
     , ffPts :: FFPts
+    , ffParamU :: [Float]
+    , ffParamV :: [Float]
     }
 
 initFF :: FreeForm
 initFF = FreeForm
     { ffRat = False
-    , ffTyp = Bspline
+    , ffTyp = Types.Bspline
     , ffDeg = (1,1)
     , ffPts = Curv2 []
+    , ffParamU = []
+    , ffParamV = []
     }
 
 mkcurv2 :: FreeForm -> EmbeddedCurve
@@ -118,6 +132,21 @@ mkcurv ff = Curve
 
 mksurf :: FreeForm -> Surface
 mksurf ff = Surface
+    { surfIsRational = ffRat ff
+    , surfDegree     = ffDeg ff
+    , surfType       = ffTyp ff
+    , surfRangeU     = case ffPts ff of
+        Surf minu maxu _ _ _ -> (minu,maxu)
+        _                    -> (0,1)
+    , surfRangeV     = case ffPts ff of
+        Surf _ _ minv maxv _ -> (minv,maxv)
+        _                    -> (0,1)
+    , surfPoints = case ffPts ff of
+        Surf _ _ _ _ pts -> pts
+        _                -> []
+    , surfKnotsU = ffParamU ff
+    , surfKnotsV = ffParamV ff
+    }
 
 addFreeForm :: (forall x. x -> Element x) -> FreeForm -> OBJ DList -> OBJ DList
 addFreeForm elm ff o = case ffPts ff of
@@ -167,6 +196,16 @@ buildOBJ = nullBuilder
         modifySecond $ \e -> e { elMtl = Just (length libs,mtl) }
     , smoothingGroup = \x -> when (x > 0) $ do
         modifySecond $ \e -> e { elSmoothingGroup = fromIntegral x }
+
+    -- Free-form support
+    , cstype = \israt typ -> modifyFF $ \s -> s { ffRat = israt, ffTyp = mkTyp typ }
+    , deg = \ds -> modifyFF $ \s -> s { ffDeg = ((!! 0) &&& (!! 1)) (ds ++ [3,3]) }
+    , surf = \u0 u1 v0 v1 ts -> do
+        let [uA,uB,vA,vB] = map realToFrac [u0,u1,v0,v1]
+        modifyFF $ \s -> s { ffPts = Surf uA uB vA vB (map mkF ts) }
+    , parm = \uv ks -> case uv of
+        ParamU -> modifyFF $ \s -> s { ffParamU = map realToFrac ks }
+        ParamV -> modifyFF $ \s -> s { ffParamV = map realToFrac ks }
     , endFreeForm =
         modify' $ \s -> s { pstObj = addFreeForm (elemental $ pstElm s) (pstFF s) (pstObj s)
                           , pstFF  = initFF }
diff --git a/src/Wavefront/Types.hs b/src/Wavefront/Types.hs
index 2ab48ba..fe49a57 100644
--- a/src/Wavefront/Types.hs
+++ b/src/Wavefront/Types.hs
@@ -132,7 +132,20 @@ data EmbeddedCurve = EmbeddedCurve
 data Curve = Curve
   deriving (Eq,Ord,Show)
 
+data CSType = Bmatrix | Bezier | Bspline | Cardinal | Taylor
+ deriving (Eq,Ord,Show,Enum)
+
 data Surface = Surface
+  { surfIsRational :: !Bool
+  , surfDegree     :: !(Int,Int)
+  , surfType       :: !CSType
+  , surfPoints     :: [FaceIndex]
+  , surfRangeU     :: !(Float,Float)
+  , surfRangeV     :: !(Float,Float)
+  , surfKnotsU     :: ![Float]
+  , surfKnotsV     :: ![Float]
+  -- TODO: trim/hole/special
+  }
   deriving (Eq,Ord,Show)
 
 -- | A point is a single index that references the locations. It’s a canonical