From f41806fb911f17e5102be3ef20a74d0b033fa2a9 Mon Sep 17 00:00:00 2001 From: Joe Crayne Date: Thu, 13 Jun 2019 20:18:15 -0400 Subject: crayne parser: maplib,c_interp,d_interp keywords --- src/Wavefront.hs | 47 ++++++++++++++++++++++++++++++++++++++++++----- 1 file changed, 42 insertions(+), 5 deletions(-) diff --git a/src/Wavefront.hs b/src/Wavefront.hs index 84edd6d..208e5bf 100644 --- a/src/Wavefront.hs +++ b/src/Wavefront.hs @@ -43,6 +43,9 @@ data ObjBuilder m = ObjBuilder , step :: [Int] -> m () , points :: [Int] -> m () , usemap :: Maybe S.ByteString -> m () + , maplib :: [S.ByteString] -> m () + , c_interp :: Bool -> m () + , d_interp :: Bool -> m () , badToken :: L.ByteString -> m () } @@ -79,6 +82,9 @@ nullBuilder = ObjBuilder , step = \is -> pure () , points = \is -> pure () , usemap = \map -> pure () + , maplib = \fns -> pure () + , c_interp = \b -> pure () + , d_interp = \b -> pure () , badToken = \bs -> pure () } @@ -173,7 +179,7 @@ findNewLine ps o@(ObjConfig args) bs = case L.break (\c -> c=='\n' || c=='\\' || 5 x call 6 cdc 7 x cdp - 8 x c_interp + 8 c_interp 9 con 10 x csh -- for all except these, 11 cstype -- Two chars suffice to distinguish @@ -181,13 +187,13 @@ findNewLine ps o@(ObjConfig args) bs = case L.break (\c -> c=='\n' || c=='\\' || 13 curv2 -- for all except these, 14 curv -- Two chars suffice to distinguish 15 deg - 16 x d_interp + 16 d_interp 17 end 18 f 19 g 20 hole 21 x lod - 22 x maplib + 22 maplib 23 mg 24 mtllib 25 o @@ -210,7 +216,6 @@ findNewLine ps o@(ObjConfig args) bs = case L.break (\c -> c=='\n' || c=='\\' || 42 vp 43 vt - -} nextToken :: (L.ByteString -> L.ByteString) -> L.ByteString -> L.ByteString @@ -419,7 +424,23 @@ parseOBJ builder args bs0 let u0:v0:_ = vs ++ repeat 0.0 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) "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) "en" -> do endFreeForm builder parseOBJ builder args (next 2 bs) "ho" -> -- hole @@ -499,6 +520,22 @@ parseOBJ builder args bs0 else Just (L.toStrict mtl) _ -> usemtl builder (L.toStrict mtl) parseOBJ builder args bs' + "ma" -> -- maplib + case findNewLine [] args $ next 2 bs of + (fnn,bs') -> do + let slurp fnn = case L.break (=='.') fnn of + (fn,ext) | L.null (L.drop 1 ext) -> if L.null fn then [] + else [fn] + | ext <- L.take 4 ext + -- XXX What is the map library extension? + , ext `elem` [".map",".mtl",".obj"] -> + if L.all isSpace (L.take 1 $ L.drop 4 ext) + then (fn <> ext) : slurp (findToken args $ L.drop 4 ext) + else let f:fs = slurp (L.drop 3 ext) in (fn <> L.take 3 ext <> f) : fs + | otherwise -> let (f:fs) = slurp (L.drop 1 ext) + in (fn <> L.take 1 ext <> f) : fs + maplib builder (map L.toStrict $ slurp fnn) + parseOBJ builder args bs' "mt" -> -- mtllib case findNewLine [] args $ next 2 bs of (fnn,bs') -> do @@ -513,7 +550,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,c_interp,d_interp,lod,shadow_obj,trace_obj,bevel + -- TODO: call,csh,lod,shadow_obj,trace_obj,bevel _ -> bad bs where bs = findToken args bs0 -- cgit v1.2.3