From e2a39102145e8cb145c690f9b56d4c63126fe106 Mon Sep 17 00:00:00 2001 From: Joe Crayne Date: Tue, 23 Jul 2019 20:07:17 -0400 Subject: WIP: Freeform surfaces. --- src/Wavefront.hs | 84 ++++++++++++++++++++++++++++++++++++++++++-------- src/Wavefront/Lex.hs | 20 ++++++------ src/Wavefront/Types.hs | 24 +++++++++++++++ 3 files changed, 106 insertions(+), 22 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 diff --git a/src/Wavefront/Lex.hs b/src/Wavefront/Lex.hs index f4cb54a..811553a 100644 --- a/src/Wavefront/Lex.hs +++ b/src/Wavefront/Lex.hs @@ -38,7 +38,7 @@ data ObjBuilder m = ObjBuilder , trim :: [CurveSpec] -> m () , hole :: [CurveSpec] -> m () , specialCurves :: [CurveSpec] -> m () - , equivalentCurves :: [EmbeddedCurve] -> m () + , equivalentCurves :: [EmbeddedCurveRef] -> m () , groups :: [S.ByteString] -> m () , smoothingGroup :: Int -> m () , mergingGroup :: Int -> Double -> m () @@ -188,7 +188,7 @@ echoBuilder = ObjBuilder , trim = \ss -> echo $ unwords ("trim":concatMap (\(CurveSpec s e r) -> [show s,show e,show r]) ss) , hole = \ss -> echo $ unwords ("hole":concatMap (\(CurveSpec s e r) -> [show s,show e,show r]) ss) , specialCurves = \ss -> echo $ unwords ("scrv":concatMap (\(CurveSpec s e r) -> [show s,show e,show r]) ss) - , equivalentCurves = \ccs -> echo $ unwords ("con":map showEmbeddedCurve ccs) + , equivalentCurves = \ccs -> echo $ unwords ("con":map showEmbeddedCurveRef ccs) , groups = \gs -> echo $ unwords $ "g":map unpackUtf8 gs , smoothingGroup = \sg -> echo ("s " ++ show sg) , mergingGroup = \mg δ -> echo $ unwords ["mg",show mg,show δ] @@ -264,6 +264,8 @@ newtype ObjConfig = ObjConfig { cfgSubst :: IntMap L.ByteString } +defaultConfig = ObjConfig IntMap.empty + -- consChunk :: S.ByteString -> L.ByteString -> L.ByteString -- consChunk c bs = L.fromChunks (c : L.toChunks bs) @@ -430,11 +432,11 @@ parseCurveSpecsN n tok bs cont = parseFloatsN 2 tok bs $ \fs bs' -> case fs of _ -> cont [] bs' -parseEmbeddedCurves :: (L.ByteString -> L.ByteString) -> L.ByteString -> ([EmbeddedCurve] -> L.ByteString -> b) -> b -parseEmbeddedCurves tok bs cont = parseIntsN 1 tok bs $ \is bs' -> case is of +parseEmbeddedCurveRefs :: (L.ByteString -> L.ByteString) -> L.ByteString -> ([EmbeddedCurveRef] -> L.ByteString -> b) -> b +parseEmbeddedCurveRefs tok bs cont = parseIntsN 1 tok bs $ \is bs' -> case is of (sref:_) -> do parseCurveSpecsN 1 tok bs' $ \cs bs'' -> case cs of - (c:_) -> parseEmbeddedCurves tok bs'' $ cont . (EmbeddedCurve sref c :) + (c:_) -> parseEmbeddedCurveRefs tok bs'' $ cont . (EmbeddedCurveRef sref c :) _ -> cont [] bs'' _ -> cont [] bs' @@ -472,14 +474,14 @@ data CurveSpec = CurveSpec } deriving (Eq,Ord,Show) -data EmbeddedCurve = EmbeddedCurve +data EmbeddedCurveRef = EmbeddedCurveRef { curveSurfaceRef :: Int , embeddedCurve :: CurveSpec } deriving (Eq,Ord,Show) -showEmbeddedCurve :: EmbeddedCurve -> String -showEmbeddedCurve (EmbeddedCurve s c) = unwords +showEmbeddedCurveRef :: EmbeddedCurveRef -> String +showEmbeddedCurveRef (EmbeddedCurveRef s c) = unwords [ show s , show (curveStart c) , show (curveEnd c) @@ -560,7 +562,7 @@ parseOBJ builder args bs0 then parseI deprecated_cdc 4 -- cdc else parseI deprecated_cdp 4 -- cdp "co" -> -- con - parseEmbeddedCurves (findToken args) (next 2 bs) $ \ss bs' -> do + parseEmbeddedCurveRefs (findToken args) (next 2 bs) $ \ss bs' -> do equivalentCurves builder ss parseOBJ builder args bs' "cs" -> if lengthLessThan 3 bs diff --git a/src/Wavefront/Types.hs b/src/Wavefront/Types.hs index 99bbb15..2ab48ba 100644 --- a/src/Wavefront/Types.hs +++ b/src/Wavefront/Types.hs @@ -18,9 +18,12 @@ data OBJ v = OBJ { objLocations :: v Location , objTexCoords :: v TexCoord , objNormals :: v Normal + , objEmbeddedCurves :: v EmbeddedCurve , objPoints :: v (Element Point) , objLines :: v (Element Line) , objFaces :: v (Element Face) + , objCurves :: v (Element Curve) + , objSurfaces :: v (Element Surface) , objMtlLibs :: v Text } @@ -28,18 +31,24 @@ type ForThisOBJ (c :: * -> Constraint) v = ( c (v Location) , c (v TexCoord) , c (v Normal) + , c (v EmbeddedCurve) , c (v (Element Point)) , c (v (Element Line)) , c (v (Element Face)) + , c (v (Element Curve)) + , c (v (Element Surface)) , c (v Text) ) type ForAllOBJ (c :: * -> Constraint) = ( c Location , c TexCoord , c Normal + , c EmbeddedCurve , c (Element Point) , c (Element Line) , c (Element Face) + , c (Element Curve) + , c (Element Surface) , c Text ) @@ -51,9 +60,12 @@ instance Rank2.Functor OBJ where { objLocations = f (objLocations obj) , objTexCoords = f (objTexCoords obj) , objNormals = f (objNormals obj) + , objEmbeddedCurves = f (objEmbeddedCurves obj) , objPoints = f (objPoints obj) , objLines = f (objLines obj) , objFaces = f (objFaces obj) + , objCurves = f (objCurves obj) + , objSurfaces = f (objSurfaces obj) , objMtlLibs = f (objMtlLibs obj) } @@ -65,9 +77,12 @@ instance ForAllOBJ c => Payload c OBJ where { objLocations = f (objLocations obj) , objTexCoords = f (objTexCoords obj) , objNormals = f (objNormals obj) + , objEmbeddedCurves = f (objEmbeddedCurves obj) , objPoints = f (objPoints obj) , objLines = f (objLines obj) , objFaces = f (objFaces obj) + , objCurves = f (objCurves obj) + , objSurfaces = f (objSurfaces obj) , objMtlLibs = f (objMtlLibs obj) } @@ -111,6 +126,15 @@ data Normal = Normal { , norZ :: {-# UNPACK #-} !Float } deriving (Eq,Ord,Show) +data EmbeddedCurve = EmbeddedCurve + deriving (Eq,Ord,Show) + +data Curve = Curve + deriving (Eq,Ord,Show) + +data Surface = Surface + deriving (Eq,Ord,Show) + -- | A point is a single index that references the locations. It’s a canonical -- type that truly represents a polygonal point. data Point = Point { -- cgit v1.2.3