From 3e342655168472ead7e6fd38ef4a21d6132401af Mon Sep 17 00:00:00 2001
From: Joe Crayne <joe@jerkface.net>
Date: Thu, 13 Jun 2019 15:07:56 -0400
Subject: crayne parser: bmat

---
 src/Wavefront.hs | 26 ++++++++++++++++++--------
 1 file changed, 18 insertions(+), 8 deletions(-)

diff --git a/src/Wavefront.hs b/src/Wavefront.hs
index de9cb21..5cef6dc 100644
--- a/src/Wavefront.hs
+++ b/src/Wavefront.hs
@@ -39,6 +39,7 @@ data ObjBuilder m = ObjBuilder
     , deprecated_bzp   :: [Int] -> m ()
     , mtllib           :: [S.ByteString] -> m ()
     , objectName       :: S.ByteString -> m ()
+    , bmat             :: ParamSpec -> [Double] -> m ()
     , badToken         :: L.ByteString -> m ()
     }
 
@@ -52,7 +53,7 @@ nullBuilder = ObjBuilder
     , cstype           = \isRat typ -> pure ()
     , curv2            = \is -> pure ()
     , curv             = \u0 v0 is -> pure ()
-    , parm             = \isU is -> pure ()
+    , parm             = \uv is -> pure ()
     , specialPoints    = \is -> pure ()
     , endFreeForm      = pure ()
     , ctech            = \approx -> pure ()
@@ -71,6 +72,7 @@ nullBuilder = ObjBuilder
     , deprecated_bzp   = \is -> pure ()
     , mtllib           = \fns -> pure ()
     , objectName       = \obn -> pure ()
+    , bmat             = \uv fs -> pure ()
     , badToken         = \bs -> pure ()
     }
 
@@ -144,7 +146,7 @@ findToken (ObjConfig args) bs = case L.dropWhile (\c -> isSpace c || c=='\\') bs
 {-
 
      1	x   bevel
-     2	x   bmat
+     2	    bmat
      3	    bzp
      4	x   call
      5	    cdc
@@ -202,13 +204,13 @@ parseFloatsN n tok bs cont = case L.splitAt 10 (tok bs) of
 parseInts tok bs cont = case L.splitAt 5 (tok bs) of
     (ds,bs') -> case I.readSigned I.readDecimal (L.toStrict ds) of
         Just (x,b) -> parseInts tok (reconsChunk b bs') (cont . (x :))
-        Nothing    -> cont [] (ds <> bs')
+        Nothing    -> cont [] bs
 
 parseIntsN 0 tok bs cont = cont [] bs
 parseIntsN n tok bs cont = case L.splitAt 5 (tok bs) of
     (ds,bs') -> case I.readSigned I.readDecimal (L.toStrict ds) of
         Just (x,b) -> parseIntsN (n-1) tok (reconsChunk b bs') (cont . (x :))
-        Nothing    -> cont [] (ds <> bs')
+        Nothing    -> cont [] bs
 
 -- Optimize me
 parseTriples :: (L.ByteString -> L.ByteString) -> L.ByteString -> ([RefTriple] -> L.ByteString -> b) -> b
@@ -326,6 +328,11 @@ parseOBJ builder args bs0
         "vn" -> parseV vertexN 3
         "vp" -> parseV vertexP 3
         "bz" -> parseI deprecated_bzp 4 -- bzp
+        "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
         "co" -> -- con
                 parseEmbeddedCurves (findToken args) (next 2 bs) $ \ss bs' -> do
@@ -388,9 +395,9 @@ parseOBJ builder args bs0
                             parseFloatsN 1 (findToken args) bs' $ \fs bs'' -> do
                                 mergingGroup builder mg (head $ fs ++ [0])
                                 parseOBJ builder args bs''
-        "pa" -> parseChar 'u' (next 2 bs) $ \isU bs' -> do
-                    parseFloats (findToken args) (if isU then bs' else L.drop 1 bs') $ \vs bs'' -> do
-                       parm builder (if isU then ParamU else ParamV) vs
+        "pa" -> parseUV (next 2 bs) $ \uv bs' -> do
+                    parseFloats (findToken args) bs' $ \vs bs'' -> do
+                       parm builder uv vs
                        parseOBJ builder args bs''
         "sc" -> -- scrv
                 parseCurveSpecs (findToken args) (next 2 bs) $ \ss bs' -> do
@@ -456,7 +463,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,step,bmat,c_interp,d_interp,lod,shadow_obj,trace_obj,bevel
+        -- TODO: call,csh,step,c_interp,d_interp,lod,shadow_obj,trace_obj,bevel
         _    -> badToken builder bs
     where
         bs = findToken args bs0
@@ -464,6 +471,9 @@ parseOBJ builder args bs0
         parseChar c tok cont = case L.uncons tok of
                         Just (x,cs) | x==c -> cont True $ next 0 cs
                         _                  -> cont False tok
+        parseUV tok cont = parseChar 'u' tok $ \isU bs' -> do
+            cont (if isU then ParamU else ParamV)
+                 (if isU then bs' else L.drop 1 bs')
         parseV build n = do
                 parseFloats (findToken args) (L.drop n bs) $ \vs bs' -> do
                 build builder vs
-- 
cgit v1.2.3