WaveFront (empty) → 0.1.0.0
raw patch · 8 files changed
+910/−0 lines, 8 filesdep +GLUtildep +OpenGLdep +basesetup-changed
Dependencies added: GLUtil, OpenGL, base, containers, filepath, lens, linear
Files
- LICENSE.md +21/−0
- README.md +24/−0
- Setup.hs +2/−0
- WaveFront.cabal +72/−0
- src/Graphics/WaveFront/Foreign.hs +90/−0
- src/Graphics/WaveFront/Load.hs +88/−0
- src/Graphics/WaveFront/Parsers.hs +492/−0
- src/Graphics/WaveFront/Utilities.hs +121/−0
+ LICENSE.md view
@@ -0,0 +1,21 @@+The MIT License (MIT) + +Copyright (c) 2015 Jonatan H Sundqvist + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE.
+ README.md view
@@ -0,0 +1,24 @@+3DWaves +======= + +This is a personal project, still in its infancy, and I don't expect anybody else to use it. Should somehow happen upon this site, I would however welcome their support and feedback. + +##Contents +Wavefront OBJ parsers and related amenities. Includes purely functional parsers +and IO utilities for loading models from files. + +Supports the basic MTL and OBJ attributes. My ambition is to add full support for the entire specification. + +Please note that this package is completely unaware of rendering and graphics. The data structures generated by the parsers are oblivious to technologies such as Direct3D and OpenGL; creating eg. GPU buffers is up to the client. + +I may at some point implement the FFI and add direct OpenGL support, in separate modules. + +##Maintainers +Jonatan H Sundqvist + +##TODO +There is currently no standalone list of tasks (cf. source files). +- Use Parsec instead (branch off) (?) +- Add sample models and demos +- Add profiling and checks +- GHCi support
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple +main = defaultMain
+ WaveFront.cabal view
@@ -0,0 +1,72 @@+-- Initial WaveFront.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/ + +-- The name of the package. +name: WaveFront + +-- The package version. See the Haskell package versioning policy (PVP) +-- for standards guiding when and how versions should be incremented. +-- http://www.haskell.org/haskellwiki/Package_versioning_policy +-- PVP summary: +-+------- breaking API changes +-- | | +----- non-breaking API additions +-- | | | +--- code changes with no API change +version: 0.1.0.0 + +-- A short (one-line) description of the package. +synopsis: Parsers and utilities for the OBJ WaveFront 3D model format + +-- A longer description of the package. +-- description: + +-- The license under which the package is released. +license: MIT + +-- The file containing the license text. +license-file: LICENSE.md + +-- The package author(s). +author: Jonatan H Sundqvist + +-- An email address to which users can send suggestions, bug reports, and +-- patches. +maintainer: jonatanhsundqvist@gmail.com + +-- A copyright notice. +-- copyright: + +category: Graphics + +build-type: Simple + +-- Extra files to be distributed with the package, such as examples or a +-- README. +extra-source-files: README.md + +-- Constraint on the version of Cabal needed to build this package. +cabal-version: >=1.10 + + +library + -- Modules exported by the library. + exposed-modules: Graphics.WaveFront.Utilities, Graphics.WaveFront.Parsers, Graphics.WaveFront.Load, Graphics.WaveFront.Foreign + + -- Modules included in this library but not exported. + -- other-modules: + + -- LANGUAGE extensions used by modules in this package. + other-extensions: UnicodeSyntax, TupleSections, ForeignFunctionInterface + + -- Other library packages from which modules are imported. + build-depends: base <= 4.8.1.0, + lens <= 4.13.0.0, + OpenGL, + GLUtil, + linear, + filepath, + containers + + -- Directories containing source files. + hs-source-dirs: src + + -- Base language which the package is written in. + default-language: Haskell2010
+ src/Graphics/WaveFront/Foreign.hs view
@@ -0,0 +1,90 @@+-- | +-- Module : Graphics.WaveFront.Foreign +-- Description : Foreign function interface +-- Copyright : (c) Jonatan H Sundqvist, 2015 +-- License : MIT +-- Maintainer : Jonatan H Sundqvist +-- Stability : experimental|stable +-- Portability : POSIX (not sure) + +-- February 24 2015 + +-- TODO | - Possible to get rid of newtypes +-- - Decide on an API + +-- SPEC | - +-- - + + + +-- TODO: Why do same extensions start with 'X'? +{-# LANGUAGE ForeignFunctionInterface #-} + + + +-------------------------------------------------------------------------------------------------------------------------------------------- +-- API +-------------------------------------------------------------------------------------------------------------------------------------------- +module Graphics.WaveFront.Foreign where + + + +-------------------------------------------------------------------------------------------------------------------------------------------- +-- We'll need these +-------------------------------------------------------------------------------------------------------------------------------------------- +import System.IO.Unsafe (unsafePerformIO) +import Foreign.Storable +import qualified Foreign.C as C + +import qualified Graphics.WaveFront.Parsers as Parsers + + + +-------------------------------------------------------------------------------------------------------------------------------------------- +-- Types +-------------------------------------------------------------------------------------------------------------------------------------------- +-- | +newtype COBJ = COBJ Parsers.OBJ + + +-- | +newtype CMTL = CMTL Parsers.MTL + + +-- | We +instance Storable COBJ where + sizeOf = const 0 + alignment = const 0 + peek _ = error "Work in progress" + poke _ = error "Work in progress" + + +-- | We +instance Storable CMTL where + sizeOf = const 0 + alignment = const 0 + peek _ = error "Work in progress" + poke _ = error "Work in progress" + + + +-------------------------------------------------------------------------------------------------------------------------------------------- +-- Functions +-------------------------------------------------------------------------------------------------------------------------------------------- +-- | +-- I feel dirty... +parseOBJ :: C.CString -> COBJ +parseOBJ = COBJ . Parsers.parseOBJ . unsafePerformIO . C.peekCString + +-- | +parseMTL :: C.CString -> CMTL +parseMTL = CMTL . Parsers.parseMTL . unsafePerformIO . C.peekCString + + + +-------------------------------------------------------------------------------------------------------------------------------------------- +-- Pure foreign function interface +-------------------------------------------------------------------------------------------------------------------------------------------- +-- I feel the urge to make a joke about 'Unacceptable argument in foreign declaration' +-- foreign export ccall parseOBJ :: C.CString -> COBJ +-- foreign export ccall parseMTL :: C.CString -> CMTL
+ src/Graphics/WaveFront/Load.hs view
@@ -0,0 +1,88 @@+-- | +-- Module : Graphics.WaveFront.Load +-- Description : Loading (and perhaps writing) OBJ and MTL files +-- Copyright : (c) Jonatan H Sundqvist, 2015 +-- License : MIT +-- Maintainer : Jonatan H Sundqvist +-- Stability : experimental|stable +-- Portability : POSIX (not sure) +-- + +-- Created July 26 2015 + +-- TODO | - +-- - + +-- SPEC | - +-- - + + + +module Graphics.WaveFront.Load where + + + +-------------------------------------------------------------------------------------------------------------------------------------------- +-- GHC Extensions +-------------------------------------------------------------------------------------------------------------------------------------------- +{-# LANGUAGE UnicodeSyntax #-} +-- {-# LANGUAGE TupleSections #-} + + + +-------------------------------------------------------------------------------------------------------------------------------------------- +-- We'll need these +-------------------------------------------------------------------------------------------------------------------------------------------- +import System.FilePath (splitFileName, (</>)) +import System.IO (hFlush, stdout) + +import Data.Either (rights, isLeft) + +import Graphics.WaveFront.Parsers (parseOBJ, parseMTL, createMTLTable, createModel, OBJ(), MTL(), MTLTable(), OBJToken(LibMTL), Model()) +import Graphics.WaveFront.Utilities + + + +-------------------------------------------------------------------------------------------------------------------------------------------- +-- Functions (IO) +-------------------------------------------------------------------------------------------------------------------------------------------- +-- Loading data ---------------------------------------------------------------------------------------------------------------------------- +-- | +-- +-- TODO: Use bytestrings (?) +-- +loadOBJ :: String -> IO OBJ +loadOBJ fn = do + rawOBJ <- readFile fn -- + return $ parseOBJ rawOBJ -- + + +-- | +-- +-- TODO: Use bytestrings (?) +-- TODO: Merge OBJ and MTL parsers (and plug in format-specific code as needed) (?) +-- +loadMTL :: String -> IO MTL +loadMTL fn = do + rawMTL <- readFile fn -- Unparsed MTL data (text) + return $ parseMTL rawMTL -- + + +-- | +-- TODO: Better names (than 'mtls' and 'fns') (?) +-- TODO: Refactor, simplify +-- TODO: Improve path handling (cf. '</>') +loadMaterials :: [String] -> IO MTLTable +loadMaterials fns = do + mtls <- mapM loadMTL fns -- + return . createMTLTable . zip (map (snd . splitFileName) fns) . map tokensOf $ mtls -- + where tokensOf = rights . map second + + +-- | Loads an OBJ model from file, including associated materials +loadModel :: String -> IO Model +loadModel fn = do + obj <- loadOBJ fn + materials <- loadMaterials [ (fst $ splitFileName fn) </> name | LibMTL name <- rights $ map second obj ] + return $ createModel obj materials + -- where loadWithName name = loadMTL name >>= return . (name,)
+ src/Graphics/WaveFront/Parsers.hs view
@@ -0,0 +1,492 @@+-- | +-- 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
+ src/Graphics/WaveFront/Utilities.hs view
@@ -0,0 +1,121 @@+-- | +-- Module : Graphics.WaveFront.Utilities +-- Description : Parsing utilities +-- Copyright : (c) Jonatan H Sundqvist, 2015 +-- License : MIT +-- Maintainer : Jonatan H Sundqvist +-- Stability : experimental|stable +-- Portability : POSIX (not sure) +-- + +-- Created July 15 2015 + +-- TODO | - +-- - + +-- SPEC | - +-- - + + + +-------------------------------------------------------------------------------------------------------------------------------------------- +-- API +-------------------------------------------------------------------------------------------------------------------------------------------- +module Graphics.WaveFront.Utilities where + + + +-------------------------------------------------------------------------------------------------------------------------------------------- +-- We'll need these +-------------------------------------------------------------------------------------------------------------------------------------------- +import Data.List (isPrefixOf, unfoldr) +import Data.Char (isSpace) +import Text.Read (readEither) + + + +-------------------------------------------------------------------------------------------------------------------------------------------- +-- Functions +-------------------------------------------------------------------------------------------------------------------------------------------- +-- Parsing utilities ----------------------------------------------------------------------------------------------------------------------- +-- | This strikes me as overly convoluted. Should probably be refactored or removed entirely. +parseTokenWith :: String -> (String -> Either e token) -> Int -> (Int, Either e token, String) +parseTokenWith line parse = withoutComment line parse + + +-- | Passes the input line (stripped of any trailing comments) to the specified parser +withoutComment :: String -> (String -> a) -> Int -> (Int, a, String) +withoutComment (l:ine) parse lnum = let (l:tokens, comment) = span (/= '#') ine in (lnum, parse tokens, comment) + + +-- | Predicate for determining if a single line of text is a comment. +-- Comments are preceded by a '#' and any number of whitespace characters. +-- +-- TODO: Drop comments at the end of a line (?) +-- TODO: Add stripComment (or extractComment) which consumes a line up until the first '#'. +-- This would allow for tokens and comments to appear on the same line. +isComment :: String -> Bool +isComment = isPrefixOf "#" . dropWhile isSpace + + +-- | Strips a trailing comment from an MTL or OBJ line. +dropComment :: String -> String +dropComment = takeWhile (/= '#') + + +-- | +takeComment :: String -> String +takeComment = dropWhile (/= '#') + + +-- | +enumerate :: [(Int -> (Int, token, comment))] -> [(Int, token, comment)] +enumerate = zipWith (flip ($)) [1..] + + +-- | Splits a string into rows and filters out unimportant elements (empty lines and comments) +-- NOTE: This function is probably obsolete due to comments being included by the parsers +-- TODO: Higher order function for composing predicates +rows :: String -> [String] +rows = filter (not . satisfiesAny [null, isComment]) . lines + where satisfiesAny predicates x = any ($ x) predicates + + +-- | +-- TODO: Use readMaybe (?) +-- TODO: Variadic 'unpacking' (or is that sinful?) +-- TODO: More informative error message (?) +-- TODO: Rename (?) +-- TODO: Generic function for mapping and sequencing readEither (cf. "vt" case in parseOBJRow) (?) +vector :: Read r => ([r] -> b) -> [String] -> e -> Either e b +vector f coords e = either (Left . const e) (Right) (sequence (map readEither coords) >>= Right . f) +-- vector _ _ = Left $ "Wrong number of coordinates for vector" + + +-- | +second :: (a, b, c) -> b +second (_, b, _) = b + +-- | +third :: (a, b, c) -> c +third (_, _, c) = c + +-- From Southpaw --------------------------------------------------------------------------------------------------------------------------- + +-- | +splitWith :: Eq a => ([a] -> ([a], [a])) -> [a] -> [[a]] +splitWith f = unfoldr cut + where cut [] = Nothing + cut xs = Just $ f xs + + +-- | Same as Python's str.split (I think) (eg. split '|' "a||c" == ["a", "", "c"]) +-- TODO: Rename +-- TODO: Easier to implement with groupBy (?) +cuts :: Eq a => a -> [a] -> [[a]] +cuts c = splitWith $ \ xs -> let (token, rest) = span (/=c) xs in (token, drop 1 rest) + + +-- | Combine every adjacent pair in the list with the given function +pairwise :: (a -> a -> b) -> [a] -> [b] +pairwise f xs = zipWith f xs (drop 1 xs)