diff options
author | Joe Crayne <joe@jerkface.net> | 2019-06-13 15:07:56 -0400 |
---|---|---|
committer | Joe Crayne <joe@jerkface.net> | 2019-06-13 15:07:56 -0400 |
commit | 3e342655168472ead7e6fd38ef4a21d6132401af (patch) | |
tree | 12239002d80b71a0613658092a0ab25d719dc3b0 | |
parent | 71c593388559e4d6963fdbbd1ed57908e7ce62ef (diff) |
crayne parser: bmat
-rw-r--r-- | src/Wavefront.hs | 26 |
1 files 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 | |||
39 | , deprecated_bzp :: [Int] -> m () | 39 | , deprecated_bzp :: [Int] -> m () |
40 | , mtllib :: [S.ByteString] -> m () | 40 | , mtllib :: [S.ByteString] -> m () |
41 | , objectName :: S.ByteString -> m () | 41 | , objectName :: S.ByteString -> m () |
42 | , bmat :: ParamSpec -> [Double] -> m () | ||
42 | , badToken :: L.ByteString -> m () | 43 | , badToken :: L.ByteString -> m () |
43 | } | 44 | } |
44 | 45 | ||
@@ -52,7 +53,7 @@ nullBuilder = ObjBuilder | |||
52 | , cstype = \isRat typ -> pure () | 53 | , cstype = \isRat typ -> pure () |
53 | , curv2 = \is -> pure () | 54 | , curv2 = \is -> pure () |
54 | , curv = \u0 v0 is -> pure () | 55 | , curv = \u0 v0 is -> pure () |
55 | , parm = \isU is -> pure () | 56 | , parm = \uv is -> pure () |
56 | , specialPoints = \is -> pure () | 57 | , specialPoints = \is -> pure () |
57 | , endFreeForm = pure () | 58 | , endFreeForm = pure () |
58 | , ctech = \approx -> pure () | 59 | , ctech = \approx -> pure () |
@@ -71,6 +72,7 @@ nullBuilder = ObjBuilder | |||
71 | , deprecated_bzp = \is -> pure () | 72 | , deprecated_bzp = \is -> pure () |
72 | , mtllib = \fns -> pure () | 73 | , mtllib = \fns -> pure () |
73 | , objectName = \obn -> pure () | 74 | , objectName = \obn -> pure () |
75 | , bmat = \uv fs -> pure () | ||
74 | , badToken = \bs -> pure () | 76 | , badToken = \bs -> pure () |
75 | } | 77 | } |
76 | 78 | ||
@@ -144,7 +146,7 @@ findToken (ObjConfig args) bs = case L.dropWhile (\c -> isSpace c || c=='\\') bs | |||
144 | {- | 146 | {- |
145 | 147 | ||
146 | 1 x bevel | 148 | 1 x bevel |
147 | 2 x bmat | 149 | 2 bmat |
148 | 3 bzp | 150 | 3 bzp |
149 | 4 x call | 151 | 4 x call |
150 | 5 cdc | 152 | 5 cdc |
@@ -202,13 +204,13 @@ parseFloatsN n tok bs cont = case L.splitAt 10 (tok bs) of | |||
202 | parseInts tok bs cont = case L.splitAt 5 (tok bs) of | 204 | parseInts tok bs cont = case L.splitAt 5 (tok bs) of |
203 | (ds,bs') -> case I.readSigned I.readDecimal (L.toStrict ds) of | 205 | (ds,bs') -> case I.readSigned I.readDecimal (L.toStrict ds) of |
204 | Just (x,b) -> parseInts tok (reconsChunk b bs') (cont . (x :)) | 206 | Just (x,b) -> parseInts tok (reconsChunk b bs') (cont . (x :)) |
205 | Nothing -> cont [] (ds <> bs') | 207 | Nothing -> cont [] bs |
206 | 208 | ||
207 | parseIntsN 0 tok bs cont = cont [] bs | 209 | parseIntsN 0 tok bs cont = cont [] bs |
208 | parseIntsN n tok bs cont = case L.splitAt 5 (tok bs) of | 210 | parseIntsN n tok bs cont = case L.splitAt 5 (tok bs) of |
209 | (ds,bs') -> case I.readSigned I.readDecimal (L.toStrict ds) of | 211 | (ds,bs') -> case I.readSigned I.readDecimal (L.toStrict ds) of |
210 | Just (x,b) -> parseIntsN (n-1) tok (reconsChunk b bs') (cont . (x :)) | 212 | Just (x,b) -> parseIntsN (n-1) tok (reconsChunk b bs') (cont . (x :)) |
211 | Nothing -> cont [] (ds <> bs') | 213 | Nothing -> cont [] bs |
212 | 214 | ||
213 | -- Optimize me | 215 | -- Optimize me |
214 | parseTriples :: (L.ByteString -> L.ByteString) -> L.ByteString -> ([RefTriple] -> L.ByteString -> b) -> b | 216 | parseTriples :: (L.ByteString -> L.ByteString) -> L.ByteString -> ([RefTriple] -> L.ByteString -> b) -> b |
@@ -326,6 +328,11 @@ parseOBJ builder args bs0 | |||
326 | "vn" -> parseV vertexN 3 | 328 | "vn" -> parseV vertexN 3 |
327 | "vp" -> parseV vertexP 3 | 329 | "vp" -> parseV vertexP 3 |
328 | "bz" -> parseI deprecated_bzp 4 -- bzp | 330 | "bz" -> parseI deprecated_bzp 4 -- bzp |
331 | "bm" -> parseUV (next 2 bs) $ \uv bs' -> do -- bmat | ||
332 | parseFloats (findToken args) bs' $ \vs bs'' -> do | ||
333 | bmat builder uv vs | ||
334 | parseOBJ builder args bs'' | ||
335 | |||
329 | "cd" -> parseI deprecated_cdc 4 -- cdc | 336 | "cd" -> parseI deprecated_cdc 4 -- cdc |
330 | "co" -> -- con | 337 | "co" -> -- con |
331 | parseEmbeddedCurves (findToken args) (next 2 bs) $ \ss bs' -> do | 338 | parseEmbeddedCurves (findToken args) (next 2 bs) $ \ss bs' -> do |
@@ -388,9 +395,9 @@ parseOBJ builder args bs0 | |||
388 | parseFloatsN 1 (findToken args) bs' $ \fs bs'' -> do | 395 | parseFloatsN 1 (findToken args) bs' $ \fs bs'' -> do |
389 | mergingGroup builder mg (head $ fs ++ [0]) | 396 | mergingGroup builder mg (head $ fs ++ [0]) |
390 | parseOBJ builder args bs'' | 397 | parseOBJ builder args bs'' |
391 | "pa" -> parseChar 'u' (next 2 bs) $ \isU bs' -> do | 398 | "pa" -> parseUV (next 2 bs) $ \uv bs' -> do |
392 | parseFloats (findToken args) (if isU then bs' else L.drop 1 bs') $ \vs bs'' -> do | 399 | parseFloats (findToken args) bs' $ \vs bs'' -> do |
393 | parm builder (if isU then ParamU else ParamV) vs | 400 | parm builder uv vs |
394 | parseOBJ builder args bs'' | 401 | parseOBJ builder args bs'' |
395 | "sc" -> -- scrv | 402 | "sc" -> -- scrv |
396 | parseCurveSpecs (findToken args) (next 2 bs) $ \ss bs' -> do | 403 | parseCurveSpecs (findToken args) (next 2 bs) $ \ss bs' -> do |
@@ -456,7 +463,7 @@ parseOBJ builder args bs0 | |||
456 | in (fn <> L.take 1 ext <> f) : fs | 463 | in (fn <> L.take 1 ext <> f) : fs |
457 | mtllib builder (map L.toStrict $ slurp fnn) | 464 | mtllib builder (map L.toStrict $ slurp fnn) |
458 | parseOBJ builder args bs' | 465 | parseOBJ builder args bs' |
459 | -- TODO: call,csh,step,bmat,c_interp,d_interp,lod,shadow_obj,trace_obj,bevel | 466 | -- TODO: call,csh,step,c_interp,d_interp,lod,shadow_obj,trace_obj,bevel |
460 | _ -> badToken builder bs | 467 | _ -> badToken builder bs |
461 | where | 468 | where |
462 | bs = findToken args bs0 | 469 | bs = findToken args bs0 |
@@ -464,6 +471,9 @@ parseOBJ builder args bs0 | |||
464 | parseChar c tok cont = case L.uncons tok of | 471 | parseChar c tok cont = case L.uncons tok of |
465 | Just (x,cs) | x==c -> cont True $ next 0 cs | 472 | Just (x,cs) | x==c -> cont True $ next 0 cs |
466 | _ -> cont False tok | 473 | _ -> cont False tok |
474 | parseUV tok cont = parseChar 'u' tok $ \isU bs' -> do | ||
475 | cont (if isU then ParamU else ParamV) | ||
476 | (if isU then bs' else L.drop 1 bs') | ||
467 | parseV build n = do | 477 | parseV build n = do |
468 | parseFloats (findToken args) (L.drop n bs) $ \vs bs' -> do | 478 | parseFloats (findToken args) (L.drop n bs) $ \vs bs' -> do |
469 | build builder vs | 479 | build builder vs |