{-# 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_bzp :: [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 () , badToken :: L.ByteString -> m () } nullBuilder :: Applicative m => ObjBuilder m nullBuilder = ObjBuilder { vertex = \vs -> pure () , vertexT = \vs -> pure () , vertexN = \vs -> pure () , vertexP = \vs -> pure () , face = \is -> pure () , cstype = \isRat typ -> pure () , curv2 = \is -> pure () , curv = \u0 v0 is -> pure () , parm = \uv is -> pure () , specialPoints = \is -> pure () , endFreeForm = pure () , ctech = \approx -> pure () , stech = \approx -> pure () , deg = \is -> pure () , surf = \u0 u1 v0 v1 ts -> pure () , trim = \ss -> pure () , hole = \ss -> pure () , specialCurves = \ss -> pure () , equivalentCurves = \ccs -> pure () , groups = \gs -> pure () , smoothingGroup = \sg -> pure () , mergingGroup = \mg δ -> pure () , usemtl = \mtl -> pure () , deprecated_cdc = \is -> pure () , deprecated_bzp = \is -> pure () , mtllib = \fns -> pure () , objectName = \obn -> pure () , bmat = \uv fs -> pure () , step = \is -> pure () , points = \is -> pure () , usemap = \map -> pure () , maplib = \fns -> pure () , c_interp = \b -> pure () , d_interp = \b -> pure () , badToken = \bs -> pure () } 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) {- 1 x bevel 2 bmat 3 x bsp 4 bzp 5 x call 6 cdc 7 x cdp 8 c_interp 9 con 10 x csh -- for all except these, 11 cstype -- Two chars suffice to distinguish 12 ctech 13 curv2 -- for all except these, 14 curv -- Two chars suffice to distinguish 15 deg 16 d_interp 17 end 18 f 19 g 20 hole 21 x lod 22 maplib 23 mg 24 mtllib 25 o 26 p 27 parm 28 x res 29 s 30 scrv 31 x shadow_obj 32 sp 33 stech -- for all except these, 34 step -- Two chars suffice to distinguish 35 surf 36 x trace_obj -- for all except these, 37 trim -- Two chars suffice to distinguish 38 usemap -- for all except these, 39 usemtl -- Two chars suffice to distinguish 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 "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 equivalentCurves builder ss parseOBJ builder args bs' "cs" -> -- 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 let tok = findToken args (next 2 bs) in if lengthLessThan 2 tok then bad tok else let flag = case L.index tok 1 of 'f' -> c_interp builder False -- off _ -> c_interp builder True -- on in parseOBJ builder args (next 2 tok) "de" -> parseI deg 3 "d_" -> -- d_interp let tok = findToken args (next 2 bs) in if lengthLessThan 2 tok then bad tok else let flag = case L.index tok 1 of 'f' -> d_interp builder False -- off _ -> d_interp builder True -- on in parseOBJ builder args (next 2 tok) "en" -> do endFreeForm builder parseOBJ builder args (next 2 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'' "sc" -> -- scrv parseCurveSpecs (findToken args) (next 2 bs) $ \ss bs' -> do specialCurves builder ss parseOBJ builder args bs' "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" -> -- 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' -- TODO: call,csh,lod,shadow_obj,trace_obj,bevel _ -> bad bs where bs = findToken args bs0 bad bs = case L.break (=='\n') 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 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''