1 files changed, 71 insertions, 13 deletions

diff --git a/src/Wavefront.hs b/src/Wavefront.hs
index cae6508..3c4eff0 100644
--- a/src/Wavefront.hs
+++ b/src/Wavefront.hs
@@ -1,4 +1,5 @@
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE RankNTypes       #-}
 module Wavefront where
 
 import Wavefront.Types
@@ -60,7 +61,9 @@ objBookKeeping builder = (lift Rank2.<$> builder)
         incrementCount objFaces $ \x o -> o { objFaces = x }
     }
 
+-- TODO: meshlab vertex colors extension
 mkv :: [Double] -> Location
+mkv [x,y,z,r,g,b] = Location x' y' z' 1 where (x':y':z':_) = map realToFrac [x,y,z]
 mkv cs = Location x y z w where (x:y:z:w:_) = map realToFrac cs ++ repeat 1
 
 mkt :: [Double] -> TexCoord
@@ -79,45 +82,94 @@ mkF (RefTriple a at an) = FaceIndex a at an
 elemental :: Element () -> x -> Element x
 elemental element x = fmap (const x) element
 
-modifyFirst :: MonadState (c, d) m => (c -> c) -> m ()
-modifyFirst = modify' . first
+modifyFirst :: MonadState ParserState m => (OBJ DList -> OBJ DList) -> m ()
+modifyFirst = modify' . (\f s -> s { pstObj = f (pstObj s) })
 
-buildOBJ :: ObjBuilder (State (OBJ DList,Element ()))
+modifySecond :: MonadState ParserState m => (Element () -> Element ()) -> m ()
+modifySecond = modify' . (\f s -> s { pstElm = f (pstElm 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]
+
+data FreeForm = FreeForm
+    { ffRat :: Bool
+    , ffTyp :: CSType
+    , ffDeg :: (Int,Int)
+    , ffPts :: FFPts
+    }
+
+initFF :: FreeForm
+initFF = FreeForm
+    { ffRat = False
+    , ffTyp = Bspline
+    , ffDeg = (1,1)
+    , ffPts = Curv2 []
+    }
+
+mkcurv2 :: FreeForm -> EmbeddedCurve
+mkcurv2 ff = EmbeddedCurve
+
+mkcurv :: FreeForm -> Curve
+mkcurv ff = Curve
+
+mksurf :: FreeForm -> Surface
+mksurf ff = Surface
+
+addFreeForm :: (forall x. x -> Element x) -> FreeForm -> OBJ DList -> OBJ DList
+addFreeForm elm ff o = case ffPts ff of
+    Curv2 {} -> o { objEmbeddedCurves = objEmbeddedCurves o `DList.snoc` mkcurv2 ff }
+    Curv {}  -> o { objCurves = objCurves o `DList.snoc` elm (mkcurv ff) }
+    Surf {}  -> o { objSurfaces = objSurfaces o `DList.snoc` elm (mksurf ff) }
+
+data ParserState = ParserState
+    { pstObj :: OBJ DList
+    , pstElm :: Element ()
+    , pstFF  :: FreeForm
+    }
+
+buildOBJ :: ObjBuilder (State ParserState)
 buildOBJ = nullBuilder
     { vertex = \xs -> modifyFirst $ \o -> o { objLocations = objLocations o `DList.snoc` mkv xs }
     , vertexT = \xs -> modifyFirst $ \o -> o { objTexCoords = objTexCoords o `DList.snoc` mkt xs }
     , vertexN = \xs -> modifyFirst $ \o -> o { objNormals = objNormals o `DList.snoc` mkn xs }
     , points = \xs -> do
         let p = map Point xs :: [Point]
-        (pts,element) <- gets (objPoints *** elemental)
+        (pts,element) <- gets (objPoints *.* elemental)
         modifyFirst $ \o -> o { objPoints = pts `DList.append` fmap element (DList.fromList p) }
     , line = \xs -> do
-        (lns,element) <- gets (objLines *** elemental)
+        (lns,element) <- gets (objLines *.* elemental)
         let l = zipWith mkl xs (tail xs)
         -- Line requires at least two points.  We'll ignore it otherwise.
         when (not $ null l) $
             modifyFirst $ \o -> o { objLines = lns `DList.append` fmap element (DList.fromList l) }
     , face = \xs -> do
-        (fcs,element) <- gets (objFaces *** elemental)
+        (fcs,element) <- gets (objFaces *.* elemental)
         case map mkF xs of
           a:b:c:ds -> modifyFirst $ \o -> o { objFaces = fcs `DList.snoc` element (Face a b c ds) }
           _        -> return () -- Ignore faces with less than 3 indices.
     , mtllib = \xs -> do
         let l = map decodeUtf8 xs
-        libs <- gets (objMtlLibs . fst)
+        libs <- gets (objMtlLibs . pstObj)
         modifyFirst $ \o -> o { objMtlLibs = DList.fromList l `DList.append` libs }
     , groups = \xs -> do
         let g = map decodeUtf8 xs
-        modify' $ second $ \e -> e { elGroups = g }
+        modifySecond $ \e -> e { elGroups = g }
     , objectName = \x -> do
         let o = decodeUtf8 x
-        modify' $ second $ \e -> e { elObject = Just o }
+        modifySecond $ \e -> e { elObject = Just o }
     , usemtl = \x -> do
         let mtl = decodeUtf8 x
-        libs <- DList.toList <$> gets (objMtlLibs . fst)
-        modify' $ second $ \e -> e { elMtl = Just (length libs,mtl) }
+        libs <- DList.toList <$> gets (objMtlLibs . pstObj)
+        modifySecond $ \e -> e { elMtl = Just (length libs,mtl) }
     , smoothingGroup = \x -> when (x > 0) $ do
-        modify $ second $ \e -> e { elSmoothingGroup = fromIntegral x }
+        modifySecond $ \e -> e { elSmoothingGroup = fromIntegral x }
+    , endFreeForm =
+        modify' $ \s -> s { pstObj = addFreeForm (elemental $ pstElm s) (pstFF s) (pstObj s)
+                          , pstFF  = initFF }
     }
 
 blankElement :: Element ()
@@ -134,9 +186,12 @@ emptyCounts = OBJ
             { objLocations = Count 0
             , objTexCoords = Count 0
             , objNormals   = Count 0
+            , objEmbeddedCurves = Count 0
             , objPoints    = Count 0
             , objLines     = Count 0
             , objFaces     = Count 0
+            , objCurves    = Count 0
+            , objSurfaces  = Count 0
             , objMtlLibs   = Count 0
             }
 
@@ -145,9 +200,12 @@ mzeroOBJ = OBJ
             { objLocations = mzero
             , objTexCoords = mzero
             , objNormals   = mzero
+            , objEmbeddedCurves = mzero
             , objPoints    = mzero
             , objLines     = mzero
             , objFaces     = mzero
+            , objCurves    = mzero
+            , objSurfaces  = mzero
             , objMtlLibs   = mzero
             }
 
@@ -155,7 +213,7 @@ parse :: L.ByteString -> OBJ Vector
 parse bs = Rank2.fmap (Vector.fromList . DList.toList) obj
  where
     go = parseCustom buildOBJ (const $ return ()) bs
-    (obj,_) = execState go (mzeroOBJ,blankElement)
+    ParserState { pstObj = obj } = execState go (ParserState mzeroOBJ blankElement initFF)
 
 parseCustom :: Monad m => ObjBuilder m -> (OBJ Count -> m b) -> L.ByteString -> m b
 parseCustom builder finish bs = do