summaryrefslogtreecommitdiff
path: root/src/Wavefront/Lex.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/Wavefront/Lex.hs')
-rw-r--r--src/Wavefront/Lex.hs654
1 files changed, 654 insertions, 0 deletions
diff --git a/src/Wavefront/Lex.hs b/src/Wavefront/Lex.hs
new file mode 100644
index 0000000..501549f
--- /dev/null
+++ b/src/Wavefront/Lex.hs
@@ -0,0 +1,654 @@
1{-# LANGUAGE NondecreasingIndentation #-}
2{-# LANGUAGE OverloadedStrings #-}
3module Wavefront.Lex where
4
5import qualified Data.ByteString.Lazy.Char8 as L
6import qualified Data.ByteString.Char8 as S
7import Data.ByteString.Internal as BS
8import Data.Char
9import Data.IntMap (IntMap)
10import qualified Data.IntMap as IntMap
11import Data.ByteString.Lex.Fractional as F
12import Data.ByteString.Lex.Integral as I
13
14data ObjBuilder m = ObjBuilder
15 { vertex :: [Double] -> m ()
16 , vertexT :: [Double] -> m ()
17 , vertexN :: [Double] -> m ()
18 , vertexP :: [Double] -> m ()
19 , face :: [RefTriple] -> m ()
20 , cstype :: Bool -> CSType -> m ()
21 , curv2 :: [Int] -> m ()
22 , curv :: Double -> Double -> [Int] -> m ()
23 , parm :: ParamSpec -> [Double] -> m ()
24 , specialPoints :: [Int] -> m ()
25 , endFreeForm :: m ()
26 , ctech :: CurveSamplingSpec -> m ()
27 , stech :: SurfaceSamplingSpec -> m ()
28 , deg :: [Int] -> m ()
29 , surf :: Double -> Double -> Double -> Double -> [RefTriple] -> m ()
30 , trim :: [CurveSpec] -> m ()
31 , hole :: [CurveSpec] -> m ()
32 , specialCurves :: [CurveSpec] -> m ()
33 , equivalentCurves :: [EmbeddedCurve] -> m ()
34 , groups :: [S.ByteString] -> m ()
35 , smoothingGroup :: Int -> m ()
36 , mergingGroup :: Int -> Double -> m ()
37 , usemtl :: S.ByteString -> m ()
38 , deprecated_cdc :: [Int] -> m ()
39 , deprecated_cdp :: [Int] -> m ()
40 , deprecated_bzp :: [Int] -> m ()
41 , deprecated_bsp :: [Int] -> m ()
42 , mtllib :: [S.ByteString] -> m ()
43 , objectName :: S.ByteString -> m ()
44 , bmat :: ParamSpec -> [Double] -> m ()
45 , step :: [Int] -> m ()
46 , points :: [Int] -> m ()
47 , usemap :: Maybe S.ByteString -> m ()
48 , maplib :: [S.ByteString] -> m ()
49 , c_interp :: Bool -> m ()
50 , d_interp :: Bool -> m ()
51 , trace_obj :: S.ByteString -> m ()
52 , shadow_obj :: S.ByteString -> m ()
53 , deprecated_res :: [Int] -> m ()
54 , bevel :: Bool -> m ()
55 , lod :: Int -> m ()
56 , call :: S.ByteString -> [S.ByteString] -> m ()
57 , command :: Bool -> L.ByteString -> m L.ByteString
58 , badToken :: L.ByteString -> m ()
59 }
60
61nullBuilder :: Applicative m => m () -> ObjBuilder m
62nullBuilder def = ObjBuilder
63 { vertex = \vs -> def
64 , vertexT = \vs -> def
65 , vertexN = \vs -> def
66 , vertexP = \vs -> def
67 , face = \is -> def
68 , cstype = \isRat typ -> def
69 , curv2 = \is -> def
70 , curv = \u0 v0 is -> def
71 , parm = \uv is -> def
72 , specialPoints = \is -> def
73 , endFreeForm = def
74 , ctech = \approx -> def
75 , stech = \approx -> def
76 , deg = \is -> def
77 , surf = \u0 u1 v0 v1 ts -> def
78 , trim = \ss -> def
79 , hole = \ss -> def
80 , specialCurves = \ss -> def
81 , equivalentCurves = \ccs -> def
82 , groups = \gs -> def
83 , smoothingGroup = \sg -> def
84 , mergingGroup = \mg δ -> def
85 , usemtl = \mtl -> def
86 , deprecated_cdc = \is -> def
87 , deprecated_cdp = \is -> def
88 , deprecated_bzp = \is -> def
89 , deprecated_bsp = \is -> def
90 , mtllib = \fns -> def
91 , objectName = \obn -> def
92 , bmat = \uv fs -> def
93 , step = \is -> def
94 , points = \is -> def
95 , usemap = \map -> def
96 , maplib = \fns -> def
97 , c_interp = \b -> def
98 , d_interp = \b -> def
99 , trace_obj = \obj -> def
100 , shadow_obj = \obj -> def
101 , deprecated_res = \is -> def
102 , bevel = \b -> def
103 , lod = \lvl -> def
104 , call = \obj args -> def
105 , command = \b cmd -> def *> pure L.empty
106 , badToken = \bs -> def
107 }
108
109
110data CurveSamplingSpec
111 -- ctech cparm
112 = UniformSubdivision
113 { divisionsPerCurveDegree :: Double -- ^ This really ought to be an integer but
114 -- but examples show floats. The only way
115 -- it makes sense as a float is if we are to
116 -- convert to an integer *after* multiplying
117 -- by the curve degree.
118 }
119 -- ctech cspace
120 | MaxLengthPolygonal { maxPolygonEdgeLength :: Double }
121 -- ctech curv
122 | CurvatureBasedPolygon { maxDistanceToCurve :: Double, maximumDegreesPerSample :: Double }
123 deriving (Eq,Show)
124
125data SurfaceSamplingSpec
126 -- stech cparma ures vres
127 = UniformIsoparametric { uDivisionsPerDegree :: Double, vDivisionsPerDegree :: Double }
128 -- stech cparmb uvres
129 | UniformAfterTrimming { uvDivisionsPerDegree :: Double }
130 -- stech cspace maxlength
131 | MaxLengthPolytopal { maxPolytopEdgeLength :: Double }
132 -- stech curv maxdist maxangle
133 | CurvatureBasedPolytope { maxDistanceToSurface :: Double, maxDegreesPerCorner :: Double }
134 deriving (Eq,Show)
135
136
137data ObjState = ObjState
138 {
139 }
140
141newtype ObjConfig = ObjConfig
142 { cfgSubst :: IntMap L.ByteString
143 }
144
145-- consChunk :: S.ByteString -> L.ByteString -> L.ByteString
146-- consChunk c bs = L.fromChunks (c : L.toChunks bs)
147
148reappend :: ByteString -> ByteString -> Maybe ByteString
149reappend a b =
150 let (ap,ao,al) = BS.toForeignPtr a
151 (bp,bo,bl) = BS.toForeignPtr b
152 in if ap == bp && ao+al == bo
153 then Just $ BS.PS ap ao (al+bl)
154 else Nothing
155
156reconsChunk :: S.ByteString -> L.ByteString -> L.ByteString
157reconsChunk b bs = case L.toChunks bs of
158 (c:cs) -> case reappend b c of
159 Just x -> L.fromChunks (x:cs)
160 Nothing -> L.fromChunks (b:c:cs)
161 _ -> L.fromChunks [b]
162
163findToken :: ObjConfig -> L.ByteString -> L.ByteString
164findToken (ObjConfig args) bs = case L.dropWhile (\c -> isSpace c || c=='\\') bs of
165 cs -> case L.uncons cs of
166 Just ('#',comment) -> findToken (ObjConfig args) $ L.drop 1 $ L.dropWhile (/='\n') comment
167 Just ('$',ref) -> case L.splitAt 5 ref of
168 (refp,ds) -> case I.readDecimal (L.toStrict refp) of
169 Just (i,es) -> case IntMap.lookup i args of
170 Just val -> val <> reconsChunk es ds
171 _ -> reconsChunk es ds
172 _ -> cs
173 Just _ -> cs
174 Nothing -> L.empty
175
176findNewLine :: [L.ByteString] -> ObjConfig -> L.ByteString -> (L.ByteString,L.ByteString)
177findNewLine ps o@(ObjConfig args) bs = case L.break (\c -> c=='\n' || c=='\\' || c=='#' || c=='\\') bs of
178 (ts,cs) -> case L.uncons cs of
179 Just ('\n',ds) -> (L.concat $ reverse $ ts : ps,ds)
180 Just ('#',comment) -> findNewLine (ts:ps) o $ L.dropWhile (/='\n') comment
181 Just ('$',ref) -> case L.splitAt 5 ref of
182 (refp,ds) -> case I.readDecimal (L.toStrict refp) of
183 Just (i,es) -> case IntMap.lookup i args of
184 Just val -> findNewLine (val:ts:ps) o $ reconsChunk es ds
185 _ -> findNewLine (ts:ps) o $ reconsChunk es ds
186 _ -> findNewLine ("$":ts:ps) o ref
187 Just ('\\',ds) -> findNewLine (ts:ps) o $ if L.take 1 ds == "\n" then L.drop 1 ds
188 else ds
189 Nothing -> (L.concat $ reverse $ ts : ps,L.empty)
190
191-- The 43 keywords of the OBJ file format:
192--
193-- 1 bevel
194-- 2 bmat
195-- 3 bsp
196-- 4 bzp
197-- 5 call
198-- 6 cdc
199-- 7 cdp
200-- 8 c_interp
201-- 9 con
202-- 10 csh
203-- 11 cstype
204-- 12 ctech
205-- 13 curv2
206-- 14 curv
207-- 15 deg
208-- 16 d_interp
209-- 17 end
210-- 18 f
211-- 19 g
212-- 20 hole
213-- 21 lod
214-- 22 maplib
215-- 23 mg
216-- 24 mtllib
217-- 25 o
218-- 26 p
219-- 27 parm
220-- 28 res
221-- 29 s
222-- 30 scrv
223-- 31 shadow_obj
224-- 32 sp
225-- 33 stech
226-- 34 step
227-- 35 surf
228-- 36 trace_obj
229-- 37 trim
230-- 38 usemap
231-- 39 usemtl
232-- 40 v
233-- 41 vn
234-- 42 vp
235-- 43 vt
236
237nextToken :: (L.ByteString -> L.ByteString) -> L.ByteString -> L.ByteString
238nextToken tok bs = tok $ L.dropWhile (not . isSpace) bs
239
240parseFloats tok bs cont = case L.splitAt 10 (tok bs) of
241 (ds,bs') -> case F.readSigned F.readExponential (L.toStrict ds) of
242 Just (x,b) -> parseFloats tok (reconsChunk b bs') (cont . (x :))
243 Nothing -> cont [] bs
244
245parseFloatsN 0 _ bs cont = cont [] bs
246parseFloatsN n tok bs cont = case L.splitAt 10 (tok bs) of
247 (ds,bs') -> case F.readSigned F.readExponential (L.toStrict ds) of
248 Just (x,b) -> parseFloatsN (n-1) tok (reconsChunk b bs') (cont . (x :))
249 Nothing -> cont [] bs
250
251parseInts tok bs cont = case L.splitAt 5 (tok bs) of
252 (ds,bs') -> case I.readSigned I.readDecimal (L.toStrict ds) of
253 Just (x,b) -> parseInts tok (reconsChunk b bs') (cont . (x :))
254 Nothing -> cont [] bs
255
256parseIntsN 0 tok bs cont = cont [] bs
257parseIntsN n tok bs cont = case L.splitAt 5 (tok bs) of
258 (ds,bs') -> case I.readSigned I.readDecimal (L.toStrict ds) of
259 Just (x,b) -> parseIntsN (n-1) tok (reconsChunk b bs') (cont . (x :))
260 Nothing -> cont [] bs
261
262-- Optimize me
263parseTriples :: (L.ByteString -> L.ByteString) -> L.ByteString -> ([RefTriple] -> L.ByteString -> b) -> b
264parseTriples tok bs cont = case L.splitAt 17 (tok bs) of
265 (ds,bs') -> case I.readSigned I.readDecimal (L.toStrict ds) of
266
267 Just (v,b) -> case S.splitAt 1 b of
268
269 ("/",ds') -> case I.readSigned I.readDecimal ds' of
270
271 Just (vt,c) -> case S.splitAt 1 c of
272 ("/",ds'') -> case I.readSigned I.readDecimal ds'' of
273 Just (vn,d) -> parseTriples tok (reconsChunk d bs') $ cont . (RefTriple v (Just vt) (Just vn) :)
274 Nothing -> parseTriples tok (reconsChunk ds'' bs') $ cont . (RefTriple v (Just vt) Nothing :)
275
276 _ -> parseTriples tok (reconsChunk c bs') $ cont . (RefTriple v (Just vt) Nothing :)
277
278 Nothing -> case S.splitAt 1 ds' of
279 ("/",ds'') -> case I.readSigned I.readDecimal ds'' of
280 Just (vn,d) -> parseTriples tok (reconsChunk d bs') $ cont . (RefTriple v Nothing (Just vn) :)
281 Nothing -> parseTriples tok (reconsChunk ds'' bs') $ cont . (RefTriple v Nothing Nothing :)
282
283 _ -> parseTriples tok (reconsChunk ds' bs') $ cont . (RefTriple v Nothing Nothing :)
284
285
286 _ -> parseTriples tok (reconsChunk b bs') $ cont . (RefTriple v Nothing Nothing :)
287
288 Nothing -> cont [] bs
289
290parseCurveSpecs :: (L.ByteString -> L.ByteString) -> L.ByteString -> ([CurveSpec] -> L.ByteString -> b) -> b
291parseCurveSpecs tok bs cont = parseFloatsN 2 tok bs $ \fs bs' -> case fs of
292 (u0:u1:_) -> do
293 parseIntsN 1 tok bs' $ \is bs'' -> case is of
294 (i:_) -> parseCurveSpecs tok bs'' $ cont . (CurveSpec u0 u1 i :)
295 _ -> cont [] bs''
296
297 _ -> cont [] bs'
298
299
300parseCurveSpecsN :: Int -> (L.ByteString -> L.ByteString) -> L.ByteString -> ([CurveSpec] -> L.ByteString -> b) -> b
301parseCurveSpecsN 0 tok bs cont = cont [] bs
302parseCurveSpecsN n tok bs cont = parseFloatsN 2 tok bs $ \fs bs' -> case fs of
303 (u0:u1:_) -> do
304 parseIntsN 1 tok bs' $ \is bs'' -> case is of
305 (i:_) -> parseCurveSpecsN (n-1) tok bs'' $ cont . (CurveSpec u0 u1 i :)
306 _ -> cont [] bs''
307
308 _ -> cont [] bs'
309
310parseEmbeddedCurves :: (L.ByteString -> L.ByteString) -> L.ByteString -> ([EmbeddedCurve] -> L.ByteString -> b) -> b
311parseEmbeddedCurves tok bs cont = parseIntsN 1 tok bs $ \is bs' -> case is of
312 (sref:_) -> do
313 parseCurveSpecsN 1 tok bs' $ \cs bs'' -> case cs of
314 (c:_) -> parseEmbeddedCurves tok bs'' $ cont . (EmbeddedCurve sref c :)
315 _ -> cont [] bs''
316
317 _ -> cont [] bs'
318
319data CSType = Bmatrix | Bezier | Bspline | Cardinal | Taylor
320 deriving (Eq,Ord,Show,Enum)
321
322data ParamSpec = ParamU | ParamV
323 deriving (Eq,Ord,Show,Enum)
324
325data RefTriple = RefTriple
326 { refV :: Int
327 , refT :: Maybe Int
328 , refN :: Maybe Int
329 }
330-- data RefTriple = RefTriple Int (Maybe Int) (Maybe Int)
331 deriving (Eq,Ord,Show)
332
333data CurveSpec = CurveSpec
334 { curveStart :: Double
335 , curveEnd :: Double
336 , curveRef :: Int
337 }
338 deriving (Eq,Ord,Show)
339
340data EmbeddedCurve = EmbeddedCurve
341 { curveSurfaceRef :: Int
342 , embeddedCurve :: CurveSpec
343 }
344 deriving (Eq,Ord,Show)
345
346lengthLessThan :: Int -> L.ByteString -> Bool
347lengthLessThan n bs =
348 foldr (\c ret ac -> let m = S.length c in if ac <= m then False else ret $! ac - m)
349 (const True)
350 (L.toChunks bs)
351 n
352
353substVar :: ObjConfig -> L.ByteString -> L.ByteString
354substVar _ mtl | L.take 1 mtl/="$" = mtl
355substVar (ObjConfig args) mtl = case I.readDecimal (L.toStrict $ L.drop 1 mtl) of
356 Just (i,_) -> case IntMap.lookup i args of
357 Just val -> val
358 Nothing -> mtl
359 Nothing -> mtl
360
361
362parseOBJ :: Monad m => ObjBuilder m -> ObjConfig -> L.ByteString -> m ()
363parseOBJ builder args bs0
364 | lengthLessThan 2 bs = return ()
365 | isSpace (L.index bs 1) = case L.head bs of
366 'f' -> parseT face 2
367 'g' -> case findNewLine [] args $ L.drop 1 bs of -- Newline required to terminate group name list.
368 (gn,bs') -> do
369 groups builder (map L.toStrict $ L.words gn)
370 parseOBJ builder args bs'
371 's' -> case next 1 bs of
372 tok -> parseOffOrNumber tok $ \sg bs' -> do
373 smoothingGroup builder sg
374 parseOBJ builder args bs'
375 'v' -> parseV vertex 2
376 'o' -> -- o object-name
377 case findNewLine [] args $ L.drop 1 bs of
378 (objn,bs') -> do
379 objectName builder (L.toStrict objn)
380 parseOBJ builder args bs'
381 'p' -> parseI points 2
382 _ -> bad bs
383 | otherwise = case L.take 2 bs of
384 "vt" -> parseV vertexT 3
385 "vn" -> parseV vertexN 3
386 "vp" -> parseV vertexP 3
387 "be" -> parseOF bevel 2 -- bevel
388 "bm" -> parseUV (next 2 bs) $ \uv bs' -> do -- bmat
389 parseFloats (findToken args) bs' $ \vs bs'' -> do
390 bmat builder uv vs
391 parseOBJ builder args bs''
392
393 "bs" -> parseI deprecated_bsp 4 -- bsp
394 "bz" -> parseI deprecated_bzp 4 -- bzp
395 "ca" -> -- call
396 case findNewLine [] args $ next 2 bs of
397 (fnn,bs') -> do
398 let slurp fnn = case L.break (=='.') fnn of
399 (fn,ext) | L.null (L.drop 1 ext) -> if L.null fn then []
400 else [fn]
401 | ".obj" <- L.take 4 ext ->
402 if L.all isSpace (L.take 1 $ L.drop 4 ext)
403 then (fn <> ".obj") : slurpArgs (findToken args $ L.drop 4 ext)
404 else let f:fs = slurp (L.drop 3 ext) in (fn <> L.take 3 ext <> f) : fs
405 | otherwise -> let (f:fs) = slurp (L.drop 1 ext)
406 in (fn <> L.take 1 ext <> f) : fs
407 slurpArgs fnn | L.null fnn = []
408 slurpArgs fnn = case L.break isSpace fnn of
409 (a,as) -> findToken args a : slurpArgs as
410 case map L.toStrict $ slurpArgs fnn of
411 [] -> return ()
412 fn:as -> call builder fn as
413 parseOBJ builder args bs'
414
415 "cd" -> if lengthLessThan 3 bs || L.index bs 2 /= 'p'
416 then parseI deprecated_cdc 4 -- cdc
417 else parseI deprecated_cdp 4 -- cdp
418 "co" -> -- con
419 parseEmbeddedCurves (findToken args) (next 2 bs) $ \ss bs' -> do
420 equivalentCurves builder ss
421 parseOBJ builder args bs'
422 "cs" -> if lengthLessThan 3 bs
423 then bad bs
424 else case L.index bs 2 of
425 'h' -> -- csh
426 let (dash,tok) = L.splitAt 1 $ next 3 bs
427 wantsErrorCheck = dash /= "-"
428 in case findNewLine [] args tok of
429 (cmd,bs') -> do result <- command builder wantsErrorCheck cmd
430 parseOBJ builder args $ result <> bs'
431 _ -> -- cstype
432 let parseRat = parseChar 'r'
433 parseTyp tok cont | lengthLessThan 3 tok = bad tok
434 | otherwise = case L.index tok 2 of
435 'a' -> cont Bmatrix $ next 3 tok
436 'z' -> cont Bezier $ next 3 tok
437 'p' -> cont Bspline $ next 3 tok
438 'r' -> cont Cardinal $ next 3 tok
439 'y' -> cont Taylor $ next 3 tok
440 _ -> bad tok
441 in parseRat (next 2 bs) $ \isRat bs' -> do
442 parseTyp bs' $ \typ bs'' -> do
443 cstype builder isRat typ
444 parseOBJ builder args bs''
445 "ct" -> -- ctech
446 let tok = next 2 bs
447 in if lengthLessThan 2 tok
448 then bad tok
449 else case L.index tok 1 of
450 'p' -> -- cparm
451 parseFloats (findToken args) (next 2 tok) $ \is bs' -> do
452 let x:_ = is ++ [0]
453 ctech builder (UniformSubdivision x)
454 parseOBJ builder args bs'
455 's' -> -- cspace
456 parseFloats (findToken args) (next 2 tok) $ \fs bs' -> do
457 let x:_ = fs ++ [1.0]
458 ctech builder (MaxLengthPolygonal x)
459 parseOBJ builder args bs'
460 'u' -> -- curv
461 parseFloats (findToken args) (next 2 tok) $ \fs bs' -> do
462 let δ:θ:_ = fs ++ repeat 1.0
463 ctech builder (CurvatureBasedPolygon δ θ)
464 parseOBJ builder args bs'
465 _ -> bad tok
466 "cu" -> if lengthLessThan 5 bs
467 then bad bs
468 else if L.index bs 4 == '2'
469 then parseI curv2 5 -- curv2
470 else do -- curv
471 parseFloatsN 2 (findToken args) (L.drop 4 bs) $ \vs bs' ->
472 parseInts (findToken args) bs' $ \is bs'' -> do
473 let u0:v0:_ = vs ++ repeat 0.0
474 curv builder u0 v0 is
475 parseOBJ builder args bs''
476 "c_" -> -- c_interp
477 parseOF c_interp 2
478 "de" -> parseI deg 3
479 "d_" -> -- d_interp
480 parseOF d_interp 2
481 "en" -> do endFreeForm builder
482 parseOBJ builder args (next 2 bs)
483 "lo" -> -- lod
484 parseInts (findToken args) (next 2 bs) $ \is bs' -> do
485 let level:_ = is ++ [0]
486 lod builder level
487 parseOBJ builder args bs'
488 "ho" -> -- hole
489 parseCurveSpecs (findToken args) (next 2 bs) $ \ss bs' -> do
490 hole builder ss
491 parseOBJ builder args bs'
492 "mg" -> case next 2 bs of
493 tok -> parseOffOrNumber tok $ \mg bs' -> do
494 parseFloatsN 1 (findToken args) bs' $ \fs bs'' -> do
495 mergingGroup builder mg (head $ fs ++ [0])
496 parseOBJ builder args bs''
497 "pa" -> parseUV (next 2 bs) $ \uv bs' -> do
498 parseFloats (findToken args) bs' $ \vs bs'' -> do
499 parm builder uv vs
500 parseOBJ builder args bs''
501 "re" -> -- res (deprecated)
502 parseI deprecated_res 3
503 "sc" -> -- scrv
504 parseCurveSpecs (findToken args) (next 2 bs) $ \ss bs' -> do
505 specialCurves builder ss
506 parseOBJ builder args bs'
507 "sh" -> -- shadow_obj
508 parseO shadow_obj 10
509 "sp" -> parseI specialPoints 3
510 "st" -> -- stech or step
511 if lengthLessThan 4 bs then bad bs
512 else case L.index bs 3 of
513 'c' ->
514 -- stech
515 let tok = next 2 bs
516 in if lengthLessThan 2 tok
517 then bad tok
518 else case L.index tok 1 of
519 'p' -> -- cparma/cparmb
520 if lengthLessThan 6 tok
521 then bad tok
522 else if L.index tok 5 == 'b'
523 then -- cparmb
524 parseFloats (findToken args) (next 5 tok) $ \is bs' -> do
525 let x:_ = is ++ [0]
526 stech builder (UniformAfterTrimming x)
527 parseOBJ builder args bs'
528 else -- cparma
529 parseFloats (findToken args) (next 5 tok) $ \is bs' -> do
530 let x:y:_ = is ++ [0]
531 stech builder (UniformIsoparametric x y)
532 parseOBJ builder args bs'
533 's' -> -- cspace
534 parseFloats (findToken args) (next 2 tok) $ \fs bs' -> do
535 let x:_ = fs ++ [1.0]
536 stech builder (MaxLengthPolytopal x)
537 parseOBJ builder args bs'
538 'u' -> -- curv
539 parseFloats (findToken args) (next 2 tok) $ \fs bs' -> do
540 let δ:θ:_ = fs ++ repeat 1.0
541 stech builder (CurvatureBasedPolytope δ θ)
542 parseOBJ builder args bs'
543 _ -> bad tok
544
545 _ -> -- step
546 parseI step 4
547
548 "su" -> -- surf
549 parseFloatsN 4 (findToken args) (next 2 bs) $ \fs bs' -> do
550 parseTriples (findToken args) bs' $ \ts bs'' -> do
551 let u0:u1:v0:v1:_ = fs ++ repeat 0
552 surf builder u0 u1 v0 v1 ts
553 parseOBJ builder args bs''
554 "tr" -> -- trip or trace_obj
555 if lengthLessThan 3 bs
556 then bad bs
557 else case L.index bs 2 of
558 'a' -> -- trace_obj
559 parseO trace_obj 9
560 _ -> -- trim
561 parseCurveSpecs (findToken args) (next 2 bs) $ \ss bs' -> do
562 trim builder ss
563 parseOBJ builder args bs'
564 "us" -> -- usemtl or usemap
565 if lengthLessThan 5 bs
566 then bad bs
567 else case L.break isSpace $ next 2 bs of
568 (mtl0,bs') -> do
569 let mtl = substVar args mtl0
570 case L.index bs 4 of
571 'a' -> usemap builder $ if mtl == "off" then Nothing
572 else Just (L.toStrict mtl)
573 _ -> usemtl builder (L.toStrict mtl)
574 parseOBJ builder args bs'
575 "ma" -> -- maplib
576 case findNewLine [] args $ next 2 bs of
577 (fnn,bs') -> do
578 let slurp fnn = case L.break (=='.') fnn of
579 (fn,ext) | L.null (L.drop 1 ext) -> if L.null fn then []
580 else [fn]
581 | ext <- L.take 4 ext
582 -- XXX What is the map library extension?
583 , ext `elem` [".map",".mtl",".obj"] ->
584 if L.all isSpace (L.take 1 $ L.drop 4 ext)
585 then (fn <> ext) : slurp (findToken args $ L.drop 4 ext)
586 else let f:fs = slurp (L.drop 3 ext) in (fn <> L.take 3 ext <> f) : fs
587 | otherwise -> let (f:fs) = slurp (L.drop 1 ext)
588 in (fn <> L.take 1 ext <> f) : fs
589 maplib builder (map L.toStrict $ slurp fnn)
590 parseOBJ builder args bs'
591 "mt" -> -- mtllib
592 case findNewLine [] args $ next 2 bs of
593 (fnn,bs') -> do
594 let slurp fnn = case L.break (=='.') fnn of
595 (fn,ext) | L.null (L.drop 1 ext) -> if L.null fn then []
596 else [fn]
597 | ".mtl" <- L.take 4 ext ->
598 if L.all isSpace (L.take 1 $ L.drop 4 ext)
599 then (fn <> ".mtl") : slurp (findToken args $ L.drop 4 ext)
600 else let f:fs = slurp (L.drop 3 ext) in (fn <> L.take 3 ext <> f) : fs
601 | otherwise -> let (f:fs) = slurp (L.drop 1 ext)
602 in (fn <> L.take 1 ext <> f) : fs
603 mtllib builder (map L.toStrict $ slurp fnn)
604 parseOBJ builder args bs'
605 _ -> bad bs
606 where
607 bs = findToken args bs0
608 bad bs = case findNewLine [] args bs of
609 (x,bs') -> do badToken builder x
610 parseOBJ builder args bs'
611 next n xs = nextToken (findToken args) $ L.drop n xs
612 parseChar c tok cont = case L.uncons tok of
613 Just (x,cs) | x==c -> cont True $ next 0 cs
614 _ -> cont False tok
615 parseO build n = case findNewLine [] args $ L.drop n bs of
616 (fn,bs') -> do
617 build builder $ sanitizeOBJFilename fn
618 parseOBJ builder args bs'
619 parseUV tok cont = parseChar 'u' tok $ \isU bs' -> do
620 cont (if isU then ParamU else ParamV)
621 (if isU then bs' else L.drop 1 bs')
622 parseV build n = do
623 parseFloats (findToken args) (L.drop n bs) $ \vs bs' -> do
624 build builder vs
625 parseOBJ builder args bs'
626 parseI build n = do
627 parseInts (findToken args) (L.drop n bs) $ \vs bs' -> do
628 build builder vs
629 parseOBJ builder args bs'
630 parseT build n = do
631 parseTriples (findToken args) (L.drop n bs) $ \vs bs' -> do
632 build builder vs
633 parseOBJ builder args bs'
634 parseOffOrNumber tok cont = parseIntsN 1 (findToken args) tok $ \is bs' -> do
635 let (sg,bs'') = case is of
636 (i:_) -> (i,bs')
637 _ | lengthLessThan 2 tok -> (0,tok)
638 _ -> (if L.index tok 1 == 'f' then 0 else 1, next 1 tok)
639 cont sg bs''
640 parseOF build n =
641 let tok = findToken args (next n bs)
642 in if lengthLessThan 2 tok
643 then bad tok
644 else let flag = case L.index tok 1 of
645 'f' -> build builder False -- off
646 _ -> build builder True -- on
647 in parseOBJ builder args (next 2 tok)
648
649
650sanitizeOBJFilename :: L.ByteString -> S.ByteString
651sanitizeOBJFilename fn = case S.breakEnd isSpace $ L.toStrict $ L.dropWhile isSpace fn of
652 (stripped,_) -> case S.breakEnd (=='.') stripped of
653 (basename,ext) | S.null basename -> ext <> ".obj"
654 | otherwise -> stripped
generated by cgit v1.2.3 (git 2.39.1) at 2024-05-20 01:19:35 +0000