From 76e4b1bd5310f65608521967db653570bb73ecbe Mon Sep 17 00:00:00 2001 From: Joe Crayne Date: Thu, 13 Jun 2019 16:02:54 -0400 Subject: crayne parser: step and p --- src/Wavefront.hs | 181 ++++++++++++++++++++++++++++++------------------------- 1 file changed, 99 insertions(+), 82 deletions(-) diff --git a/src/Wavefront.hs b/src/Wavefront.hs index 5cef6dc..74d0b39 100644 --- a/src/Wavefront.hs +++ b/src/Wavefront.hs @@ -40,40 +40,44 @@ data ObjBuilder m = ObjBuilder , mtllib :: [S.ByteString] -> m () , objectName :: S.ByteString -> m () , bmat :: ParamSpec -> [Double] -> m () + , step :: [Int] -> m () + , points :: [Int] -> m () , badToken :: L.ByteString -> m () } nullBuilder :: Applicative m => ObjBuilder m nullBuilder = ObjBuilder - { vertex = \vs -> pure () - , vertexT = \vs -> pure () - , vertexN = \vs -> pure () - , vertexP = \vs -> pure () - , face = \is -> pure () - , cstype = \isRat typ -> pure () - , curv2 = \is -> pure () - , curv = \u0 v0 is -> pure () - , parm = \uv is -> pure () - , specialPoints = \is -> pure () - , endFreeForm = pure () - , ctech = \approx -> pure () - , stech = \approx -> pure () - , deg = \is -> pure () + { vertex = \vs -> pure () + , vertexT = \vs -> pure () + , vertexN = \vs -> pure () + , vertexP = \vs -> pure () + , face = \is -> pure () + , cstype = \isRat typ -> pure () + , curv2 = \is -> pure () + , curv = \u0 v0 is -> pure () + , parm = \uv is -> pure () + , specialPoints = \is -> pure () + , endFreeForm = pure () + , ctech = \approx -> pure () + , stech = \approx -> pure () + , deg = \is -> pure () , surf = \u0 u1 v0 v1 ts -> pure () - , trim = \ss -> pure () - , hole = \ss -> pure () - , specialCurves = \ss -> pure () - , equivalentCurves = \ccs -> pure () - , groups = \gs -> pure () - , smoothingGroup = \sg -> pure () - , mergingGroup = \mg δ -> pure () - , usemtl = \mtl -> pure () - , deprecated_cdc = \is -> pure () - , deprecated_bzp = \is -> pure () - , mtllib = \fns -> pure () - , objectName = \obn -> pure () - , bmat = \uv fs -> pure () - , badToken = \bs -> pure () + , trim = \ss -> pure () + , hole = \ss -> pure () + , specialCurves = \ss -> pure () + , equivalentCurves = \ccs -> pure () + , groups = \gs -> pure () + , smoothingGroup = \sg -> pure () + , mergingGroup = \mg δ -> pure () + , usemtl = \mtl -> pure () + , deprecated_cdc = \is -> pure () + , deprecated_bzp = \is -> pure () + , mtllib = \fns -> pure () + , objectName = \obn -> pure () + , bmat = \uv fs -> pure () + , step = \is -> pure () + , points = \is -> pure () + , badToken = \bs -> pure () } @@ -168,22 +172,23 @@ findToken (ObjConfig args) bs = case L.dropWhile (\c -> isSpace c || c=='\\') bs 21 mg 22 mtllib 23 o - 24 parm - 25 s - 26 scrv - 27 x shadow_obj - 28 sp - 29 stech -- for all except these, - 30 x step -- Two chars suffice to distinguish - 31 surf - 32 x trace_obj -- for all except these, - 33 trim -- Two chars suffice to distinguish - 34 x usemap -- for all except these, - 35 usemtl -- Two chars suffice to distinguish - 36 v - 37 vn - 38 vp - 39 vt + 24 p + 25 parm + 26 s + 27 scrv + 28 x shadow_obj + 29 sp + 30 stech -- for all except these, + 31 step -- Two chars suffice to distinguish + 32 surf + 33 x trace_obj -- for all except these, + 34 trim -- Two chars suffice to distinguish + 35 x usemap -- for all except these, + 36 usemtl -- Two chars suffice to distinguish + 37 v + 38 vn + 39 vp + 40 vt -} @@ -322,7 +327,8 @@ parseOBJ builder args bs0 (objn,bs') -> do objectName builder (L.toStrict objn) parseOBJ builder args bs' - _ -> badToken builder bs + 'p' -> parseI points 2 + _ -> bad bs | otherwise = case L.take 2 bs of "vt" -> parseV vertexT 3 "vn" -> parseV vertexN 3 @@ -340,14 +346,14 @@ parseOBJ builder args bs0 parseOBJ builder args bs' "cs" -> -- cstype let parseRat = parseChar 'r' - parseTyp tok cont | lengthLessThan 3 tok = badToken builder tok + parseTyp tok cont | lengthLessThan 3 tok = bad tok | otherwise = case L.index tok 2 of 'a' -> cont Bmatrix $ next 3 tok 'z' -> cont Bezier $ next 3 tok 'p' -> cont Bspline $ next 3 tok 'r' -> cont Cardinal $ next 3 tok 'y' -> cont Taylor $ next 3 tok - _ -> badToken builder tok + _ -> bad tok in parseRat (next 2 bs) $ \isRat bs' -> do parseTyp bs' $ \typ bs'' -> do cstype builder isRat typ @@ -355,7 +361,7 @@ parseOBJ builder args bs0 "ct" -> -- ctech let tok = next 2 bs in if lengthLessThan 2 tok - then badToken builder tok + then bad tok else case L.index tok 1 of 'p' -> -- cparm parseFloats (findToken args) (next 2 tok) $ \is bs' -> do @@ -372,9 +378,9 @@ parseOBJ builder args bs0 let δ:θ:_ = fs ++ repeat 1.0 ctech builder (CurvatureBasedPolygon δ θ) parseOBJ builder args bs' - _ -> badToken builder tok + _ -> bad tok "cu" -> if lengthLessThan 5 bs - then badToken builder bs + then bad bs else if L.index bs 4 == '2' then parseI curv2 5 -- curv2 else do -- curv @@ -404,36 +410,44 @@ parseOBJ builder args bs0 specialCurves builder ss parseOBJ builder args bs' "sp" -> parseI specialPoints 3 - "st" -> -- stech - let tok = next 2 bs - in if lengthLessThan 2 tok - then badToken builder tok - else case L.index tok 1 of - 'p' -> -- cparma/cparmb - if lengthLessThan 6 tok - then badToken builder tok - else if L.index tok 5 == 'b' - then -- cparmb - parseFloats (findToken args) (next 5 tok) $ \is bs' -> do - let x:_ = is ++ [0] - stech builder (UniformAfterTrimming x) - parseOBJ builder args bs' - else -- cparma - parseFloats (findToken args) (next 5 tok) $ \is bs' -> do - let x:y:_ = is ++ [0] - stech builder (UniformIsoparametric x y) - parseOBJ builder args bs' - 's' -> -- cspace - parseFloats (findToken args) (next 2 tok) $ \fs bs' -> do - let x:_ = fs ++ [1.0] - stech builder (MaxLengthPolytopal x) - parseOBJ builder args bs' - 'u' -> -- curv - parseFloats (findToken args) (next 2 tok) $ \fs bs' -> do - let δ:θ:_ = fs ++ repeat 1.0 - stech builder (CurvatureBasedPolytope δ θ) - parseOBJ builder args bs' - _ -> badToken builder tok + "st" -> -- stech or step + if lengthLessThan 4 bs then bad bs + else case L.index bs 3 of + 'c' -> + -- stech + let tok = next 2 bs + in if lengthLessThan 2 tok + then bad tok + else case L.index tok 1 of + 'p' -> -- cparma/cparmb + if lengthLessThan 6 tok + then bad tok + else if L.index tok 5 == 'b' + then -- cparmb + parseFloats (findToken args) (next 5 tok) $ \is bs' -> do + let x:_ = is ++ [0] + stech builder (UniformAfterTrimming x) + parseOBJ builder args bs' + else -- cparma + parseFloats (findToken args) (next 5 tok) $ \is bs' -> do + let x:y:_ = is ++ [0] + stech builder (UniformIsoparametric x y) + parseOBJ builder args bs' + 's' -> -- cspace + parseFloats (findToken args) (next 2 tok) $ \fs bs' -> do + let x:_ = fs ++ [1.0] + stech builder (MaxLengthPolytopal x) + parseOBJ builder args bs' + 'u' -> -- curv + parseFloats (findToken args) (next 2 tok) $ \fs bs' -> do + let δ:θ:_ = fs ++ repeat 1.0 + stech builder (CurvatureBasedPolytope δ θ) + parseOBJ builder args bs' + _ -> bad tok + + _ -> -- step + parseI step 4 + "su" -> -- surf parseFloatsN 4 (findToken args) (next 2 bs) $ \fs bs' -> do parseTriples (findToken args) bs' $ \ts bs'' -> do @@ -463,10 +477,13 @@ 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,step,c_interp,d_interp,lod,shadow_obj,trace_obj,bevel - _ -> badToken builder bs + -- TODO: call,csh,c_interp,d_interp,lod,shadow_obj,trace_obj,bevel + _ -> bad bs where bs = findToken args bs0 + bad bs = case L.break (=='\n') bs of + (x,bs') -> do badToken builder x + parseOBJ builder args bs' next n xs = nextToken (findToken args) $ L.drop n xs parseChar c tok cont = case L.uncons tok of Just (x,cs) | x==c -> cont True $ next 0 cs -- cgit v1.2.3