From 585889267d535a0e1b777fad58e0467ff2ec7175 Mon Sep 17 00:00:00 2001 From: Joe Crayne Date: Fri, 14 Jun 2019 03:58:34 -0400 Subject: Renamed low-level crayne parser to Wavefront.Lex. --- src/Wavefront.hs | 654 --------------------------------------------------- src/Wavefront/Lex.hs | 654 +++++++++++++++++++++++++++++++++++++++++++++++++++ test/bench.hs | 2 +- wavefront-obj.cabal | 2 +- 4 files changed, 656 insertions(+), 656 deletions(-) delete mode 100644 src/Wavefront.hs create mode 100644 src/Wavefront/Lex.hs diff --git a/src/Wavefront.hs b/src/Wavefront.hs deleted file mode 100644 index c5c8d1b..0000000 --- a/src/Wavefront.hs +++ /dev/null @@ -1,654 +0,0 @@ -{-# LANGUAGE NondecreasingIndentation #-} -{-# LANGUAGE OverloadedStrings #-} -module Wavefront where - -import qualified Data.ByteString.Lazy.Char8 as L -import qualified Data.ByteString.Char8 as S -import Data.ByteString.Internal as BS -import Data.Char -import Data.IntMap (IntMap) -import qualified Data.IntMap as IntMap -import Data.ByteString.Lex.Fractional as F -import Data.ByteString.Lex.Integral as I - -data ObjBuilder m = ObjBuilder - { vertex :: [Double] -> m () - , vertexT :: [Double] -> m () - , vertexN :: [Double] -> m () - , vertexP :: [Double] -> m () - , face :: [RefTriple] -> m () - , cstype :: Bool -> CSType -> m () - , curv2 :: [Int] -> m () - , curv :: Double -> Double -> [Int] -> m () - , parm :: ParamSpec -> [Double] -> m () - , specialPoints :: [Int] -> m () - , endFreeForm :: m () - , ctech :: CurveSamplingSpec -> m () - , stech :: SurfaceSamplingSpec -> m () - , deg :: [Int] -> m () - , surf :: Double -> Double -> Double -> Double -> [RefTriple] -> m () - , trim :: [CurveSpec] -> m () - , hole :: [CurveSpec] -> m () - , specialCurves :: [CurveSpec] -> m () - , equivalentCurves :: [EmbeddedCurve] -> m () - , groups :: [S.ByteString] -> m () - , smoothingGroup :: Int -> m () - , 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 () - , step :: [Int] -> m () - , points :: [Int] -> m () - , usemap :: Maybe S.ByteString -> m () - , maplib :: [S.ByteString] -> m () - , c_interp :: Bool -> m () - , d_interp :: Bool -> m () - , trace_obj :: S.ByteString -> m () - , shadow_obj :: S.ByteString -> m () - , deprecated_res :: [Int] -> m () - , bevel :: Bool -> m () - , lod :: Int -> m () - , call :: S.ByteString -> [S.ByteString] -> m () - , command :: Bool -> L.ByteString -> m L.ByteString - , badToken :: L.ByteString -> m () - } - -nullBuilder :: Applicative m => m () -> ObjBuilder m -nullBuilder def = ObjBuilder - { vertex = \vs -> def - , vertexT = \vs -> def - , vertexN = \vs -> def - , vertexP = \vs -> def - , face = \is -> def - , cstype = \isRat typ -> def - , curv2 = \is -> def - , curv = \u0 v0 is -> def - , parm = \uv is -> def - , specialPoints = \is -> def - , endFreeForm = def - , ctech = \approx -> def - , stech = \approx -> def - , deg = \is -> def - , surf = \u0 u1 v0 v1 ts -> def - , trim = \ss -> def - , hole = \ss -> def - , specialCurves = \ss -> def - , equivalentCurves = \ccs -> def - , groups = \gs -> def - , smoothingGroup = \sg -> def - , mergingGroup = \mg δ -> def - , usemtl = \mtl -> def - , deprecated_cdc = \is -> def - , deprecated_cdp = \is -> def - , deprecated_bzp = \is -> def - , deprecated_bsp = \is -> def - , mtllib = \fns -> def - , objectName = \obn -> def - , bmat = \uv fs -> def - , step = \is -> def - , points = \is -> def - , usemap = \map -> def - , maplib = \fns -> def - , c_interp = \b -> def - , d_interp = \b -> def - , trace_obj = \obj -> def - , shadow_obj = \obj -> def - , deprecated_res = \is -> def - , bevel = \b -> def - , lod = \lvl -> def - , call = \obj args -> def - , command = \b cmd -> def *> pure L.empty - , badToken = \bs -> def - } - - -data CurveSamplingSpec - -- ctech cparm - = UniformSubdivision - { divisionsPerCurveDegree :: Double -- ^ This really ought to be an integer but - -- but examples show floats. The only way - -- it makes sense as a float is if we are to - -- convert to an integer *after* multiplying - -- by the curve degree. - } - -- ctech cspace - | MaxLengthPolygonal { maxPolygonEdgeLength :: Double } - -- ctech curv - | CurvatureBasedPolygon { maxDistanceToCurve :: Double, maximumDegreesPerSample :: Double } - deriving (Eq,Show) - -data SurfaceSamplingSpec - -- stech cparma ures vres - = UniformIsoparametric { uDivisionsPerDegree :: Double, vDivisionsPerDegree :: Double } - -- stech cparmb uvres - | UniformAfterTrimming { uvDivisionsPerDegree :: Double } - -- stech cspace maxlength - | MaxLengthPolytopal { maxPolytopEdgeLength :: Double } - -- stech curv maxdist maxangle - | CurvatureBasedPolytope { maxDistanceToSurface :: Double, maxDegreesPerCorner :: Double } - deriving (Eq,Show) - - -data ObjState = ObjState - { - } - -newtype ObjConfig = ObjConfig - { cfgSubst :: IntMap L.ByteString - } - --- consChunk :: S.ByteString -> L.ByteString -> L.ByteString --- consChunk c bs = L.fromChunks (c : L.toChunks bs) - -reappend :: ByteString -> ByteString -> Maybe ByteString -reappend a b = - let (ap,ao,al) = BS.toForeignPtr a - (bp,bo,bl) = BS.toForeignPtr b - in if ap == bp && ao+al == bo - then Just $ BS.PS ap ao (al+bl) - else Nothing - -reconsChunk :: S.ByteString -> L.ByteString -> L.ByteString -reconsChunk b bs = case L.toChunks bs of - (c:cs) -> case reappend b c of - Just x -> L.fromChunks (x:cs) - Nothing -> L.fromChunks (b:c:cs) - _ -> L.fromChunks [b] - -findToken :: ObjConfig -> L.ByteString -> L.ByteString -findToken (ObjConfig args) bs = case L.dropWhile (\c -> isSpace c || c=='\\') bs of - cs -> case L.uncons cs of - Just ('#',comment) -> findToken (ObjConfig args) $ L.drop 1 $ L.dropWhile (/='\n') comment - Just ('$',ref) -> case L.splitAt 5 ref of - (refp,ds) -> case I.readDecimal (L.toStrict refp) of - Just (i,es) -> case IntMap.lookup i args of - Just val -> val <> reconsChunk es ds - _ -> reconsChunk es ds - _ -> cs - Just _ -> cs - Nothing -> L.empty - -findNewLine :: [L.ByteString] -> ObjConfig -> L.ByteString -> (L.ByteString,L.ByteString) -findNewLine ps o@(ObjConfig args) bs = case L.break (\c -> c=='\n' || c=='\\' || c=='#' || c=='\\') bs of - (ts,cs) -> case L.uncons cs of - Just ('\n',ds) -> (L.concat $ reverse $ ts : ps,ds) - Just ('#',comment) -> findNewLine (ts:ps) o $ L.dropWhile (/='\n') comment - Just ('$',ref) -> case L.splitAt 5 ref of - (refp,ds) -> case I.readDecimal (L.toStrict refp) of - Just (i,es) -> case IntMap.lookup i args of - Just val -> findNewLine (val:ts:ps) o $ reconsChunk es ds - _ -> findNewLine (ts:ps) o $ reconsChunk es ds - _ -> findNewLine ("$":ts:ps) o ref - Just ('\\',ds) -> findNewLine (ts:ps) o $ if L.take 1 ds == "\n" then L.drop 1 ds - else ds - Nothing -> (L.concat $ reverse $ ts : ps,L.empty) - --- The 43 keywords of the OBJ file format: --- --- 1 bevel --- 2 bmat --- 3 bsp --- 4 bzp --- 5 call --- 6 cdc --- 7 cdp --- 8 c_interp --- 9 con --- 10 csh --- 11 cstype --- 12 ctech --- 13 curv2 --- 14 curv --- 15 deg --- 16 d_interp --- 17 end --- 18 f --- 19 g --- 20 hole --- 21 lod --- 22 maplib --- 23 mg --- 24 mtllib --- 25 o --- 26 p --- 27 parm --- 28 res --- 29 s --- 30 scrv --- 31 shadow_obj --- 32 sp --- 33 stech --- 34 step --- 35 surf --- 36 trace_obj --- 37 trim --- 38 usemap --- 39 usemtl --- 40 v --- 41 vn --- 42 vp --- 43 vt - -nextToken :: (L.ByteString -> L.ByteString) -> L.ByteString -> L.ByteString -nextToken tok bs = tok $ L.dropWhile (not . isSpace) bs - -parseFloats tok bs cont = case L.splitAt 10 (tok bs) of - (ds,bs') -> case F.readSigned F.readExponential (L.toStrict ds) of - Just (x,b) -> parseFloats tok (reconsChunk b bs') (cont . (x :)) - Nothing -> cont [] bs - -parseFloatsN 0 _ bs cont = cont [] bs -parseFloatsN n tok bs cont = case L.splitAt 10 (tok bs) of - (ds,bs') -> case F.readSigned F.readExponential (L.toStrict ds) of - Just (x,b) -> parseFloatsN (n-1) tok (reconsChunk b bs') (cont . (x :)) - Nothing -> cont [] bs - -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 [] 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 [] bs - --- Optimize me -parseTriples :: (L.ByteString -> L.ByteString) -> L.ByteString -> ([RefTriple] -> L.ByteString -> b) -> b -parseTriples tok bs cont = case L.splitAt 17 (tok bs) of - (ds,bs') -> case I.readSigned I.readDecimal (L.toStrict ds) of - - Just (v,b) -> case S.splitAt 1 b of - - ("/",ds') -> case I.readSigned I.readDecimal ds' of - - Just (vt,c) -> case S.splitAt 1 c of - ("/",ds'') -> case I.readSigned I.readDecimal ds'' of - Just (vn,d) -> parseTriples tok (reconsChunk d bs') $ cont . (RefTriple v (Just vt) (Just vn) :) - Nothing -> parseTriples tok (reconsChunk ds'' bs') $ cont . (RefTriple v (Just vt) Nothing :) - - _ -> parseTriples tok (reconsChunk c bs') $ cont . (RefTriple v (Just vt) Nothing :) - - Nothing -> case S.splitAt 1 ds' of - ("/",ds'') -> case I.readSigned I.readDecimal ds'' of - Just (vn,d) -> parseTriples tok (reconsChunk d bs') $ cont . (RefTriple v Nothing (Just vn) :) - Nothing -> parseTriples tok (reconsChunk ds'' bs') $ cont . (RefTriple v Nothing Nothing :) - - _ -> parseTriples tok (reconsChunk ds' bs') $ cont . (RefTriple v Nothing Nothing :) - - - _ -> parseTriples tok (reconsChunk b bs') $ cont . (RefTriple v Nothing Nothing :) - - Nothing -> cont [] bs - -parseCurveSpecs :: (L.ByteString -> L.ByteString) -> L.ByteString -> ([CurveSpec] -> L.ByteString -> b) -> b -parseCurveSpecs tok bs cont = parseFloatsN 2 tok bs $ \fs bs' -> case fs of - (u0:u1:_) -> do - parseIntsN 1 tok bs' $ \is bs'' -> case is of - (i:_) -> parseCurveSpecs tok bs'' $ cont . (CurveSpec u0 u1 i :) - _ -> cont [] bs'' - - _ -> cont [] bs' - - -parseCurveSpecsN :: Int -> (L.ByteString -> L.ByteString) -> L.ByteString -> ([CurveSpec] -> L.ByteString -> b) -> b -parseCurveSpecsN 0 tok bs cont = cont [] bs -parseCurveSpecsN n tok bs cont = parseFloatsN 2 tok bs $ \fs bs' -> case fs of - (u0:u1:_) -> do - parseIntsN 1 tok bs' $ \is bs'' -> case is of - (i:_) -> parseCurveSpecsN (n-1) tok bs'' $ cont . (CurveSpec u0 u1 i :) - _ -> cont [] bs'' - - _ -> cont [] bs' - -parseEmbeddedCurves :: (L.ByteString -> L.ByteString) -> L.ByteString -> ([EmbeddedCurve] -> L.ByteString -> b) -> b -parseEmbeddedCurves tok bs cont = parseIntsN 1 tok bs $ \is bs' -> case is of - (sref:_) -> do - parseCurveSpecsN 1 tok bs' $ \cs bs'' -> case cs of - (c:_) -> parseEmbeddedCurves tok bs'' $ cont . (EmbeddedCurve sref c :) - _ -> cont [] bs'' - - _ -> cont [] bs' - -data CSType = Bmatrix | Bezier | Bspline | Cardinal | Taylor - deriving (Eq,Ord,Show,Enum) - -data ParamSpec = ParamU | ParamV - deriving (Eq,Ord,Show,Enum) - -data RefTriple = RefTriple - { refV :: Int - , refT :: Maybe Int - , refN :: Maybe Int - } --- data RefTriple = RefTriple Int (Maybe Int) (Maybe Int) - deriving (Eq,Ord,Show) - -data CurveSpec = CurveSpec - { curveStart :: Double - , curveEnd :: Double - , curveRef :: Int - } - deriving (Eq,Ord,Show) - -data EmbeddedCurve = EmbeddedCurve - { curveSurfaceRef :: Int - , embeddedCurve :: CurveSpec - } - deriving (Eq,Ord,Show) - -lengthLessThan :: Int -> L.ByteString -> Bool -lengthLessThan n bs = - foldr (\c ret ac -> let m = S.length c in if ac <= m then False else ret $! ac - m) - (const True) - (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 () - | isSpace (L.index bs 1) = case L.head bs of - 'f' -> parseT face 2 - 'g' -> case findNewLine [] args $ L.drop 1 bs of -- Newline required to terminate group name list. - (gn,bs') -> do - groups builder (map L.toStrict $ L.words gn) - parseOBJ builder args bs' - 's' -> case next 1 bs of - tok -> parseOffOrNumber tok $ \sg bs' -> do - smoothingGroup builder sg - parseOBJ builder args bs' - 'v' -> parseV vertex 2 - 'o' -> -- o object-name - case findNewLine [] args $ L.drop 1 bs of - (objn,bs') -> do - objectName builder (L.toStrict objn) - parseOBJ builder args bs' - 'p' -> parseI points 2 - _ -> bad bs - | otherwise = case L.take 2 bs of - "vt" -> parseV vertexT 3 - "vn" -> parseV vertexN 3 - "vp" -> parseV vertexP 3 - "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'' - - "bs" -> parseI deprecated_bsp 4 -- bsp - "bz" -> parseI deprecated_bzp 4 -- bzp - "ca" -> -- call - case findNewLine [] args $ next 2 bs of - (fnn,bs') -> do - let slurp fnn = case L.break (=='.') fnn of - (fn,ext) | L.null (L.drop 1 ext) -> if L.null fn then [] - else [fn] - | ".obj" <- L.take 4 ext -> - if L.all isSpace (L.take 1 $ L.drop 4 ext) - then (fn <> ".obj") : slurpArgs (findToken args $ L.drop 4 ext) - else let f:fs = slurp (L.drop 3 ext) in (fn <> L.take 3 ext <> f) : fs - | otherwise -> let (f:fs) = slurp (L.drop 1 ext) - in (fn <> L.take 1 ext <> f) : fs - slurpArgs fnn | L.null fnn = [] - slurpArgs fnn = case L.break isSpace fnn of - (a,as) -> findToken args a : slurpArgs as - case map L.toStrict $ slurpArgs fnn of - [] -> return () - fn:as -> call builder fn as - parseOBJ builder args bs' - - "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 - parseOBJ builder args bs' - "cs" -> if lengthLessThan 3 bs - then bad bs - else case L.index bs 2 of - 'h' -> -- csh - let (dash,tok) = L.splitAt 1 $ next 3 bs - wantsErrorCheck = dash /= "-" - in case findNewLine [] args tok of - (cmd,bs') -> do result <- command builder wantsErrorCheck cmd - parseOBJ builder args $ result <> bs' - _ -> -- cstype - let parseRat = parseChar 'r' - parseTyp tok cont | lengthLessThan 3 tok = bad tok - | otherwise = case L.index tok 2 of - 'a' -> cont Bmatrix $ next 3 tok - 'z' -> cont Bezier $ next 3 tok - 'p' -> cont Bspline $ next 3 tok - 'r' -> cont Cardinal $ next 3 tok - 'y' -> cont Taylor $ next 3 tok - _ -> bad tok - in parseRat (next 2 bs) $ \isRat bs' -> do - parseTyp bs' $ \typ bs'' -> do - cstype builder isRat typ - parseOBJ builder args bs'' - "ct" -> -- ctech - let tok = next 2 bs - in if lengthLessThan 2 tok - then bad tok - else case L.index tok 1 of - 'p' -> -- cparm - parseFloats (findToken args) (next 2 tok) $ \is bs' -> do - let x:_ = is ++ [0] - ctech builder (UniformSubdivision x) - parseOBJ builder args bs' - 's' -> -- cspace - parseFloats (findToken args) (next 2 tok) $ \fs bs' -> do - let x:_ = fs ++ [1.0] - ctech builder (MaxLengthPolygonal x) - parseOBJ builder args bs' - 'u' -> -- curv - parseFloats (findToken args) (next 2 tok) $ \fs bs' -> do - let δ:θ:_ = fs ++ repeat 1.0 - ctech builder (CurvatureBasedPolygon δ θ) - parseOBJ builder args bs' - _ -> bad tok - "cu" -> if lengthLessThan 5 bs - then bad bs - else if L.index bs 4 == '2' - then parseI curv2 5 -- curv2 - else do -- curv - parseFloatsN 2 (findToken args) (L.drop 4 bs) $ \vs bs' -> - parseInts (findToken args) bs' $ \is bs'' -> do - let u0:v0:_ = vs ++ repeat 0.0 - curv builder u0 v0 is - parseOBJ builder args bs'' - "c_" -> -- c_interp - parseOF c_interp 2 - "de" -> parseI deg 3 - "d_" -> -- d_interp - 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 - parseOBJ builder args bs' - "mg" -> case next 2 bs of - tok -> parseOffOrNumber tok $ \mg bs' -> do - parseFloatsN 1 (findToken args) bs' $ \fs bs'' -> do - mergingGroup builder mg (head $ fs ++ [0]) - parseOBJ builder args bs'' - "pa" -> parseUV (next 2 bs) $ \uv bs' -> do - 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 - parseOBJ builder args bs' - "sh" -> -- shadow_obj - parseO shadow_obj 10 - "sp" -> parseI specialPoints 3 - "st" -> -- stech or step - if lengthLessThan 4 bs then bad bs - else case L.index bs 3 of - 'c' -> - -- stech - let tok = next 2 bs - in if lengthLessThan 2 tok - then bad tok - else case L.index tok 1 of - 'p' -> -- cparma/cparmb - if lengthLessThan 6 tok - then bad tok - else if L.index tok 5 == 'b' - then -- cparmb - parseFloats (findToken args) (next 5 tok) $ \is bs' -> do - let x:_ = is ++ [0] - stech builder (UniformAfterTrimming x) - parseOBJ builder args bs' - else -- cparma - parseFloats (findToken args) (next 5 tok) $ \is bs' -> do - let x:y:_ = is ++ [0] - stech builder (UniformIsoparametric x y) - parseOBJ builder args bs' - 's' -> -- cspace - parseFloats (findToken args) (next 2 tok) $ \fs bs' -> do - let x:_ = fs ++ [1.0] - stech builder (MaxLengthPolytopal x) - parseOBJ builder args bs' - 'u' -> -- curv - parseFloats (findToken args) (next 2 tok) $ \fs bs' -> do - let δ:θ:_ = fs ++ repeat 1.0 - stech builder (CurvatureBasedPolytope δ θ) - parseOBJ builder args bs' - _ -> bad tok - - _ -> -- step - parseI step 4 - - "su" -> -- surf - parseFloatsN 4 (findToken args) (next 2 bs) $ \fs bs' -> do - parseTriples (findToken args) bs' $ \ts bs'' -> do - let u0:u1:v0:v1:_ = fs ++ repeat 0 - surf builder u0 u1 v0 v1 ts - parseOBJ builder args bs'' - "tr" -> -- trip or trace_obj - if lengthLessThan 3 bs - then bad bs - else case L.index bs 2 of - 'a' -> -- trace_obj - parseO trace_obj 9 - _ -> -- trim - parseCurveSpecs (findToken args) (next 2 bs) $ \ss bs' -> do - trim builder ss - 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' - "ma" -> -- maplib - case findNewLine [] args $ next 2 bs of - (fnn,bs') -> do - let slurp fnn = case L.break (=='.') fnn of - (fn,ext) | L.null (L.drop 1 ext) -> if L.null fn then [] - else [fn] - | ext <- L.take 4 ext - -- XXX What is the map library extension? - , ext `elem` [".map",".mtl",".obj"] -> - if L.all isSpace (L.take 1 $ L.drop 4 ext) - then (fn <> ext) : slurp (findToken args $ L.drop 4 ext) - else let f:fs = slurp (L.drop 3 ext) in (fn <> L.take 3 ext <> f) : fs - | otherwise -> let (f:fs) = slurp (L.drop 1 ext) - in (fn <> L.take 1 ext <> f) : fs - maplib builder (map L.toStrict $ slurp fnn) - parseOBJ builder args bs' - "mt" -> -- mtllib - case findNewLine [] args $ next 2 bs of - (fnn,bs') -> do - let slurp fnn = case L.break (=='.') fnn of - (fn,ext) | L.null (L.drop 1 ext) -> if L.null fn then [] - else [fn] - | ".mtl" <- L.take 4 ext -> - if L.all isSpace (L.take 1 $ L.drop 4 ext) - then (fn <> ".mtl") : slurp (findToken args $ L.drop 4 ext) - else let f:fs = slurp (L.drop 3 ext) in (fn <> L.take 3 ext <> f) : fs - | otherwise -> let (f:fs) = slurp (L.drop 1 ext) - in (fn <> L.take 1 ext <> f) : fs - mtllib builder (map L.toStrict $ slurp fnn) - parseOBJ builder args bs' - _ -> bad bs - where - bs = findToken args bs0 - bad bs = case findNewLine [] args bs of - (x,bs') -> do badToken builder x - parseOBJ builder args bs' - next n xs = nextToken (findToken args) $ L.drop n xs - parseChar c tok cont = case L.uncons tok of - Just (x,cs) | x==c -> cont True $ next 0 cs - _ -> cont False tok - parseO build n = case findNewLine [] args $ L.drop n bs of - (fn,bs') -> do - build builder $ sanitizeOBJFilename fn - parseOBJ builder args bs' - 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 - parseOBJ builder args bs' - parseI build n = do - parseInts (findToken args) (L.drop n bs) $ \vs bs' -> do - build builder vs - parseOBJ builder args bs' - parseT build n = do - parseTriples (findToken args) (L.drop n bs) $ \vs bs' -> do - build builder vs - parseOBJ builder args bs' - parseOffOrNumber tok cont = parseIntsN 1 (findToken args) tok $ \is bs' -> do - let (sg,bs'') = case is of - (i:_) -> (i,bs') - _ | 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 - (stripped,_) -> case S.breakEnd (=='.') stripped of - (basename,ext) | S.null basename -> ext <> ".obj" - | otherwise -> stripped 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 @@ +{-# LANGUAGE NondecreasingIndentation #-} +{-# LANGUAGE OverloadedStrings #-} +module Wavefront.Lex where + +import qualified Data.ByteString.Lazy.Char8 as L +import qualified Data.ByteString.Char8 as S +import Data.ByteString.Internal as BS +import Data.Char +import Data.IntMap (IntMap) +import qualified Data.IntMap as IntMap +import Data.ByteString.Lex.Fractional as F +import Data.ByteString.Lex.Integral as I + +data ObjBuilder m = ObjBuilder + { vertex :: [Double] -> m () + , vertexT :: [Double] -> m () + , vertexN :: [Double] -> m () + , vertexP :: [Double] -> m () + , face :: [RefTriple] -> m () + , cstype :: Bool -> CSType -> m () + , curv2 :: [Int] -> m () + , curv :: Double -> Double -> [Int] -> m () + , parm :: ParamSpec -> [Double] -> m () + , specialPoints :: [Int] -> m () + , endFreeForm :: m () + , ctech :: CurveSamplingSpec -> m () + , stech :: SurfaceSamplingSpec -> m () + , deg :: [Int] -> m () + , surf :: Double -> Double -> Double -> Double -> [RefTriple] -> m () + , trim :: [CurveSpec] -> m () + , hole :: [CurveSpec] -> m () + , specialCurves :: [CurveSpec] -> m () + , equivalentCurves :: [EmbeddedCurve] -> m () + , groups :: [S.ByteString] -> m () + , smoothingGroup :: Int -> m () + , 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 () + , step :: [Int] -> m () + , points :: [Int] -> m () + , usemap :: Maybe S.ByteString -> m () + , maplib :: [S.ByteString] -> m () + , c_interp :: Bool -> m () + , d_interp :: Bool -> m () + , trace_obj :: S.ByteString -> m () + , shadow_obj :: S.ByteString -> m () + , deprecated_res :: [Int] -> m () + , bevel :: Bool -> m () + , lod :: Int -> m () + , call :: S.ByteString -> [S.ByteString] -> m () + , command :: Bool -> L.ByteString -> m L.ByteString + , badToken :: L.ByteString -> m () + } + +nullBuilder :: Applicative m => m () -> ObjBuilder m +nullBuilder def = ObjBuilder + { vertex = \vs -> def + , vertexT = \vs -> def + , vertexN = \vs -> def + , vertexP = \vs -> def + , face = \is -> def + , cstype = \isRat typ -> def + , curv2 = \is -> def + , curv = \u0 v0 is -> def + , parm = \uv is -> def + , specialPoints = \is -> def + , endFreeForm = def + , ctech = \approx -> def + , stech = \approx -> def + , deg = \is -> def + , surf = \u0 u1 v0 v1 ts -> def + , trim = \ss -> def + , hole = \ss -> def + , specialCurves = \ss -> def + , equivalentCurves = \ccs -> def + , groups = \gs -> def + , smoothingGroup = \sg -> def + , mergingGroup = \mg δ -> def + , usemtl = \mtl -> def + , deprecated_cdc = \is -> def + , deprecated_cdp = \is -> def + , deprecated_bzp = \is -> def + , deprecated_bsp = \is -> def + , mtllib = \fns -> def + , objectName = \obn -> def + , bmat = \uv fs -> def + , step = \is -> def + , points = \is -> def + , usemap = \map -> def + , maplib = \fns -> def + , c_interp = \b -> def + , d_interp = \b -> def + , trace_obj = \obj -> def + , shadow_obj = \obj -> def + , deprecated_res = \is -> def + , bevel = \b -> def + , lod = \lvl -> def + , call = \obj args -> def + , command = \b cmd -> def *> pure L.empty + , badToken = \bs -> def + } + + +data CurveSamplingSpec + -- ctech cparm + = UniformSubdivision + { divisionsPerCurveDegree :: Double -- ^ This really ought to be an integer but + -- but examples show floats. The only way + -- it makes sense as a float is if we are to + -- convert to an integer *after* multiplying + -- by the curve degree. + } + -- ctech cspace + | MaxLengthPolygonal { maxPolygonEdgeLength :: Double } + -- ctech curv + | CurvatureBasedPolygon { maxDistanceToCurve :: Double, maximumDegreesPerSample :: Double } + deriving (Eq,Show) + +data SurfaceSamplingSpec + -- stech cparma ures vres + = UniformIsoparametric { uDivisionsPerDegree :: Double, vDivisionsPerDegree :: Double } + -- stech cparmb uvres + | UniformAfterTrimming { uvDivisionsPerDegree :: Double } + -- stech cspace maxlength + | MaxLengthPolytopal { maxPolytopEdgeLength :: Double } + -- stech curv maxdist maxangle + | CurvatureBasedPolytope { maxDistanceToSurface :: Double, maxDegreesPerCorner :: Double } + deriving (Eq,Show) + + +data ObjState = ObjState + { + } + +newtype ObjConfig = ObjConfig + { cfgSubst :: IntMap L.ByteString + } + +-- consChunk :: S.ByteString -> L.ByteString -> L.ByteString +-- consChunk c bs = L.fromChunks (c : L.toChunks bs) + +reappend :: ByteString -> ByteString -> Maybe ByteString +reappend a b = + let (ap,ao,al) = BS.toForeignPtr a + (bp,bo,bl) = BS.toForeignPtr b + in if ap == bp && ao+al == bo + then Just $ BS.PS ap ao (al+bl) + else Nothing + +reconsChunk :: S.ByteString -> L.ByteString -> L.ByteString +reconsChunk b bs = case L.toChunks bs of + (c:cs) -> case reappend b c of + Just x -> L.fromChunks (x:cs) + Nothing -> L.fromChunks (b:c:cs) + _ -> L.fromChunks [b] + +findToken :: ObjConfig -> L.ByteString -> L.ByteString +findToken (ObjConfig args) bs = case L.dropWhile (\c -> isSpace c || c=='\\') bs of + cs -> case L.uncons cs of + Just ('#',comment) -> findToken (ObjConfig args) $ L.drop 1 $ L.dropWhile (/='\n') comment + Just ('$',ref) -> case L.splitAt 5 ref of + (refp,ds) -> case I.readDecimal (L.toStrict refp) of + Just (i,es) -> case IntMap.lookup i args of + Just val -> val <> reconsChunk es ds + _ -> reconsChunk es ds + _ -> cs + Just _ -> cs + Nothing -> L.empty + +findNewLine :: [L.ByteString] -> ObjConfig -> L.ByteString -> (L.ByteString,L.ByteString) +findNewLine ps o@(ObjConfig args) bs = case L.break (\c -> c=='\n' || c=='\\' || c=='#' || c=='\\') bs of + (ts,cs) -> case L.uncons cs of + Just ('\n',ds) -> (L.concat $ reverse $ ts : ps,ds) + Just ('#',comment) -> findNewLine (ts:ps) o $ L.dropWhile (/='\n') comment + Just ('$',ref) -> case L.splitAt 5 ref of + (refp,ds) -> case I.readDecimal (L.toStrict refp) of + Just (i,es) -> case IntMap.lookup i args of + Just val -> findNewLine (val:ts:ps) o $ reconsChunk es ds + _ -> findNewLine (ts:ps) o $ reconsChunk es ds + _ -> findNewLine ("$":ts:ps) o ref + Just ('\\',ds) -> findNewLine (ts:ps) o $ if L.take 1 ds == "\n" then L.drop 1 ds + else ds + Nothing -> (L.concat $ reverse $ ts : ps,L.empty) + +-- The 43 keywords of the OBJ file format: +-- +-- 1 bevel +-- 2 bmat +-- 3 bsp +-- 4 bzp +-- 5 call +-- 6 cdc +-- 7 cdp +-- 8 c_interp +-- 9 con +-- 10 csh +-- 11 cstype +-- 12 ctech +-- 13 curv2 +-- 14 curv +-- 15 deg +-- 16 d_interp +-- 17 end +-- 18 f +-- 19 g +-- 20 hole +-- 21 lod +-- 22 maplib +-- 23 mg +-- 24 mtllib +-- 25 o +-- 26 p +-- 27 parm +-- 28 res +-- 29 s +-- 30 scrv +-- 31 shadow_obj +-- 32 sp +-- 33 stech +-- 34 step +-- 35 surf +-- 36 trace_obj +-- 37 trim +-- 38 usemap +-- 39 usemtl +-- 40 v +-- 41 vn +-- 42 vp +-- 43 vt + +nextToken :: (L.ByteString -> L.ByteString) -> L.ByteString -> L.ByteString +nextToken tok bs = tok $ L.dropWhile (not . isSpace) bs + +parseFloats tok bs cont = case L.splitAt 10 (tok bs) of + (ds,bs') -> case F.readSigned F.readExponential (L.toStrict ds) of + Just (x,b) -> parseFloats tok (reconsChunk b bs') (cont . (x :)) + Nothing -> cont [] bs + +parseFloatsN 0 _ bs cont = cont [] bs +parseFloatsN n tok bs cont = case L.splitAt 10 (tok bs) of + (ds,bs') -> case F.readSigned F.readExponential (L.toStrict ds) of + Just (x,b) -> parseFloatsN (n-1) tok (reconsChunk b bs') (cont . (x :)) + Nothing -> cont [] bs + +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 [] 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 [] bs + +-- Optimize me +parseTriples :: (L.ByteString -> L.ByteString) -> L.ByteString -> ([RefTriple] -> L.ByteString -> b) -> b +parseTriples tok bs cont = case L.splitAt 17 (tok bs) of + (ds,bs') -> case I.readSigned I.readDecimal (L.toStrict ds) of + + Just (v,b) -> case S.splitAt 1 b of + + ("/",ds') -> case I.readSigned I.readDecimal ds' of + + Just (vt,c) -> case S.splitAt 1 c of + ("/",ds'') -> case I.readSigned I.readDecimal ds'' of + Just (vn,d) -> parseTriples tok (reconsChunk d bs') $ cont . (RefTriple v (Just vt) (Just vn) :) + Nothing -> parseTriples tok (reconsChunk ds'' bs') $ cont . (RefTriple v (Just vt) Nothing :) + + _ -> parseTriples tok (reconsChunk c bs') $ cont . (RefTriple v (Just vt) Nothing :) + + Nothing -> case S.splitAt 1 ds' of + ("/",ds'') -> case I.readSigned I.readDecimal ds'' of + Just (vn,d) -> parseTriples tok (reconsChunk d bs') $ cont . (RefTriple v Nothing (Just vn) :) + Nothing -> parseTriples tok (reconsChunk ds'' bs') $ cont . (RefTriple v Nothing Nothing :) + + _ -> parseTriples tok (reconsChunk ds' bs') $ cont . (RefTriple v Nothing Nothing :) + + + _ -> parseTriples tok (reconsChunk b bs') $ cont . (RefTriple v Nothing Nothing :) + + Nothing -> cont [] bs + +parseCurveSpecs :: (L.ByteString -> L.ByteString) -> L.ByteString -> ([CurveSpec] -> L.ByteString -> b) -> b +parseCurveSpecs tok bs cont = parseFloatsN 2 tok bs $ \fs bs' -> case fs of + (u0:u1:_) -> do + parseIntsN 1 tok bs' $ \is bs'' -> case is of + (i:_) -> parseCurveSpecs tok bs'' $ cont . (CurveSpec u0 u1 i :) + _ -> cont [] bs'' + + _ -> cont [] bs' + + +parseCurveSpecsN :: Int -> (L.ByteString -> L.ByteString) -> L.ByteString -> ([CurveSpec] -> L.ByteString -> b) -> b +parseCurveSpecsN 0 tok bs cont = cont [] bs +parseCurveSpecsN n tok bs cont = parseFloatsN 2 tok bs $ \fs bs' -> case fs of + (u0:u1:_) -> do + parseIntsN 1 tok bs' $ \is bs'' -> case is of + (i:_) -> parseCurveSpecsN (n-1) tok bs'' $ cont . (CurveSpec u0 u1 i :) + _ -> cont [] bs'' + + _ -> cont [] bs' + +parseEmbeddedCurves :: (L.ByteString -> L.ByteString) -> L.ByteString -> ([EmbeddedCurve] -> L.ByteString -> b) -> b +parseEmbeddedCurves tok bs cont = parseIntsN 1 tok bs $ \is bs' -> case is of + (sref:_) -> do + parseCurveSpecsN 1 tok bs' $ \cs bs'' -> case cs of + (c:_) -> parseEmbeddedCurves tok bs'' $ cont . (EmbeddedCurve sref c :) + _ -> cont [] bs'' + + _ -> cont [] bs' + +data CSType = Bmatrix | Bezier | Bspline | Cardinal | Taylor + deriving (Eq,Ord,Show,Enum) + +data ParamSpec = ParamU | ParamV + deriving (Eq,Ord,Show,Enum) + +data RefTriple = RefTriple + { refV :: Int + , refT :: Maybe Int + , refN :: Maybe Int + } +-- data RefTriple = RefTriple Int (Maybe Int) (Maybe Int) + deriving (Eq,Ord,Show) + +data CurveSpec = CurveSpec + { curveStart :: Double + , curveEnd :: Double + , curveRef :: Int + } + deriving (Eq,Ord,Show) + +data EmbeddedCurve = EmbeddedCurve + { curveSurfaceRef :: Int + , embeddedCurve :: CurveSpec + } + deriving (Eq,Ord,Show) + +lengthLessThan :: Int -> L.ByteString -> Bool +lengthLessThan n bs = + foldr (\c ret ac -> let m = S.length c in if ac <= m then False else ret $! ac - m) + (const True) + (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 () + | isSpace (L.index bs 1) = case L.head bs of + 'f' -> parseT face 2 + 'g' -> case findNewLine [] args $ L.drop 1 bs of -- Newline required to terminate group name list. + (gn,bs') -> do + groups builder (map L.toStrict $ L.words gn) + parseOBJ builder args bs' + 's' -> case next 1 bs of + tok -> parseOffOrNumber tok $ \sg bs' -> do + smoothingGroup builder sg + parseOBJ builder args bs' + 'v' -> parseV vertex 2 + 'o' -> -- o object-name + case findNewLine [] args $ L.drop 1 bs of + (objn,bs') -> do + objectName builder (L.toStrict objn) + parseOBJ builder args bs' + 'p' -> parseI points 2 + _ -> bad bs + | otherwise = case L.take 2 bs of + "vt" -> parseV vertexT 3 + "vn" -> parseV vertexN 3 + "vp" -> parseV vertexP 3 + "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'' + + "bs" -> parseI deprecated_bsp 4 -- bsp + "bz" -> parseI deprecated_bzp 4 -- bzp + "ca" -> -- call + case findNewLine [] args $ next 2 bs of + (fnn,bs') -> do + let slurp fnn = case L.break (=='.') fnn of + (fn,ext) | L.null (L.drop 1 ext) -> if L.null fn then [] + else [fn] + | ".obj" <- L.take 4 ext -> + if L.all isSpace (L.take 1 $ L.drop 4 ext) + then (fn <> ".obj") : slurpArgs (findToken args $ L.drop 4 ext) + else let f:fs = slurp (L.drop 3 ext) in (fn <> L.take 3 ext <> f) : fs + | otherwise -> let (f:fs) = slurp (L.drop 1 ext) + in (fn <> L.take 1 ext <> f) : fs + slurpArgs fnn | L.null fnn = [] + slurpArgs fnn = case L.break isSpace fnn of + (a,as) -> findToken args a : slurpArgs as + case map L.toStrict $ slurpArgs fnn of + [] -> return () + fn:as -> call builder fn as + parseOBJ builder args bs' + + "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 + parseOBJ builder args bs' + "cs" -> if lengthLessThan 3 bs + then bad bs + else case L.index bs 2 of + 'h' -> -- csh + let (dash,tok) = L.splitAt 1 $ next 3 bs + wantsErrorCheck = dash /= "-" + in case findNewLine [] args tok of + (cmd,bs') -> do result <- command builder wantsErrorCheck cmd + parseOBJ builder args $ result <> bs' + _ -> -- cstype + let parseRat = parseChar 'r' + parseTyp tok cont | lengthLessThan 3 tok = bad tok + | otherwise = case L.index tok 2 of + 'a' -> cont Bmatrix $ next 3 tok + 'z' -> cont Bezier $ next 3 tok + 'p' -> cont Bspline $ next 3 tok + 'r' -> cont Cardinal $ next 3 tok + 'y' -> cont Taylor $ next 3 tok + _ -> bad tok + in parseRat (next 2 bs) $ \isRat bs' -> do + parseTyp bs' $ \typ bs'' -> do + cstype builder isRat typ + parseOBJ builder args bs'' + "ct" -> -- ctech + let tok = next 2 bs + in if lengthLessThan 2 tok + then bad tok + else case L.index tok 1 of + 'p' -> -- cparm + parseFloats (findToken args) (next 2 tok) $ \is bs' -> do + let x:_ = is ++ [0] + ctech builder (UniformSubdivision x) + parseOBJ builder args bs' + 's' -> -- cspace + parseFloats (findToken args) (next 2 tok) $ \fs bs' -> do + let x:_ = fs ++ [1.0] + ctech builder (MaxLengthPolygonal x) + parseOBJ builder args bs' + 'u' -> -- curv + parseFloats (findToken args) (next 2 tok) $ \fs bs' -> do + let δ:θ:_ = fs ++ repeat 1.0 + ctech builder (CurvatureBasedPolygon δ θ) + parseOBJ builder args bs' + _ -> bad tok + "cu" -> if lengthLessThan 5 bs + then bad bs + else if L.index bs 4 == '2' + then parseI curv2 5 -- curv2 + else do -- curv + parseFloatsN 2 (findToken args) (L.drop 4 bs) $ \vs bs' -> + parseInts (findToken args) bs' $ \is bs'' -> do + let u0:v0:_ = vs ++ repeat 0.0 + curv builder u0 v0 is + parseOBJ builder args bs'' + "c_" -> -- c_interp + parseOF c_interp 2 + "de" -> parseI deg 3 + "d_" -> -- d_interp + 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 + parseOBJ builder args bs' + "mg" -> case next 2 bs of + tok -> parseOffOrNumber tok $ \mg bs' -> do + parseFloatsN 1 (findToken args) bs' $ \fs bs'' -> do + mergingGroup builder mg (head $ fs ++ [0]) + parseOBJ builder args bs'' + "pa" -> parseUV (next 2 bs) $ \uv bs' -> do + 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 + parseOBJ builder args bs' + "sh" -> -- shadow_obj + parseO shadow_obj 10 + "sp" -> parseI specialPoints 3 + "st" -> -- stech or step + if lengthLessThan 4 bs then bad bs + else case L.index bs 3 of + 'c' -> + -- stech + let tok = next 2 bs + in if lengthLessThan 2 tok + then bad tok + else case L.index tok 1 of + 'p' -> -- cparma/cparmb + if lengthLessThan 6 tok + then bad tok + else if L.index tok 5 == 'b' + then -- cparmb + parseFloats (findToken args) (next 5 tok) $ \is bs' -> do + let x:_ = is ++ [0] + stech builder (UniformAfterTrimming x) + parseOBJ builder args bs' + else -- cparma + parseFloats (findToken args) (next 5 tok) $ \is bs' -> do + let x:y:_ = is ++ [0] + stech builder (UniformIsoparametric x y) + parseOBJ builder args bs' + 's' -> -- cspace + parseFloats (findToken args) (next 2 tok) $ \fs bs' -> do + let x:_ = fs ++ [1.0] + stech builder (MaxLengthPolytopal x) + parseOBJ builder args bs' + 'u' -> -- curv + parseFloats (findToken args) (next 2 tok) $ \fs bs' -> do + let δ:θ:_ = fs ++ repeat 1.0 + stech builder (CurvatureBasedPolytope δ θ) + parseOBJ builder args bs' + _ -> bad tok + + _ -> -- step + parseI step 4 + + "su" -> -- surf + parseFloatsN 4 (findToken args) (next 2 bs) $ \fs bs' -> do + parseTriples (findToken args) bs' $ \ts bs'' -> do + let u0:u1:v0:v1:_ = fs ++ repeat 0 + surf builder u0 u1 v0 v1 ts + parseOBJ builder args bs'' + "tr" -> -- trip or trace_obj + if lengthLessThan 3 bs + then bad bs + else case L.index bs 2 of + 'a' -> -- trace_obj + parseO trace_obj 9 + _ -> -- trim + parseCurveSpecs (findToken args) (next 2 bs) $ \ss bs' -> do + trim builder ss + 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' + "ma" -> -- maplib + case findNewLine [] args $ next 2 bs of + (fnn,bs') -> do + let slurp fnn = case L.break (=='.') fnn of + (fn,ext) | L.null (L.drop 1 ext) -> if L.null fn then [] + else [fn] + | ext <- L.take 4 ext + -- XXX What is the map library extension? + , ext `elem` [".map",".mtl",".obj"] -> + if L.all isSpace (L.take 1 $ L.drop 4 ext) + then (fn <> ext) : slurp (findToken args $ L.drop 4 ext) + else let f:fs = slurp (L.drop 3 ext) in (fn <> L.take 3 ext <> f) : fs + | otherwise -> let (f:fs) = slurp (L.drop 1 ext) + in (fn <> L.take 1 ext <> f) : fs + maplib builder (map L.toStrict $ slurp fnn) + parseOBJ builder args bs' + "mt" -> -- mtllib + case findNewLine [] args $ next 2 bs of + (fnn,bs') -> do + let slurp fnn = case L.break (=='.') fnn of + (fn,ext) | L.null (L.drop 1 ext) -> if L.null fn then [] + else [fn] + | ".mtl" <- L.take 4 ext -> + if L.all isSpace (L.take 1 $ L.drop 4 ext) + then (fn <> ".mtl") : slurp (findToken args $ L.drop 4 ext) + else let f:fs = slurp (L.drop 3 ext) in (fn <> L.take 3 ext <> f) : fs + | otherwise -> let (f:fs) = slurp (L.drop 1 ext) + in (fn <> L.take 1 ext <> f) : fs + mtllib builder (map L.toStrict $ slurp fnn) + parseOBJ builder args bs' + _ -> bad bs + where + bs = findToken args bs0 + bad bs = case findNewLine [] args bs of + (x,bs') -> do badToken builder x + parseOBJ builder args bs' + next n xs = nextToken (findToken args) $ L.drop n xs + parseChar c tok cont = case L.uncons tok of + Just (x,cs) | x==c -> cont True $ next 0 cs + _ -> cont False tok + parseO build n = case findNewLine [] args $ L.drop n bs of + (fn,bs') -> do + build builder $ sanitizeOBJFilename fn + parseOBJ builder args bs' + 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 + parseOBJ builder args bs' + parseI build n = do + parseInts (findToken args) (L.drop n bs) $ \vs bs' -> do + build builder vs + parseOBJ builder args bs' + parseT build n = do + parseTriples (findToken args) (L.drop n bs) $ \vs bs' -> do + build builder vs + parseOBJ builder args bs' + parseOffOrNumber tok cont = parseIntsN 1 (findToken args) tok $ \is bs' -> do + let (sg,bs'') = case is of + (i:_) -> (i,bs') + _ | 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 + (stripped,_) -> case S.breakEnd (=='.') stripped of + (basename,ext) | S.null basename -> ext <> ".obj" + | otherwise -> stripped diff --git a/test/bench.hs b/test/bench.hs index bf60303..3c4cf1e 100644 --- a/test/bench.hs +++ b/test/bench.hs @@ -22,7 +22,7 @@ import Codec.Wavefront.Token ( tokenize ) import qualified Graphics.WaveFront.Parse as Parse import qualified Graphics.WaveFront.Parse.Common as Parse -import Wavefront +import Wavefront.Lex import Criterion.Main #ifdef WEIGH diff --git a/wavefront-obj.cabal b/wavefront-obj.cabal index a1087df..b5cd8df 100644 --- a/wavefront-obj.cabal +++ b/wavefront-obj.cabal @@ -48,7 +48,7 @@ library , Codec.Wavefront.Face , Codec.Wavefront.FreeForm , Codec.Wavefront.Token - , Wavefront + , Wavefront.Lex -- other-modules: other-extensions: ForeignFunctionInterface , UnicodeSyntax -- cgit v1.2.3