-- | -- Module : Graphics.WaveFront.Parsers -- Description : descr -- Copyright : (c) Jonatan H Sundqvist, February 8 2015 -- License : MIT -- Maintainer : Jonatan H Sundqvist -- Stability : experimental|stable -- Portability : POSIX (not sure) -- -- Created February 8 2015-- Wavefront - Parsers.hs -- Migrated to separate project on February 21 2015 -- TODO | - Appropriate container types (eg. bytestring, vector) -- - Grammar specification -- - Incremental parsing (?) -- - Improve naming scheme -- -- - Separate MTL and OBJ parsers (?) (...) -- - Separate parsing, processing, logging, IO and testing (...) -- -- Proper path handling (eg. include root in MTLTable or not) -- -- - Additional attributes (lighting, splines, etc.) -- - FFI (...) -- - Debugging information (line number, missing file, missing values, etc.) (...) -- - Proper Haddock coverage, including headers (...) -- - Model type (...) -- - Caching (?) -- - Performance, profiling, optimisations -- -- Strict or lazy (eg. with Data.Map) (?) -- -- - PrintfArg instances for the types defined in this module -- - Reconciling Cabal and hierarchical modules -- - Dealing with paths in lib statements (requires knowledge of working directories) -- - Move comments and specification to separate files (eg. README) -- - Inline comments (for internals, implementation) -- -- - Full OBJ spec compliance -- -- Do the usemtl and libmtl statements affect vertices or faces (?) -- -- - Parser bugs -- -- Negative coordinates enclosed in parentheses -- -- - Decide on a public interface (exports) (API) -- -- Model will be the main API type -- -- Processing utils (eg. iterating over model faces; withModelFaces :: ((Material, [(Vertex, Maybe Normalcoords, Maybe Texcoords)]) -> b) -> Model -> [b]) -- -- Export functions for working with the output data (eg. unzipIndices :: [(Int, Int, Int)] -> ([Int], [Int], [Int])) -- -- Export certain utilities (eg. second, perhaps in another module) (?) -- SPEC | - -- - -------------------------------------------------------------------------------------------------------------------------------------------- -- GHC Extensions -------------------------------------------------------------------------------------------------------------------------------------------- {-# LANGUAGE UnicodeSyntax #-} {-# LANGUAGE TupleSections #-} -------------------------------------------------------------------------------------------------------------------------------------------- -- Section -------------------------------------------------------------------------------------------------------------------------------------------- module Graphics.WaveFront.Parsers (parseOBJ, parseMTL, facesOf, materialsOf, modelAttributes, tessellate, boundingbox, hasTextures, textures, MTL(), OBJ(), Model(..), Face(..), Material(..), OBJToken(..), MTLToken(..), MTLTable(..), BoundingBox(..), OBJNoParse(..), MTLNoParse(..), createModel, createMTLTable) where -------------------------------------------------------------------------------------------------------------------------------------------- -- We'll need these -------------------------------------------------------------------------------------------------------------------------------------------- import Data.List (groupBy, unzip4) import Data.Maybe (listToMaybe, catMaybes) import Data.Either (rights) import Data.Char (isSpace) import qualified Data.Map as Map import qualified Data.Set as Set import Text.Read (readMaybe, readEither) import Control.Monad (liftM) -- import Southpaw.Utilities.Utilities (pairwise, cuts) import Graphics.WaveFront.Utilities -------------------------------------------------------------------------------------------------------------------------------------------- -- Types -------------------------------------------------------------------------------------------------------------------------------------------- -- OBJ parser types ------------------------------------------------------------------------------------------------------------------------ -- | Represents a single (valid) OBJ token -- -- TODO: Polymorphic numerical types (?) -- TODO: Add context, metadata (eg. line numbers, filename) (?) -- TODO: Naming scheme (added OBJ prefix to prevent name clashes; cf. Face type) -- TODO: Comment token (preserve comments in parser output or remove them) (?) data OBJToken = OBJVertex Float Float Float | OBJNormal Float Float Float | OBJTexture Float Float | OBJFace [(Int, Maybe Int, Maybe Int)] | -- TODO: Associate material with each face, handle absent indices UseMTL String | -- LibMTL String | -- TODO: Use actual MTL type Group [String] | -- TODO: Do grouped faces have to be consecutive? Object [String] -- TODO: What is the difference between group and object? deriving (Eq, Show) -- TODO: Derive Read (?) -- | -- TODO: Rename (?) data OBJNoParse = OBJComment String | OBJEmpty | OBJNoSuchAttribute String | OBJNoParse String deriving (Show) -- | -- TODO: Use error type instead of String, allowing us to distinguish invalid data -- from eg. comments and blank lines (?) type OBJRow = (Int, Either OBJNoParse OBJToken, String) -- | Output type of the OBJ parser. Currently a list of line number and token (or error string) pairs -- -- TODO: Rename (?) -- TODO: Use Integral for line number (?) -- type OBJ = [OBJRow] -- MTL parser types ------------------------------------------------------------------------------------------------------------------------ -- | Represents a single (valid) MTL token -- -- TODO: Is the alpha channel optional, ignored, disallowed? -- TODO: Include support for ('Ns', 'Ni', 'd', 'Tr', 'illum') -- data MTLToken = Ambient Float Float Float (Maybe Float) | -- Ka Diffuse Float Float Float (Maybe Float) | -- Kd Specular Float Float Float (Maybe Float) | -- Ks MapDiffuse String | -- map_Kd NewMaterial String -- newmtl deriving (Eq, Show) -- | -- TODO: Rename (?) data MTLNoParse = MTLComment String | MTLEmpty | MTLNoSuchAttribute String | MTLNoParse String deriving (Show) -- | Output type of the single-row MTL parser. type MTLRow = (Int, Either MTLNoParse MTLToken, String) -- | Output type of the MTL parser. Currently a list of line number and token (or error string) pairs -- -- TODO: Add type for processed MTL (eg. a map between names and materials) -- type MTL = [MTLRow] -- (line number, MTL token, comment) -- | type MTLTable = Map.Map String (Map.Map String Material) -- General types --------------------------------------------------------------------------------------------------------------------------- type Vector num = (num, num, num) -- Queen Vectoria type Point num = (num, num) -- Haskell is no longer Point-free -- API types ------------------------------------------------------------------------------------------------------------------------------- -- | -- TODO: Validation (eg. length ivertices == length == ivertices == length itextures if length isn't 0) -- TOOD: Pack indices in a tuple (eg. indices :: [(Int, Int, Int)]) (?) -- TOOD: Use (String, String) for the names of the mtl file and material instead of Material (?) -- TODO: Use types so as not to confuse the indices (eg. newtype INormal, newtype ITexcoord) data Face = Face { indices :: [(Int, Maybe Int, Maybe Int)], material :: Material } deriving (Show) -- | type Colour = (Float, Float, Float, Float) -- | -- TODO: Do all materials have an ambient, a diffuse and a specular colour (?) -- TODO: Support more attributes (entire spec) (?) -- TODO: Lenses (?) data Material = Material { ambient :: Colour, diffuse :: Colour, specular :: Colour, texture :: Maybe String } deriving (Show) -- | Abstract representation of an OBJ model with associated MTL definitions. -- -- TODO: Rename (?) -- TODO: Include metadata, comments, rejected data (?) -- TODO: Separate type for processed OBJTokens (ie. token + context) -- TODO: Perform index lookups (?) -- TODO: Reconsider the types (especially of the materials) -- TODO: Rename accessor functions (eg. texcoords instead of textures) (?) -- data Model = Model { vertices :: [Vector Float], normals :: [Vector Float], texcoords :: [Point Float], faces :: [Face], materials :: MTLTable, -- TODO: Type synonym (?) groups :: Map.Map [String] (Int, Int), -- TODO: Type synonym objects :: Map.Map [String] (Int, Int) -- TODO: Type synonym } deriving (Show) -- | data BoundingBox n = BoundingBox { left :: n, right :: n, top :: n, bottom :: n, front :: n, back :: n } -------------------------------------------------------------------------------------------------------------------------------------------- -- Functions (pure) -------------------------------------------------------------------------------------------------------------------------------------------- -- OBJ parsing ----------------------------------------------------------------------------------------------------------------------------- -- | This function creates an OBJToken or error for each line in the input data -- -- TODO: Use appropriate container type (cf. TODO section) -- TODO: Extract filter predicate (isComment, isEmpty) -- TODO: Is it even necessary to strip whitespace? -- TODO: Function for composing predicates (?) -- TODO: Should this function separate the various fields (eg. [(Vertices, Faces, Materials, Groups)] instead of [Maybe OBJToken]) -- parseOBJ :: String -> OBJ parseOBJ = enumerate . map parseOBJRow . lines -- . rows -- | Generates a token given a single valid OBJ row, or an error value if the input is malformed. -- -- TODO: Correctness (total function, no runtime exceptions) -- TODO: Rename 'which' (?) -- TODO: Handle invalid rows (how to deal with mangled definitions w.r.t indices?) -- TODO: Extract value parsing logic (eg. pattern matching, converting, handle errors) -- TODO: Named errors (typed?) rather than Nothing (cf. Either) (?) -- Type for unsupported but valid (according to spec) attributes (?) -- Type for specific attribute that failed to parse (eg. "f 1/2 0/p 1.5/x") -- -- TODO: Additional values, currently unsupported attributes (ignore?) (pattern match against the entire line, eg. ["vn", x, y, z]) -- TODO: Dealing with MTL definitions (pass in names, MTL value, return list of MTL dependencies) -- TODO: Take 1-based indexing into account straight away (?) -- TODO: Deal with absent texture and normal indices (✓) -- TODO: Strip trailing comments (✓) -- TODO: Don't ignore leftover values (errors?) (...) -- parseOBJRow :: String -> (Int -> OBJRow) -- Maybe OBJToken parseOBJRow ln = parseTokenWith ln $ \ line -> let (attr:values) = words line in case (attr:values) of ("f":_:_:_:_) -> either (Left . noparse . const line) (Right . OBJFace) . sequence . map (ivertex . cuts '/') $ values -- Face ["v", sx, sy, sz] -> vector (\ [x, y, z] -> OBJVertex x y z) [sx, sy, sz] (noparse line) -- Vertex ["vn", sx, sy, sz] -> vector (\ [x, y, z] -> OBJNormal x y z) [sx, sy, sz] (noparse line) -- Normal ["vt", sx, sy] -> vector (\ [x, y] -> OBJTexture x y) [sx, sy] (noparse line) -- Texture ("g":_:_) -> Right $ Group values -- Group ("o":_:_) -> Right $ Object values -- Object ("s":_:_) -> Left $ noparse line -- Smooth shading ["mtllib", lib] -> Right $ LibMTL lib -- ["usemtl", mtl] -> Right $ UseMTL mtl -- _ -> Left $ noparse line -- TODO: More informative errors where -- ivertex :: [String] -> Either OBJNoParse OBJToken ivertex [svi, sti, sni] = readEither svi >>= \ vi -> Right $ (vi, readMaybe sti, readMaybe sni) -- TODO: Refactor, simplify ivertex [svi, sti] = readEither svi >>= \ vi -> Right $ (vi, readMaybe sti, Nothing) -- TODO: Refactor, simplify ivertex [svi] = readEither svi >>= \ vi -> Right $ (vi, Nothing, Nothing) -- TODO: Refactor, simplify ivertex _ = Left ln noparse line | null line || all isSpace line = OBJEmpty | isComment line = OBJComment line | otherwise = OBJNoParse line -- | Returns a list of annotated parsing errors or the original OBJ data structure if -- validateOBJ :: OBJ -> Either [OBJNoParse] OBJ -- validateOBJ _ = undefined -- MTL parsing ----------------------------------------------------------------------------------------------------------------------------- -- | Produces a list of MTL tokens, with associated line numbers and comments parseMTL :: String -> MTL parseMTL = enumerate . map parseMTLRow . lines -- | Parses a single MTL row. -- -- TOOD: Simplify 'withChannels' -- TOOD: Process the MTL tokens (✗) -- TODO: cf. parseOBJRow -- parseMTLRow :: String -> (Int -> MTLRow) parseMTLRow ln = parseTokenWith ln $ \ line -> let (which:values) = words line in case which:values of ("Ka":sr:sg:sb:rest) -> withChannels Ambient sr sg sb rest line -- Ka ("Kd":sr:sg:sb:rest) -> withChannels Diffuse sr sg sb rest line -- Kd ("Ks":sr:sg:sb:rest) -> withChannels Specular sr sg sb rest line -- Ks ["map_Kd", name] -> Right $ MapDiffuse name -- map_Kd ["newmtl", name] -> Right $ NewMaterial name -- newmtl _ -> Left $ noparse line -- where withChannels f sr sg sb [] line = vector (\[r, g, b] -> f r g b Nothing) [sr, sg, sb] (noparse line) -- TODO: Refactor, simplify withChannels f sr sg sb [sa] line = vector (\[r, g, b] -> f r g b $ readMaybe sa) [sr, sg, sb] (noparse line) -- TODO: Refactor, simplify withChannels _ _ _ _ _ line = Left $ noparse line noparse line | null line || all isSpace line = MTLEmpty | isComment line = MTLComment line | otherwise = MTLNoParse line -- Parser output churners (OBJ) ------------------------------------------------------------------------------------------------------------ -- | Creates a mapping between group names and the corresponding bounds ([lower, upper)). Invalid -- tokens are simply discarded by this function. -- -- TODO: Figure out how to deal with multiple group names (eg. "g mesh1 nose head") groupsOf :: [OBJToken] -> Map.Map [String] (Int, Int) groupsOf = buildIndexMapWith . filter notObject where notObject (Object _) = False notObject _ = True -- | objectsOf :: [OBJToken] -> Map.Map [String] (Int, Int) objectsOf = buildIndexMapWith . filter notGroup where notGroup (Group _) = False notGroup _ = True -- | Creates a mapping between names (of groups or objects) to face indices -- -- TODO: Refactor, simplify -- buildIndexMapWith :: [OBJToken] -> Map.Map [String] (Int, Int) buildIndexMapWith tokens = Map.fromList . pairwise zipIndices . reverse . addLastIndex $ foldl update (0, []) $ tokens where addLastIndex (nfaces, groups') = ([], nfaces):groups' zipIndices (names, low) (_, upp) = (names, (low, upp)) update (nfaces, groups') token = case token of Group names -> (nfaces, (names, nfaces):groups') Object names -> (nfaces, (names, nfaces):groups') OBJFace _ -> (nfaces+1, groups') _ -> (nfaces, groups') -- | Filters out faces from a stream of OBJTokens and attaches the currently selected material, -- as defined by the most recent LibMTL and UseMTL tokens. -- -- TODO: Don't use foldl (?) -- TODO: Deal with errors (eg. missing materials) -- TODO: Improve naming scheme (lots of primes) -- TODO: Default material, take 'error-handling' function (?) -- facesOf :: [OBJToken] -> MTLTable -> [Either String Face] facesOf tokens table = reverse . third . foldl update ("", "", []) $ tokens where retrieve lib mat = Map.lookup lib table >>= Map.lookup mat createFace lib mat ind = case retrieve lib mat of Nothing -> Left $ "No such material: " ++ lib ++ "." ++ mat Just m -> Right $ Face { indices=ind, material=m } update (lib', material', faces') token = case token of OBJFace ind -> (lib', material', createFace lib' material' ind : faces') LibMTL lib -> (lib, material', faces') UseMTL mat -> (lib', mat, faces') _ -> (lib', material', faces') -- Parser output churners (MTL) ------------------------------------------------------------------------------------------------------------ -- | Constructs a map between names and materials. Partially or wholly undefined materials -- are mapped to a string detailing the error (eg. Left "missing specular"). -- -- TODO: Debug information (eg. attributes without an associated material) -- TODO: Pass in error function (would allow for more flexible error handling) (?) -- TODO: Filter out parser failures (?) -- TOOD: Deal with duplicated attributes (probably won't crop up in any real situations) materialsOf :: [MTLToken] -> Map.Map String (Either String Material) materialsOf tokens = Map.fromList . rights $ map createMaterial thegroups where thegroups = groupBy (((not . isnew) .) . flip const) tokens -- TODO: Refactor this atrocity isnew (NewMaterial _) = True -- TODO: Rename isnew isnew _ = False createMaterial (NewMaterial name:attrs) = Right $ (name, fromAttributes attrs) createMaterial attrs = Left $ "Free-floating attributes: " ++ show attrs fromAttributes attrs | any null colours = Left $ "Missing colour(s)" -- TODO: More elaborate message (eg. which colour) | otherwise = Right $ Material { ambient=head amb, diffuse=head diff, specular=head spec, texture=listToMaybe [ name | MapDiffuse name <- attrs ] } where colours@[diff, spec, amb] = [[ (r, g, b, maybe 1.0 id a) | Diffuse r g b a <- attrs ], [ (r, g, b, maybe 1.0 id a) | Specular r g b a <- attrs ], [ (r, g, b, maybe 1.0 id a) | Ambient r g b a <- attrs ]] -- | -- TODO: Debug information (eg. how many invalid materials were filtered out) -- TODO: Refactor, simplify createMTLTable :: [(String, [MTLToken])] -> MTLTable createMTLTable mtls = Map.fromList . map (\ (name, tokens) -> (name, Map.mapMaybe prune . materialsOf $ tokens)) $ mtls where prune (Right mat) = Just mat prune (Left _) = Nothing -- API functions --------------------------------------------------------------------------------------------------------------------------- -- | -- TODO: Use map for materials (?) -- TODO: How to retrieve MTL data -- TODO: How to deal with errors, including no-parse, index errors, etc. -- TODO: Performance, how are 'copies' of coordinates handled (?) -- TODO: Performance, one pass (with a fold perhaps) -- TODO: Use a more efficient data structure (especially w.r.t indexing; cf. Vector) -- TODO: Consider preserving the indices (rather than generating a list of duplicated vertices). -- This would preserve space (in cases where vertices are often re-used), as well as being -- very compatible with index buffers on graphics cards. -- -- TODO: Keep map of materials and list of textures in final output (inside model or as items in a tuple) (?) -- -- I never knew pattern matching in list comprehensions could be used to filter by constructor -- let rows = parseOBJ data in ([ v | @v(Vertex {}) <- rows], [ v | @v(Vertex {}) <- rows]) createModel :: OBJ -> MTLTable -> Model createModel tokens thematerials = let modeldata = rights $ map second tokens -- TODO: Vat do vee du viz ze dissidents, kommandant? in Model { vertices = [ (x, y, z) | OBJVertex x y z <- modeldata ], normals = [ (x, y, z) | OBJNormal x y z <- modeldata ], texcoords = [ (x, y) | OBJTexture x y <- modeldata ], faces = map tessellate . rights $ facesOf modeldata thematerials, groups = groupsOf modeldata, objects = objectsOf modeldata, materials = thematerials } -- | -- data Attributes = Attributes { -- vertexdata :: Vertices -- texcoorddata :: TexCoords -- } -- newtype Vertices = Vertices [Vector Float] -- newtype TexCoords = TexCoords [Maybe (Point Float)] -- newtype Normals = Normals [Maybe (Vector Float)] -- newtype Materials = Materials [Material] type Vertices = [Vector Float] type TexCoords = [Maybe (Point Float)] type Normals = [Maybe (Vector Float)] type Materials = [Material] -- | Extracts vertex, normal, texture and material data from a model -- TODO: Figure out how to deal with missing indices modelAttributes :: Model -> (Vertices, TexCoords, Normals, Materials) modelAttributes model = unzip4 $ concat [ map (attributesAt mat) theindices | Face { material=mat, indices=theindices } <- faces model] where vertexAt = (vertices model !!) . subtract 1 -- normalAt = liftM $ (normals model !!) . subtract 1 -- texcoordAt = liftM $ (texcoords model !!) . subtract 1 -- attributesAt mat (vi, ti, ni) = (vertexAt vi, texcoordAt ti, normalAt ni, mat) -- collect (vs, ts, ns, mats) = (Vertices vs, TexCoords ts, Normals ns, Materials mats) -- | -- TODO: Specialise to [[Face]] (?) -- TODO: Check vertex count (has to be atleast three) -- TODO: Better names (?) tessellate :: Face -> Face tessellate face@(Face { indices=ind }) = face { indices=triangles ind } where triangles (a:rest) =concat $ pairwise (\b c -> [a, b, c]) rest -- | -- unpackModelAttributes :: -- | boundingbox :: Model -> BoundingBox Float boundingbox model = BoundingBox { left=minx, right=maxx, bottom=miny, top=maxy, front=maxz, back=minz } where minmax (v:alues) = foldr (\val acc -> (min val (fst acc), max val (snd acc))) (v, v) alues (minx, maxx) = minmax . map (\(x, _, _) -> x) $ vertices model (miny, maxy) = minmax . map (\(_, y, _) -> y) $ vertices model (minz, maxz) = minmax . map (\(_, _, z) -> z) $ vertices model -- TODO: Make sure the order is right -- Model queries --------------------------------------------------------------------------------------------------------------------------- -- | hasTextures :: Model -> Bool hasTextures = not . Set.null . textures -- (/= Nothing) -- | All texture names as a list -- TODO: Wrap in ;aybe (instead of empty list) (?) textures :: Model -> Set.Set String textures = Set.fromList . catMaybes . map texture . concatMap Map.elems . Map.elems . materials