crayne parser: bsp,bevel,lod,res,cdp keywords.

1 files 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