From 8bd628fb6e07c26377f18547eeb7b10dfd2841da Mon Sep 17 00:00:00 2001 From: Joe Crayne Date: Thu, 13 Jun 2019 22:35:58 -0400 Subject: crayne parser: bsp,bevel,lod,res,cdp keywords. --- src/Wavefront.hs | 62 ++++++++++++++++++++++++++++++++++++-------------------- 1 file changed, 40 insertions(+), 22 deletions(-) diff --git a/src/Wavefront.hs b/src/Wavefront.hs index 6378d08..b97c304 100644 --- a/src/Wavefront.hs +++ b/src/Wavefront.hs @@ -36,7 +36,9 @@ data ObjBuilder m = ObjBuilder , mergingGroup :: Int -> Double -> m () , usemtl :: S.ByteString -> m () , deprecated_cdc :: [Int] -> m () + , deprecated_cdp :: [Int] -> m () , deprecated_bzp :: [Int] -> m () + , deprecated_bsp :: [Int] -> m () , mtllib :: [S.ByteString] -> m () , objectName :: S.ByteString -> m () , bmat :: ParamSpec -> [Double] -> m () @@ -48,6 +50,9 @@ data ObjBuilder m = ObjBuilder , d_interp :: Bool -> m () , trace_obj :: S.ByteString -> m () , shadow_obj :: S.ByteString -> m () + , deprecated_res :: [Int] -> m () + , bevel :: Bool -> m () + , lod :: Int -> m () , badToken :: L.ByteString -> m () } @@ -77,7 +82,9 @@ nullBuilder = ObjBuilder , mergingGroup = \mg δ -> pure () , usemtl = \mtl -> pure () , deprecated_cdc = \is -> pure () + , deprecated_cdp = \is -> pure () , deprecated_bzp = \is -> pure () + , deprecated_bsp = \is -> pure () , mtllib = \fns -> pure () , objectName = \obn -> pure () , bmat = \uv fs -> pure () @@ -89,6 +96,9 @@ nullBuilder = ObjBuilder , d_interp = \b -> pure () , trace_obj = \obj -> pure () , shadow_obj = \obj -> pure () + , deprecated_res = \is -> pure () + , bevel = \b -> pure () + , lod = \lvl -> pure () , badToken = \bs -> pure () } @@ -176,13 +186,13 @@ findNewLine ps o@(ObjConfig args) bs = case L.break (\c -> c=='\n' || c=='\\' || {- - 1 x bevel + 1 bevel 2 bmat - 3 x bsp + 3 bsp 4 bzp 5 x call 6 cdc - 7 x cdp + 7 cdp 8 c_interp 9 con 10 x csh -- for all except these, @@ -196,14 +206,14 @@ findNewLine ps o@(ObjConfig args) bs = case L.break (\c -> c=='\n' || c=='\\' || 18 f 19 g 20 hole - 21 x lod + 21 lod 22 maplib 23 mg 24 mtllib 25 o 26 p 27 parm - 28 x res + 28 res 29 s 30 scrv 31 shadow_obj @@ -372,13 +382,17 @@ parseOBJ builder args bs0 "vt" -> parseV vertexT 3 "vn" -> parseV vertexN 3 "vp" -> parseV vertexP 3 - "bz" -> parseI deprecated_bzp 4 -- bzp + "be" -> parseOF bevel 2 -- bevel "bm" -> parseUV (next 2 bs) $ \uv bs' -> do -- bmat parseFloats (findToken args) bs' $ \vs bs'' -> do bmat builder uv vs parseOBJ builder args bs'' - "cd" -> parseI deprecated_cdc 4 -- cdc + "bs" -> parseI deprecated_bsp 4 -- bsp + "bz" -> parseI deprecated_bzp 4 -- bzp + "cd" -> if lengthLessThan 3 bs || L.index bs 2 /= 'p' + then parseI deprecated_cdc 4 -- cdc + else parseI deprecated_cdp 4 -- cdp "co" -> -- con parseEmbeddedCurves (findToken args) (next 2 bs) $ \ss bs' -> do equivalentCurves builder ss @@ -429,24 +443,17 @@ parseOBJ builder args bs0 curv builder u0 v0 is parseOBJ builder args bs'' "c_" -> -- c_interp - let tok = findToken args (next 2 bs) - in if lengthLessThan 2 tok - then bad tok - else let flag = case L.index tok 1 of - 'f' -> c_interp builder False -- off - _ -> c_interp builder True -- on - in parseOBJ builder args (next 2 tok) + parseOF c_interp 2 "de" -> parseI deg 3 "d_" -> -- d_interp - let tok = findToken args (next 2 bs) - in if lengthLessThan 2 tok - then bad tok - else let flag = case L.index tok 1 of - 'f' -> d_interp builder False -- off - _ -> d_interp builder True -- on - in parseOBJ builder args (next 2 tok) + parseOF d_interp 2 "en" -> do endFreeForm builder parseOBJ builder args (next 2 bs) + "lo" -> -- lod + parseInts (findToken args) (next 2 bs) $ \is bs' -> do + let level:_ = is ++ [0] + lod builder level + parseOBJ builder args bs' "ho" -> -- hole parseCurveSpecs (findToken args) (next 2 bs) $ \ss bs' -> do hole builder ss @@ -460,6 +467,8 @@ parseOBJ builder args bs0 parseFloats (findToken args) bs' $ \vs bs'' -> do parm builder uv vs parseOBJ builder args bs'' + "re" -> -- res (deprecated) + parseI deprecated_res 3 "sc" -> -- scrv parseCurveSpecs (findToken args) (next 2 bs) $ \ss bs' -> do specialCurves builder ss @@ -562,7 +571,7 @@ parseOBJ builder args bs0 in (fn <> L.take 1 ext <> f) : fs mtllib builder (map L.toStrict $ slurp fnn) parseOBJ builder args bs' - -- TODO: call,csh,lod,shadow_obj,trace_obj,bevel + -- TODO: call,csh _ -> bad bs where bs = findToken args bs0 @@ -598,6 +607,15 @@ parseOBJ builder args bs0 _ | lengthLessThan 2 tok -> (0,tok) _ -> (if L.index tok 1 == 'f' then 0 else 1, next 1 tok) cont sg bs'' + parseOF build n = + let tok = findToken args (next n bs) + in if lengthLessThan 2 tok + then bad tok + else let flag = case L.index tok 1 of + 'f' -> build builder False -- off + _ -> build builder True -- on + in parseOBJ builder args (next 2 tok) + sanitizeOBJFilename :: L.ByteString -> S.ByteString sanitizeOBJFilename fn = case S.breakEnd isSpace $ L.toStrict $ L.dropWhile isSpace fn of -- cgit v1.2.3