crayne parser: usemap support

1 files changed, 23 insertions, 6 deletions

diff --git a/src/Wavefront.hs b/src/Wavefront.hs
index ca4b497..84edd6d 100644
--- a/src/Wavefront.hs
+++ b/src/Wavefront.hs
@@ -42,6 +42,7 @@ data ObjBuilder m = ObjBuilder
     , bmat             :: ParamSpec -> [Double] -> m ()
     , step             :: [Int] -> m ()
     , points           :: [Int] -> m ()
+    , usemap           :: Maybe S.ByteString -> m ()
     , badToken         :: L.ByteString -> m ()
     }
 
@@ -77,6 +78,7 @@ nullBuilder = ObjBuilder
     , bmat             = \uv fs          -> pure ()
     , step             = \is             -> pure ()
     , points           = \is             -> pure ()
+    , usemap           = \map            -> pure ()
     , badToken         = \bs             -> pure ()
     }
 
@@ -201,7 +203,7 @@ findNewLine ps o@(ObjConfig args) bs = case L.break (\c -> c=='\n' || c=='\\' ||
     35      surf
     36  x   trace_obj -- for all except these,
     37      trim      -- Two chars suffice to distinguish
-    38  x   usemap -- for all except these,
+    38      usemap -- for all except these,
     39      usemtl -- Two chars suffice to distinguish
     40      v
     41      vn
@@ -327,6 +329,15 @@ lengthLessThan n bs =
           (L.toChunks bs)
           n
 
+substVar :: ObjConfig -> L.ByteString -> L.ByteString
+substVar _ mtl | L.take 1 mtl/="$" = mtl
+substVar (ObjConfig args) mtl = case I.readDecimal (L.toStrict $ L.drop 1 mtl) of
+    Just (i,_) -> case IntMap.lookup i args of
+        Just val -> val
+        Nothing  -> mtl
+    Nothing -> mtl
+
+
 parseOBJ :: Monad m => ObjBuilder m -> ObjConfig -> L.ByteString -> m ()
 parseOBJ builder args bs0
     | lengthLessThan 2 bs = return ()
@@ -477,11 +488,17 @@ parseOBJ builder args bs0
                 parseCurveSpecs (findToken args) (next 2 bs) $ \ss bs' -> do
                     trim builder ss
                     parseOBJ builder args bs'
-        "us" -> -- usemtl
-                case L.break isSpace $ next 2 bs of
-                    (mtl,bs') -> do
-                        usemtl builder (L.toStrict mtl)
-                        parseOBJ builder args bs'
+        "us" -> -- usemtl or usemap
+                if lengthLessThan 5 bs
+                    then bad bs
+                    else case L.break isSpace $ next 2 bs of
+                        (mtl0,bs') -> do
+                            let mtl = substVar args mtl0
+                            case L.index bs 4 of
+                                'a' -> usemap builder $ if mtl == "off" then Nothing
+                                                                        else Just (L.toStrict mtl)
+                                _   -> usemtl builder (L.toStrict mtl)
+                            parseOBJ builder args bs'
         "mt" -> -- mtllib
                 case findNewLine [] args $ next 2 bs of
                     (fnn,bs') -> do