diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -9,10 +9,13 @@ 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. +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. +## Examples + + ## Maintainers Jonatan H Sundqvist @@ -20,8 +23,22 @@ See source files (.hs) for additional items. -- [ ] Use Parsec instead (branch off) (?) -- [ ] Add sample models and demos -- [ ] Add profiling and checks -- [ ] GHCi support -- [ ] Proper ticket system +- [ ] Performance (currently, it's atrocious) (...) + - Parallelism (...) +- [ ] Add sample models and demos (...) +- [ ] Add profiling and checks (cf. QuickCheck) + - Travis-CI integration +- [x] GHCi support (added .ghci file, works quite well) +- [x] Proper ticket system ([here](https://github.com/SwiftsNamesake/3DWaves/issues/)) +- [ ] Polymorphism (...) +- [ ] Querying + - Asking questions about a particular model (bounds, storage, number of faces, material types, etc.) + - Asking questions about the OBJ and MTL formats (eg. 'what does the various illum values mean') + - Screenshots (maybe in the wavefront-render package) +- [ ] Serialising (eg. writing to OBJ and MTL) +- [ ] Rendering + - Create a separate package (wavefront-render) with an OpenGL backend +- [ ] Executables + - OBJ viewer (...) + - Command line tool (?) +- [ ] Foreign function interface diff --git a/WaveFront.cabal b/WaveFront.cabal --- a/WaveFront.cabal +++ b/WaveFront.cabal @@ -10,7 +10,7 @@ -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change -version: 0.1.2.0 +version: 0.5.0.0 -- A short (one-line) description of the package. synopsis: Parsers and utilities for the OBJ WaveFront 3D model format @@ -24,7 +24,7 @@ -- The file containing the license text. license-file: LICENSE.md --- The package author(s). +-- The package
author: Jonatan H Sundqvist -- An email address to which users can send suggestions, bug reports, and @@ -46,29 +46,66 @@ cabal-version: >=1.10 +flag pedantic + description: Enable warnings + default: True + + +flag optimise + description: Enable optimisations + -- TODO: Should probably be True + default: False + + +flag profile + description: Enable profiling options + default: False + + +source-repository head + type: git + -- TODO: Rename the GitHub repo (?) + location: https://github.com/swiftsnamesake/3DWaves + + library -- Modules exported by the library. - exposed-modules: Graphics.WaveFront.Types, Graphics.WaveFront.Utilities, Graphics.WaveFront.Parsers, Graphics.WaveFront.Load, - Graphics.WaveFront.Foreign + exposed-modules: Graphics.WaveFront, + Graphics.WaveFront.Types, + Graphics.WaveFront.Lenses, + Graphics.WaveFront.Parse, + Graphics.WaveFront.Load, + Graphics.WaveFront.Foreign, + Graphics.WaveFront.Model -- Modules included in this library but not exported. - -- other-modules: + other-modules: Graphics.WaveFront.Parse.Common, + Graphics.WaveFront.Parse.OBJ, + Graphics.WaveFront.Parse.MTL + -- Compiler arguments + ghc-options: -Wall + -- LANGUAGE extensions used by modules in this package. + -- TODO: This list is incomplete other-extensions: UnicodeSyntax, TupleSections, ForeignFunctionInterface -- Other library packages from which modules are imported. - build-depends: base == 4.*, - lens <= 4.13.0.0, - OpenGL, - GLUtil, - linear, - filepath, - containers, - Cartesian + build-depends: base == 4.* + , lens <= 4.14 + , either + , transformers + , linear + , vector + , text + , attoparsec + , filepath + , containers + , QuickCheck + , Cartesian -- Directories containing source files. hs-source-dirs: src -- Base language which the package is written in. - default-language: Haskell2010 + default-language: Haskell2010 diff --git a/src/Graphics/WaveFront.hs b/src/Graphics/WaveFront.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/WaveFront.hs @@ -0,0 +1,37 @@ +-- | +-- Module : Graphics.WaveFront +-- Description : Re-exports public API +-- Copyright : (c) Jonatan H Sundqvist, 2016 +-- License : MIT +-- Maintainer : Jonatan H Sundqvist +-- Stability : experimental|stable +-- Portability : POSIX (not sure) + +-- TODO | - Logging +-- - + +-- SPEC | - +-- - + + + +-------------------------------------------------------------------------------------------------------------------------------------------- +-- GHC Extensions +-------------------------------------------------------------------------------------------------------------------------------------------- + + + +-------------------------------------------------------------------------------------------------------------------------------------------- +-- API +-------------------------------------------------------------------------------------------------------------------------------------------- +module Graphics.WaveFront () where -- TODO: Fill this in + + + +-------------------------------------------------------------------------------------------------------------------------------------------- +-- We'll need these +-------------------------------------------------------------------------------------------------------------------------------------------- +-- import Graphics.WaveFront.Types +-- import qualified Graphics.WaveFront.Parse as Parse +-- import qualified Graphics.WaveFront.Parse.Common as Parse +-- import Graphics.WaveFront.Model diff --git a/src/Graphics/WaveFront/Foreign.hs b/src/Graphics/WaveFront/Foreign.hs --- a/src/Graphics/WaveFront/Foreign.hs +++ b/src/Graphics/WaveFront/Foreign.hs @@ -9,7 +9,7 @@ -- February 24 2015 --- TODO | - Possible to get rid of newtypes +-- TODO | - Possible to get rid of newtypes (?) -- - Decide on an API -- SPEC | - @@ -17,7 +17,7 @@ --- TODO: Why do same extensions start with 'X'? +-- TODO: Why do some extensions start with 'X'? {-# LANGUAGE ForeignFunctionInterface #-} @@ -32,12 +32,12 @@ -------------------------------------------------------------------------------------------------------------------------------------------- -- We'll need these -------------------------------------------------------------------------------------------------------------------------------------------- -import System.IO.Unsafe (unsafePerformIO) -import Foreign.Storable -import qualified Foreign.C as C +-- import System.IO.Unsafe (unsafePerformIO) +-- import Foreign.Storable +-- import qualified Foreign.C as C -import Graphics.WaveFront.Types -import qualified Graphics.WaveFront.Parsers as Parsers +-- import Graphics.WaveFront.Types +-- import qualified Graphics.WaveFront.Parse as Parse @@ -45,15 +45,39 @@ -- Functions -------------------------------------------------------------------------------------------------------------------------------------------- --- | --- I feel dirty... -parseOBJ :: C.CString -> COBJ -parseOBJ = COBJ . Parsers.parseOBJ . unsafePerformIO . C.peekCString +-- -- | +-- -- 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 --- | -parseMTL :: C.CString -> CMTL -parseMTL = CMTL . Parsers.parseMTL . unsafePerformIO . C.peekCString + +-- -- | +-- newtype COBJ = COBJ OBJ +-- +-- +-- -- | +-- newtype CMTL = CMTL 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" -------------------------------------------------------------------------------------------------------------------------------------------- diff --git a/src/Graphics/WaveFront/Lenses.hs b/src/Graphics/WaveFront/Lenses.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/WaveFront/Lenses.hs @@ -0,0 +1,54 @@ +-- | +-- Module : Graphics.WaveFront.Lenses +-- Description : +-- Copyright : (c) Jonatan H Sundqvist, 2016 +-- License : MIT +-- Maintainer : Jonatan H Sundqvist +-- Stability : experimental|stable +-- Portability : POSIX (not sure) +-- + +-- Created July 9 2016 + +-- TODO | - +-- - + +-- SPEC | - +-- - + + + +-------------------------------------------------------------------------------------------------------------------------------------------- +-- GHC Pragmas +-------------------------------------------------------------------------------------------------------------------------------------------- +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE FlexibleInstances #-} + + + +-------------------------------------------------------------------------------------------------------------------------------------------- +-- API +-------------------------------------------------------------------------------------------------------------------------------------------- +module Graphics.WaveFront.Lenses where + + + +-------------------------------------------------------------------------------------------------------------------------------------------- +-- We'll need these +-------------------------------------------------------------------------------------------------------------------------------------------- +import Control.Lens (makeLensesWith, abbreviatedFields) + +import Graphics.WaveFront.Types + + + +-------------------------------------------------------------------------------------------------------------------------------------------- +-- Lenses +-------------------------------------------------------------------------------------------------------------------------------------------- +makeLensesWith abbreviatedFields ''VertexIndices +makeLensesWith abbreviatedFields ''Face +makeLensesWith abbreviatedFields ''Colour +makeLensesWith abbreviatedFields ''Material +makeLensesWith abbreviatedFields ''Model diff --git a/src/Graphics/WaveFront/Load.hs b/src/Graphics/WaveFront/Load.hs --- a/src/Graphics/WaveFront/Load.hs +++ b/src/Graphics/WaveFront/Load.hs @@ -10,7 +10,7 @@ -- Created July 26 2015 --- TODO | - +-- TODO | - Logging -- - -- SPEC | - @@ -33,59 +33,70 @@ -------------------------------------------------------------------------------------------------------------------------------------------- -- We'll need these -------------------------------------------------------------------------------------------------------------------------------------------- -import System.FilePath (splitFileName, ()) -import System.IO (hFlush, stdout) +import System.FilePath (splitFileName, takeDirectory, ()) -import Data.Either (rights, isLeft) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.IO as T +import Data.Vector (Vector) -import Control.Lens ((^.), _2) +import Control.Applicative ((<$>)) +import Control.Monad.Trans.Either +import Control.Monad.Trans.Class (lift) -import Graphics.WaveFront.Types -import Graphics.WaveFront.Parsers (parseOBJ, parseMTL, createMTLTable, createModel) -import Graphics.WaveFront.Utilities +import qualified Data.Attoparsec.Text as Atto +import Graphics.WaveFront.Types +import qualified Graphics.WaveFront.Parse as Parse +import qualified Graphics.WaveFront.Parse.Common as Parse +import Graphics.WaveFront.Model (createMTLTable, createModel) + -------------------------------------------------------------------------------------------------------------------------------------------- -- Functions (IO) -------------------------------------------------------------------------------------------------------------------------------------------- + -- Loading data ---------------------------------------------------------------------------------------------------------------------------- + -- | --- --- TODO: Use bytestrings (?) --- -loadOBJ :: String -> IO OBJ -loadOBJ fn = do - rawOBJ <- readFile fn -- - return $ parseOBJ rawOBJ -- +-- TODO | - Use bytestrings (?) +-- - Deal with IO and parsing errors +obj :: (Fractional f, Integral i) => String -> IO (Either String (OBJ f Text i [])) +obj fn = runEitherT $ do + lift $ putStrLn $ "Loading obj file: " ++ fn + EitherT $ Atto.parseOnly (Parse.wholeFile Parse.obj) <$> T.readFile fn -- | --- --- 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 | - Use bytestrings (?) +-- - Merge OBJ and MTL parsers (and plug in format-specific code as needed) (?) +-- - Deal with IO and parsing errors +mtl :: (Fractional f) => String -> IO (Either String (MTL f Text [])) +mtl fn = do + putStrLn $ "Loading mtl file: " ++ fn + Atto.parseOnly (Parse.wholeFile Parse.mtl) <$> T.readFile fn -- | --- 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 (^._2) +-- TODO | - Better names (than 'mtls' and 'fns') (?) +-- - Refactor, simplify +-- - Improve path handling (cf. '') +-- - Graceful error handling +materials :: (Fractional f) => [FilePath] -> IO (Either String (MTLTable f Text)) +materials fns = runEitherT $ do + tokens <- mapM (EitherT . mtl) fns + EitherT . return $ createTableFromMTLs tokens + where + createTableFromMTLs :: [[MTLToken f Text]] -> Either String (MTLTable f Text) + createTableFromMTLs = createMTLTable . zip (map (T.pack . snd . splitFileName) fns) -- | 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 (^._2) obj ] - return $ createModel obj materials - -- where loadWithName name = loadMTL name >>= return . (name,) +-- TODO | - Graceful error handling +model :: (Fractional f, Integral i) => FilePath -> IO (Either String (Model f Text i Vector)) +model fn = runEitherT $ do + obj <- EitherT $ obj fn + materials <- EitherT $ materials [ fst (splitFileName fn) T.unpack name | LibMTL name <- obj ] + EitherT . return $ createModel obj materials (Just $ takeDirectory fn) + -- where loadWithName name = mtl name >>= return . (name,) diff --git a/src/Graphics/WaveFront/Model.hs b/src/Graphics/WaveFront/Model.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/WaveFront/Model.hs @@ -0,0 +1,323 @@ +-- | +-- Module : Graphics.WaveFront.Model +-- Description : +-- Copyright : (c) Jonatan H Sundqvist, 2016 +-- License : MIT +-- Maintainer : Jonatan H Sundqvist +-- Stability : stable +-- Portability : portable +-- + +-- TODO | - Single-pass (eg. consume all tokens only once) for additional performance (?) +-- - + +-- SPEC | - +-- - + + + +-------------------------------------------------------------------------------------------------------------------------------------------- +-- GHC Extensions +-------------------------------------------------------------------------------------------------------------------------------------------- +{-# LANGUAGE UnicodeSyntax #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +--{-# LANGUAGE OverloadedLists #-} + + + +-------------------------------------------------------------------------------------------------------------------------------------------- +-- Section +-------------------------------------------------------------------------------------------------------------------------------------------- +-- TODO | - Clean this up +module Graphics.WaveFront.Model ( + BoundingBox(..), + facesOf, materialsOf, + tessellate, bounds, + hasTextures, textures, + createModel, createMTLTable, + fromIndices, fromFaceIndices, diffuseColours +) where + + + +-------------------------------------------------------------------------------------------------------------------------------------------- +-- We'll need these +-------------------------------------------------------------------------------------------------------------------------------------------- +import qualified Data.Vector as V +import Data.Vector (Vector, (!?)) + +import Data.Text (Text) +import qualified Data.Map as M +import Data.Map (Map) +import qualified Data.Set as S +import Data.Set (Set) + +import Data.List (groupBy) +import Data.Maybe (listToMaybe, catMaybes) + +import Linear (V3(..)) + +import Control.Lens ((^.), (.~), (%~), (&), _1, _2, _3) + +import Cartesian.Core (BoundingBox(..), fromExtents, x, y, z) + +import Graphics.WaveFront.Types +import Graphics.WaveFront.Lenses + + + +-------------------------------------------------------------------------------------------------------------------------------------------- +-- Functions +-------------------------------------------------------------------------------------------------------------------------------------------- + +-------------------------------------------------------------------------------------------------------------------------------------------- + +-- TODO | - Factor out these combinators + +-- | Performs a computation on adjacent pairs in a list +-- TODO | - Factor out and make generic +pairwise :: (a -> a -> b) -> [a] -> [b] +pairwise f xs = zipWith f xs (drop 1 xs) + + +-- | Convers an Either to a Maybe +eitherToMaybe :: Either a b -> Maybe b +eitherToMaybe (Right b) = Just b +eitherToMaybe (Left _) = Nothing + + +-- | Converts a Maybe to an Either +maybeToEither :: a -> Maybe b -> Either a b +maybeToEither _ (Just b) = Right b +maybeToEither a (Nothing) = Left a + +-- Parser output churners (OBJ) ------------------------------------------------------------------------------------------------------------ + +-- TODO | - Move to separate module (eg. WaveFront.Model) + +-- | Creates a mapping between group names and the corresponding bounds ([lower, upper)). +-- +-- TODO | - Figure out how to deal with multiple group names (eg. "g mesh1 nose head") +-- - Include not just face indices but vertex indices (makes it easier to 'slice' GPU buffers) (maybe in a separate function) +groupsOf :: (Ord s, Integral i) => [OBJToken f s i m] -> Map (Set s) (i, i) +groupsOf = buildIndexMapWith . filter notObject + where + notObject (Object _) = False + notObject _ = True + + +-- | Creates a mapping between object names and the corresponding bounds ([lower, upper)). +objectsOf :: (Ord s, Integral i) => [OBJToken f s i m] -> Map (Set s) (i, i) +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 +-- - What happens if the same group or object appears multiple times (is that possible?) +-- - Rename or add function parameter (the -With suffix implies a function parameter) +buildIndexMapWith :: (Ord s, Integral i) => [OBJToken f s i m] -> Map (Set s) (i, i) +buildIndexMapWith = M.fromList . pairwise zipIndices . update 0 + where + zipIndices (names, low) (_, upp) = (names, (low, upp)) + + -- TODO | - Separate Group and Object lists + -- - Rename (?) + -- - Factor out (might be useful for testing) (?) + update faceCount [] = [(S.empty, faceCount)] + update faceCount (Group names:xs) = (names, faceCount) : update faceCount xs + update faceCount (Object names:xs) = (names, faceCount) : update faceCount xs + update faceCount (OBJFace _:xs) = update (faceCount + 1) xs + update faceCount (_:xs) = update faceCount xs + + +-- | Filters out faces from a stream of OBJTokens and attaches the currently selected material, +-- as defined by the most recent LibMTL and UseMTL tokens. +facesOf :: forall f s i m. Ord s => MTLTable f s -> [OBJToken f s i m] -> [Either String (Face f s i m)] +facesOf materials' = makeFaces Nothing Nothing + where + -- | It's not always rude to make faces + -- TODO | - Keep refactoring... + -- - Rename (?) + makeFaces :: Maybe s -> Maybe s -> [OBJToken f s i m] -> [Either String (Face f s i m)] + makeFaces _ _ [] = [] + makeFaces lib@(Just libName) mat@(Just matName) (OBJFace is:xs) = createFace materials' libName matName is : makeFaces lib mat xs + + makeFaces lib@Nothing mat (OBJFace _:xs) = Left "No library selected for face" : makeFaces lib mat xs + makeFaces lib mat@Nothing (OBJFace _:xs) = Left "No material selected for face" : makeFaces lib mat xs + + makeFaces _ mat (LibMTL libName:xs) = makeFaces (Just libName) mat xs + makeFaces lib _ (UseMTL matName:xs) = makeFaces lib (Just matName) xs + + makeFaces lib mat (_:xs) = makeFaces lib mat xs + + +-- | +createFace :: Ord s => MTLTable f s -> s -> s -> m (VertexIndices i) -> Either String (Face f s i m) +createFace materials' libName matName indices' = do + material' <- lookupMaterial materials' libName matName + Right $ Face { fIndices=indices', fMaterial=material' } + + +-- | Tries to find a given material in the specified MTL table +-- TODO | - Specify missing material or library name (would require additional constraints on 's') +-- - Refactor +lookupMaterial :: Ord s => MTLTable f s -> s -> s -> Either String (Material f s) +lookupMaterial materials' libName matName = do + library <- maybeToEither "No such library" (M.lookup libName materials') + maybeToEither "No such material" (M.lookup matName library) + +-- Parser output churners (MTL) ------------------------------------------------------------------------------------------------------------ + +-- | Constructs an MTL table from a list of (libraryName, token stream) pairs. +-- TODO | - Refactor, simplify +createMTLTable :: Ord s => [(s, [MTLToken f s])] -> Either String (MTLTable f s) +createMTLTable = fmap M.fromList . mapM (\(name, tokens) -> (name,) <$> materialsOf tokens) + + +-- | Constructs a map between names and materials. Incomplete material definitions +-- result in an error (Left ...). +-- +-- TODO | - Debug information (eg. attributes without an associated material) +-- - Pass in error function (would allow for more flexible error handling) (?) +-- - Deal with duplicated attributes (probably won't crop up in any real situations) +materialsOf :: Ord s => [MTLToken f s] -> Either String (Map s (Material f s)) +materialsOf = fmap M.fromList . mapM createMaterial . partitionMaterials + + +-- | Creates a new (name, material) pair from a stream of MTL tokens. +-- The first token should be a new material name. +createMaterial :: [MTLToken f s] -> Either String (s, Material f s) +createMaterial (NewMaterial name:attrs) = (name,) <$> fromAttributes attrs +createMaterial attrs = Left $ "Free-floating attributes" + + +-- | Breaks a stream of MTL tokens into lists of material definitions +-- TODO | - Rename (eg. groupMaterials) (?) +partitionMaterials :: [MTLToken f s] -> [[MTLToken f s]] +partitionMaterials = groupBy (\_ b -> not $ isNewMaterial b) + where + isNewMaterial (NewMaterial _) = True + isNewMaterial _ = False + + +-- | Creates a material +fromAttributes :: [MTLToken f s] -> Either String (Material f s) +fromAttributes attrs = case colours' of + Nothing -> Left $ "Missing colour(s)" -- TODO: More elaborate message (eg. which colour) + Just (amb, diff, spec) -> Right $ Material { fAmbient=amb,fDiffuse=diff, fSpecular=spec, fTexture=texture' } + where + colours' = materialColours attrs + texture' = listToMaybe [ name | MapDiffuse name <- attrs ] + + +-- | Tries to extract a diffuse colour, a specular colour, and an ambient colour from a list of MTL tokens +-- TODO | - Should we really require all three colour types (?) +-- - Rename (?) +materialColours :: [MTLToken f s] -> Maybe (Colour f, Colour f, Colour f) +materialColours attrs = (,,) <$> + listToMaybe [ c | (Diffuse c) <- attrs ] <*> + listToMaybe [ c | (Specular c) <- attrs ] <*> + listToMaybe [ c | (Ambient c) <- attrs ] + +-- API functions --------------------------------------------------------------------------------------------------------------------------- + +-- | Constructs a model from a stream of OBJ tokens, a materials table and an optional path to root of the model (used for textures, etc.) +-- +-- TODO | - Performance, how are 'copies' of coordinates handled (?) +-- - Performance, one pass (with a fold perhaps) +-- +-- I never knew pattern matching in list comprehensions could be used to filter by constructor +createModel :: (Ord s, Integral i) => OBJ f s i [] -> MTLTable f s -> Maybe FilePath -> Either String (Model f s i Vector) +createModel tokens materials root = do + faces' <- sequence $ facesOf materials tokens + return $ Model { fVertices = V.fromList [ vec | OBJVertex vec <- tokens ], + fNormals = V.fromList [ vec | OBJNormal vec <- tokens ], + fTexcoords = V.fromList [ vec | OBJTexCoord vec <- tokens ], + fFaces = packFaces faces', + fGroups = groupsOf tokens, + fObjects = objectsOf tokens, + fMaterials = materials, + fRoot = root } + where + packFace :: Face f s i [] -> Face f s i Vector + packFace face@Face{fIndices} = face { fIndices=V.fromList fIndices } -- indices %~ (_) -- TODO: Type-changing lenses + + packFaces :: [] (Face f s i []) -> Vector (Face f s i Vector) + packFaces = V.fromList . map (packFace . tessellate) + + +-- | +-- TODO | - Specialise to [[Face]] (?) +-- - Check vertex count (has to be atleast three) +-- - Better names (?) +tessellate :: Face f s i [] -> Face f s i [] +tessellate = indices %~ triangles + where + triangles [] = [] + triangles (a:rest) = concat $ pairwise (\b c -> [a, b, c]) rest + + +-- | Finds the axis-aligned bounding box of the model +-- TODO | - Deal with empty vertex lists (?) +-- - Refactor +-- - Folding over applicative (fold in parallel) +-- - Make sure the order is right +bounds :: (Num f, Ord f, Foldable m, HasVertices (Model f s i m) (m (V3 f))) => Model f s i m -> BoundingBox (V3 f) +bounds model = fromExtents $ axisBounds (model^.vertices) <$> V3 x y z + where + -- TODO | - Factor out 'minmax' + minmaxBy :: (Ord o, Num o, Foldable m) => (a -> o) -> m a -> (o, o) + minmaxBy f values = foldr (\val' acc -> let val = f val' in (min val (fst acc), max val (snd acc))) (0, 0) values -- TODO: Factor out + + axisBounds vs axis = minmaxBy (^.axis) vs + +-- Orphaned TODOs? + +-- TODO | - Deal with missing values properly +-- - Indexing should be defined in an API function + +-------------------------------------------------------------------------------------------------------------------------------------------- + +-- TODO | - Polymorphic indexing and traversing +-- - Profile, optimise +-- - Index buffers + + +-- | Takes a vector of data, an index function, a choice function, a vector of some type with indices +-- and uses the indices to constructs a new Vector with the data in the original vector. +-- +-- TODO | - Factor out the buffer-building logic +-- - Rewrite the docs... +fromIndices :: Vector v -> (Vector v -> i -> b) -> (a -> i) -> Vector a -> Vector b +fromIndices data' index choose = V.map (index data' . choose) + + +-- | +-- . fromIntegral . subtract 1 +-- . (^.indices) +fromFaceIndices :: Integral i => Vector (v f) -> (Vector (v f) -> a -> b) -> (VertexIndices i -> a) -> Vector (Face f Text i Vector) -> Vector b +fromFaceIndices data' index choose = V.concatMap (fromIndices data' index (choose) . (^.indices)) + + +-- | +diffuseColours :: Vector (Face f s i Vector) -> Vector (Colour f) +diffuseColours faces' = V.concatMap (\f -> V.replicate (V.length $ f^.indices) (f^.material.diffuse)) faces' + +-- Model queries --------------------------------------------------------------------------------------------------------------------------- + +-- | Does the model have textures? +hasTextures :: Ord s => Model f s i m -> Bool +hasTextures = not . S.null . textures + + +-- | The set of all texture names +textures :: Ord s => Model f s i m -> S.Set s +textures = S.fromList . catMaybes . map (^.texture) . concatMap M.elems . M.elems . (^.materials) diff --git a/src/Graphics/WaveFront/Parse.hs b/src/Graphics/WaveFront/Parse.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/WaveFront/Parse.hs @@ -0,0 +1,87 @@ +-- | +-- Module : Graphics.WaveFront.Parse +-- Description : +-- 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 +-- -- Remove 'parse-' prefix, import qualified (eg. 'Parse.obj') +-- +-- - 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) (?) +-- -- Multi-threading +-- -- Appropriate container types +-- +-- - 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 #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NamedFieldPuns #-} + + + +-------------------------------------------------------------------------------------------------------------------------------------------- +-- API +-------------------------------------------------------------------------------------------------------------------------------------------- +-- TODO: Clean this up +module Graphics.WaveFront.Parse ( + module Graphics.WaveFront.Types, -- TODO: Don't export internal types (duh) + obj, mtl, + comment, lineSeparator +) where + + + +-------------------------------------------------------------------------------------------------------------------------------------------- +-- We'll need these +-------------------------------------------------------------------------------------------------------------------------------------------- +import Graphics.WaveFront.Parse.Common +import Graphics.WaveFront.Parse.OBJ (obj) +import Graphics.WaveFront.Parse.MTL (mtl) + +import Graphics.WaveFront.Types diff --git a/src/Graphics/WaveFront/Parse/Common.hs b/src/Graphics/WaveFront/Parse/Common.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/WaveFront/Parse/Common.hs @@ -0,0 +1,166 @@ +-- | +-- Module : Graphics.WaveFront.Parse.Common +-- Description : +-- Copyright : (c) Jonatan H Sundqvist, October 2 2016 +-- License : MIT +-- Maintainer : Jonatan H Sundqvist +-- Stability : experimental|stable +-- Portability : POSIX (not sure) + +-- TODO | - Fully polymorphic (even in the string and list types) (?) +-- - + +-- SPEC | - +-- - + + + +-------------------------------------------------------------------------------------------------------------------------------------------- +-- GHC Extensions +-------------------------------------------------------------------------------------------------------------------------------------------- +{-# LANGUAGE OverloadedStrings #-} + + + +-------------------------------------------------------------------------------------------------------------------------------------------- +-- Section +-------------------------------------------------------------------------------------------------------------------------------------------- +module Graphics.WaveFront.Parse.Common where + + + +-------------------------------------------------------------------------------------------------------------------------------------------- +-- We'll need these +-------------------------------------------------------------------------------------------------------------------------------------------- +import Data.Text (Text, pack) +import qualified Data.Attoparsec.Text as Atto + +import Control.Applicative (pure, liftA2, (<$>), (<*>), (<*), (*>), (<|>)) +import Linear (V2(..), V3(..)) + +import Graphics.WaveFront.Types + + + +-------------------------------------------------------------------------------------------------------------------------------------------- +-- Functions (pure) +-------------------------------------------------------------------------------------------------------------------------------------------- + +-- Jon's little helpers -------------------------------------------------------------------------------------------------------------------- + +-- | Consumes all input, including any leading or trailing comments and whitespace +-- TODO | - Rename (?) +wholeFile :: Atto.Parser a -> Atto.Parser a +wholeFile p = cutToTheChase *> p <* cutToTheChase <* Atto.endOfInput + + +-- | Skips any leading comments, line breaks and empty lines +-- TODO | - Rename (?) +-- - Skip whitespace +cutToTheChase :: Atto.Parser () +cutToTheChase = Atto.skipMany ((comment *> pure ()) <|> (Atto.satisfy isLinearSpace *> pure ()) <|> Atto.endOfLine) + + +-- | OBJ rows may be separated by one or more lines of comments and whitespace, or empty lines. +-- TODO | - Make sure this is right +lineSeparator :: Atto.Parser () +lineSeparator = Atto.skipMany1 $ ignore space *> ignore comment *> Atto.endOfLine + + +-- | Parses a comment (from the '#' to end of the line), possibly preceded by whitespace +-- TODO | - Break out the whitespace part (?) +comment :: Atto.Parser Text +comment = Atto.skipSpace *> Atto.char '#' *> Atto.takeTill (\c -> (c == '\r') || (c == '\n')) -- TODO: Is the newline consumed (?) + + +-- | Tries the given parser, falls back to 'Nothing' if it fails +-- TODO | - Use 'try' to enforce backtracking (?) +optional :: Atto.Parser a -> Atto.Parser (Maybe a) +optional p = Atto.option Nothing (Just <$> p) + + +-- | Like Atto.skipMany, except it skips one match at the most +ignore :: Atto.Parser a -> Atto.Parser () +ignore p = optional p *> pure () + + +-- | +atleast :: Int -> Atto.Parser a -> Atto.Parser [a] +atleast n p = liftA2 (++) (Atto.count n p) (Atto.many' p) + + +-- | Skips atleast one white space character (not including newlines and carriage returns) +space :: Atto.Parser () +space = Atto.skipMany1 (Atto.satisfy isLinearSpace) + + +-- | Predicate for linear space (eg. whitespace besides newlines) +-- TODO | - Unicode awareness (cf. Data.Char.isSpace) +-- - Come up with a better name (?) +isLinearSpace :: Char -> Bool +isLinearSpace c = (c == ' ') || (c == '\t') + + +-- | One or more letters (cf. 'Atto.letter' for details) +word :: Atto.Parser Text +word = pack <$> Atto.many1 Atto.letter + + +-- | Used for texture, material, object and group names (and maybe others that I have yet to think of) +-- TODO | - Use Unicode groups, make more robust (?) +name :: Atto.Parser Text +name = pack <$> Atto.many1 (Atto.satisfy $ \c -> (c /= ' ') && (c /= '\t') && (c /= '\r') && (c /= '\n')) + + +-- | Parses the strings "off" (False) and "on" (True) +toggle :: Atto.Parser Bool +toggle = (Atto.string "off" *> pure False) <|> (Atto.string "on" *> pure True) + + +-- | Wraps a parser in a '(' and a ')', with no whitespace in between +parenthesised :: Atto.Parser a -> Atto.Parser a +parenthesised p = Atto.char '(' *> p <* Atto.char ')' + + +-- TODO | - Allow scientific notation (?) + +-- | +coord :: Fractional f => Atto.Parser f +coord = space *> (parenthesised Atto.rational <|> Atto.rational) + + +-- | A single colour channel +-- TODO | - Clamp to [0,1] (cf. partial from monadplus) (?) +-- - Can channels be parenthesised (?) +channel :: Fractional f => Atto.Parser f +channel = space *> (parenthesised Atto.rational <|> Atto.rational) + + +-- | A colour with three or four channels (RGB[A]) +colour :: Fractional f => Atto.Parser (Colour f) +colour = Colour <$> channel <*> channel <*> channel <*> Atto.option 1 channel + + +-- | A point in 3D space +point3D :: Fractional f => Atto.Parser (V3 f) +point3D = V3 <$> coord <*> coord <*> coord + + +-- | A point in 2D space +point2D :: Fractional f => Atto.Parser (V2 f) +point2D = V2 <$> coord <*> coord + + +-- | +clamp :: Ord n => n -> n -> n -> Atto.Parser n +clamp lower upper n + | between lower upper n = pure n + | otherwise = fail "Number not in range" + where + between lw up n = (lower <= n) && (n <= upper) + -- between 0 <. n <. 5 + +-- | +-- TODO | - Clean up and generalise +clamped :: Integral i => i -> i -> Atto.Parser i +clamped lower upper = Atto.decimal >>= clamp lower upper diff --git a/src/Graphics/WaveFront/Parse/MTL.hs b/src/Graphics/WaveFront/Parse/MTL.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/WaveFront/Parse/MTL.hs @@ -0,0 +1,142 @@ +-- | +-- Module : Graphics.WaveFront.Parse.MTL +-- Description : +-- Copyright : (c) Jonatan H Sundqvist, October 2 2016 +-- License : MIT +-- Maintainer : Jonatan H Sundqvist +-- Stability : experimental|stable +-- Portability : POSIX (not sure) + +-- TODO | - +-- - + +-- SPEC | - +-- - + + + +-------------------------------------------------------------------------------------------------------------------------------------------- +-- GHC Extensions +-------------------------------------------------------------------------------------------------------------------------------------------- +{-# LANGUAGE UnicodeSyntax #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NamedFieldPuns #-} + + + +-------------------------------------------------------------------------------------------------------------------------------------------- +-- API +-------------------------------------------------------------------------------------------------------------------------------------------- +module Graphics.WaveFront.Parse.MTL ( + mtl, row, token, + ambient, diffuse, specular, + mapDiffuse, newMaterial +) where + + + +-------------------------------------------------------------------------------------------------------------------------------------------- +-- We'll need these +-------------------------------------------------------------------------------------------------------------------------------------------- +-- import qualified Data.Map as M +-- import qualified Data.Set as S +-- import qualified Data.Vector as V +import Data.Text (Text) + +import qualified Data.Attoparsec.Text as Atto + +import Control.Applicative ((<$>), (<*), (*>), (<|>)) + +import Graphics.WaveFront.Parse.Common + +import Graphics.WaveFront.Types hiding (ambient, diffuse, specular) + + + +-------------------------------------------------------------------------------------------------------------------------------------------- +-- Functions +-------------------------------------------------------------------------------------------------------------------------------------------- + +-- MTL parsing ----------------------------------------------------------------------------------------------------------------------------- + +-- | Produces a list of MTL tokens +mtl :: (Fractional f) => Atto.Parser (MTL f Text []) +mtl = Atto.sepBy row lineSeparator + + +-- | Parses a single MTL row. +row :: (Fractional f) => Atto.Parser (MTLToken f Text) +row = token <* ignore comment + +-------------------------------------------------------------------------------------------------------------------------------------------- + +-- | Parse an MTL token +-- TODO: How to deal with common prefix (Ka, Kd, Ks) (backtrack?) +token :: (Fractional f) => Atto.Parser (MTLToken f Text) +token = (Atto.string "Ka" *> ambient) <|> + (Atto.string "Kd" *> diffuse) <|> + (Atto.string "Ks" *> specular) <|> + (Atto.string "Ns" *> specExp) <|> + (Atto.string "illum" *> illum) <|> + (Atto.string "Ni" *> refraction) <|> + (Atto.string "d" *> dissolve) <|> -- TODO: Handle inverse as well (cf. 'Tr' attribute) + (Atto.string "map_Kd" *> mapDiffuse) <|> + (Atto.string "map_Ka" *> mapAmbient) <|> + (Atto.string "newmtl" *> newMaterial) + +-------------------------------------------------------------------------------------------------------------------------------------------- + +-- TODO: Expose these parsers for testing purposes (?) + +-- TODO | - Change definition of 'colour' and 'Colour' to only allow three channels (alpha is handled by the 'dissolve' attribute) +-- - Change the definition of 'Colour' or use the one defined in the colour package + +-- | Three or four channel values (RGB[A]) +ambient :: (Fractional f) => Atto.Parser (MTLToken f s) +ambient = Ambient <$> colour + + +-- | Three or four channel values (RGB[A]) +diffuse :: (Fractional f) => Atto.Parser (MTLToken f s) +diffuse = Diffuse <$> colour + + +-- | Three or four channel values (RGB[A]) +specular :: (Fractional f) => Atto.Parser (MTLToken f s) +specular = Specular <$> colour + + +-- | A rational number, preceded by whitespace (specular exponent) +specExp :: (Fractional f) => Atto.Parser (MTLToken f s) +specExp = space *> (SpecularExponent <$> Atto.rational) + + +-- | A number between 0 and 10 (inclusive) (illumination model) +illum :: Atto.Parser (MTLToken f s) +illum = space *> (Illum <$> clamped 0 10) + + +-- | A rational number, preceded by whitespace (refraction index) +refraction :: (Fractional f) => Atto.Parser (MTLToken f s) +refraction = space *> (Refraction <$> Atto.rational) + + +-- | A rational number, preceded by whitespace (doss) +dissolve :: (Fractional f) => Atto.Parser (MTLToken f s) +dissolve = space *> (Dissolve <$> Atto.rational) + + +-- | A texture name, preceded by whitespace +mapDiffuse :: Atto.Parser (MTLToken f Text) +mapDiffuse = space *> (MapDiffuse <$> name) + + +-- | A texture name, preceded by whitespace +mapAmbient :: Atto.Parser (MTLToken f Text) +mapAmbient = space *> (MapAmbient <$> name) + + +-- | A material name, preceded by whitespace +newMaterial :: Atto.Parser (MTLToken f Text) +newMaterial = space *> (NewMaterial <$> name) diff --git a/src/Graphics/WaveFront/Parse/OBJ.hs b/src/Graphics/WaveFront/Parse/OBJ.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/WaveFront/Parse/OBJ.hs @@ -0,0 +1,172 @@ +-- | +-- Module : Graphics.WaveFront.Parse.OBJ +-- Description : +-- Copyright : (c) Jonatan H Sundqvist, October 2 2016 +-- License : MIT +-- Maintainer : Jonatan H Sundqvist +-- Stability : experimental|stable +-- Portability : POSIX (not sure) + +-- TODO | - Fully polymorphic (even in the string and list types) (?) +-- - + +-- SPEC | - +-- - + + + +-------------------------------------------------------------------------------------------------------------------------------------------- +-- GHC Extensions +-------------------------------------------------------------------------------------------------------------------------------------------- +{-# LANGUAGE UnicodeSyntax #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NamedFieldPuns #-} + + + +-------------------------------------------------------------------------------------------------------------------------------------------- +-- API +-------------------------------------------------------------------------------------------------------------------------------------------- +module Graphics.WaveFront.Parse.OBJ ( + obj, row, face, + normal, texture, vertex, object, group, + lib, use, + vertexIndices, +) where + + + +-------------------------------------------------------------------------------------------------------------------------------------------- +-- We'll need these +-------------------------------------------------------------------------------------------------------------------------------------------- +import Data.Text (Text) +-- import qualified Data.Vector as V +import qualified Data.Set as S + +import qualified Data.Attoparsec.Text as Atto + +import Control.Applicative ((<$>), (<*>), (<*), (*>), (<|>)) + +-- import Linear (V2(..), V3(..)) + +import Graphics.WaveFront.Parse.Common +import Graphics.WaveFront.Types hiding (texture) + + + +-------------------------------------------------------------------------------------------------------------------------------------------- +-- Functions +-------------------------------------------------------------------------------------------------------------------------------------------- + +-- OBJ parsing ----------------------------------------------------------------------------------------------------------------------------- + +-- | This function creates an OBJToken or error for each line in the input data +obj :: (Fractional f, Integral i) => Atto.Parser (OBJ f Text i []) +obj = Atto.sepBy row lineSeparator -- <* Atto.endOfInput + + +-- | Parses a token given a single valid OBJ row +-- +-- TODO | - Correctness (total function, no runtime exceptions) +-- - Handle invalid rows (how to deal with mangled definitions w.r.t indices?) +-- - Use ListLike or Monoid (or maybe Indexable, since that's the real requirement) (?) +row :: (Fractional f, Integral i) => Atto.Parser (OBJToken f Text i []) +row = token <* ignore comment -- TODO: Let the separator handle comments (?) + + +-- | +-- Parses an OBJ token +token :: (Fractional f, Integral i) => Atto.Parser (OBJToken f Text i []) +token = (Atto.string "f" *> face) <|> + (Atto.string "l" *> line) <|> + -- TODO: How to deal with common prefix (v, vn, vt) (backtrack?) (doesn't seem to be a problem) + (Atto.string "vn" *> normal) <|> + (Atto.string "vt" *> texture) <|> + (Atto.string "v" *> vertex) <|> + (Atto.string "o" *> object) <|> + (Atto.string "g" *> group) <|> + (Atto.string "s" *> smooth) <|> + (Atto.string "mtllib" *> lib) <|> + (Atto.string "usemtl" *> use) + + +-- TODO: Expose these parsers for testing purposes (?) + +-------------------------------------------------------------------------------------------------------------------------------------------- + +-- | Three or more vertex definitions (cf. 'vertexIndices' for details) +face :: Integral i => Atto.Parser (OBJToken f Text i []) +face = OBJFace <$> vertexIndices + + +-- | A single vertex definition with indices for vertex position, normal, and texture coordinates +-- +-- TODO: | - Should the slashes be optional? +-- - Allowed trailing slashes (I'll have to check the spec again) (?) +-- +-- f Int[/((Int[/Int])|(/Int))] +vertexIndices :: Integral i => Atto.Parser [VertexIndices i] +vertexIndices = atleast 3 (space *> (ivertex <*> index <*> index)) <|> -- vi/ti/ni + atleast 3 (space *> (ivertex <*> nothing <*> skipIndex)) <|> -- vi//ni + atleast 3 (space *> (ivertex <*> index <*> nothing)) <|> -- vi/ti + atleast 3 (space *> (ivertex <*> nothing <*> nothing)) -- vi + where + ivertex :: Integral i => Atto.Parser (Maybe i -> Maybe i -> VertexIndices i) + ivertex = VertexIndices <$> Atto.decimal + + index :: Integral i => Atto.Parser (Maybe i) + index = Just <$> (Atto.char '/' *> Atto.decimal) + + skipIndex :: Integral i => Atto.Parser (Maybe i) + skipIndex = Atto.char '/' *> index + + nothing :: Atto.Parser (Maybe i) + nothing = pure Nothing + +-- Geometry primitives --------------------------------------------------------------------------------------------------------------------- + +-- | Two integers, separated by whitespace +line :: Integral i => Atto.Parser (OBJToken f Text i m) +line = Line <$> (space *> Atto.decimal) <*> (space *> Atto.decimal) + +-------------------------------------------------------------------------------------------------------------------------------------------- + +-- | Three cordinates, separated by whitespace +normal :: (Fractional f) => Atto.Parser (OBJToken f Text i m) +normal = OBJNormal <$> point3D + + +-- | Two coordinates, separated by whitespace +texture :: (Fractional f) => Atto.Parser (OBJToken f Text i m) +texture = OBJTexCoord <$> point2D + + +-- | Three coordinates, separated by whitespace +vertex :: (Fractional f) => Atto.Parser (OBJToken f s i m) +vertex = OBJVertex <$> point3D + + +-- | Object names, separated by whitespace +object :: Atto.Parser (OBJToken f Text i m) +object = Object . S.fromList <$> atleast 1 (space *> name) + + +-- | Group names, separated by whitespace +group :: Atto.Parser (OBJToken f Text i m) +group = Group . S.fromList <$> atleast 1 (space *> name) + + +-- | Either 'on' or 'off' +smooth :: Atto.Parser (OBJToken f s i m) +smooth = SmoothShading <$> (space *> toggle) + + +-- | An MTL library name +lib :: Atto.Parser (OBJToken f Text i m) +lib = LibMTL <$> (space *> name) + + +-- | An MTL material name +use :: Atto.Parser (OBJToken f Text i m) +use = UseMTL <$> (space *> name) diff --git a/src/Graphics/WaveFront/Parsers.hs b/src/Graphics/WaveFront/Parsers.hs deleted file mode 100644 --- a/src/Graphics/WaveFront/Parsers.hs +++ /dev/null @@ -1,358 +0,0 @@ --- | --- Module : Graphics.WaveFront.Parsers --- Description : --- 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) (?) --- -- Multi-threading --- -- Appropriate container types --- --- - 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, - module Graphics.WaveFront.Types, - BoundingBox(..), Vector(..), - 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 Control.Lens hiding (indices) - --- import Southpaw.Utilities.Utilities (pairwise, cuts) - -import Cartesian.Space.Types (BoundingBox(..), Vector3D(..)) - -import Graphics.WaveFront.Types -import Graphics.WaveFront.Utilities - - - --------------------------------------------------------------------------------------------------------------------------------------------- --- 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 . (^._3) . 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. (use applicative?) --- 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 (^._2) 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 } - - --- | 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 :: - - --- | --- TODO: Deal with empty vertex lists (?) --- boundingbox :: (RealFloat n, Ord n) => Model -> BoundingBox (Vector3D n) -boundingbox :: Model -> BoundingBox (Vector3D Float) -boundingbox model = BoundingBox { centreOf=Vector3D (minx+maxx) (miny+maxy) (minz+maxz) * Vector3D 0.5 0 0, sizeOf=Vector3D (maxx-minx) (maxy-miny) (maxz-minz) } - where - minmax :: (Ord o) => [o] -> (o, o) - minmax (v:alues) = foldr (\val acc -> (min val (fst acc), max val (snd acc))) (v, v) alues -- TODO: Factor out - - [(minx, maxx), (miny, maxy), (minz, maxz)] = [ minmax . map (^.f) $ vertices model | f <- [_1, _2, _3]] -- 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 diff --git a/src/Graphics/WaveFront/Types.hs b/src/Graphics/WaveFront/Types.hs --- a/src/Graphics/WaveFront/Types.hs +++ b/src/Graphics/WaveFront/Types.hs @@ -21,7 +21,12 @@ -------------------------------------------------------------------------------------------------------------------------------------------- -- GHC Pragmas -------------------------------------------------------------------------------------------------------------------------------------------- - +{-# LANGUAGE DuplicateRecordFields #-} -- I love GHC 8.0 +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE DeriveFoldable #-} @@ -35,8 +40,10 @@ -------------------------------------------------------------------------------------------------------------------------------------------- -- We'll need these -------------------------------------------------------------------------------------------------------------------------------------------- -import qualified Data.Map as Map -import Foreign.Storable +import Data.Functor.Classes (Show1) --Eq1, Show1, showsPrec1, eq1) +import Data.Map as M +import Data.Set as S (Set) +import Linear (V2(..), V3(..)) @@ -45,161 +52,203 @@ -------------------------------------------------------------------------------------------------------------------------------------------- -- OBJ parser types ------------------------------------------------------------------------------------------------------------------------ + +-- TODO | - Add strictness annotations (?) + + -- | 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 +-- TODO | - Polymorphic numerical types (?) +-- - Add context, metadata (eg. line numbers, filename) (?) +-- - Naming scheme (added OBJ prefix to prevent name clashes; cf. Face type) +-- - Comment token (preserve comments in parser output or remove them) (?) +-- +-- - Cover the entire spec (http://www.martinreddy.net/gfx/3d/OBJ.spec) +-- (and handle unimplemented attributes gracefully) +data OBJToken f s i m = OBJVertex (V3 f) | + OBJNormal (V3 f) | + OBJTexCoord (V2 f) | + OBJFace (m (VertexIndices i)) | -- TODO: Associate material with each face, handle absent indices - UseMTL String | -- - LibMTL String | -- TODO: Use actual MTL type + Line i i | -- Line (I'm assuming the arguments are indices to the endpoint vertices) - 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 (?) + UseMTL s | -- TODO: Rename (eg. 'UseMaterial') (?) + LibMTL s | -- + SmoothShading Bool | -- s --- | --- TODO: Rename (?) -data OBJNoParse = OBJComment String | OBJEmpty | OBJNoSuchAttribute String | OBJNoParse String deriving (Show) + -- TODO: Use OBJ prefix (?) + Group (Set s) | -- TODO: Do grouped faces have to be consecutive? + Object (Set s) -- TODO: What is the difference between group and object? + -- deriving (Show, Eq) -- TODO: Derive Read (?) + -- | --- 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) +-- TODO: Rename (?) +-- TODO: Use union instead of Maybe (?) +data VertexIndices i = VertexIndices { + fIvertex :: i, + fItexcoord :: Maybe i, + fInormal :: Maybe i +} deriving (Show, Eq) --- | Output type of the OBJ parser. Currently a list of line number and token (or error string) pairs +-- | Output type of the OBJ parser. -- --- TODO: Rename (?) --- TODO: Use Integral for line number (?) +-- TODO | - Rename (?) +-- - Use Integral for line number (?) -- -type OBJ = [OBJRow] +type OBJ f s i m = m (OBJToken f s i m) -- 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 +-- TODO | - Is the alpha channel optional, ignored, disallowed? +-- - Include support for ('Ns', 'Ni', 'd', 'Tr', 'illum') +-- - Assume no colours have an alpha channel, since transparency is handled by the 'd' attribute (?) +data MTLToken f s = Ambient (Colour f) | -- Ka + Diffuse (Colour f) | -- Kd + Specular (Colour f) | -- Ks - MapDiffuse String | -- map_Kd - NewMaterial String -- newmtl - deriving (Eq, Show) + SpecularExponent f | -- Ns (TODO: Find out exactly what this entails) + Illum Illumination | -- illum (TODO: Find out what this means) --- | --- TODO: Rename (?) -data MTLNoParse = MTLComment String | MTLEmpty | MTLNoSuchAttribute String | MTLNoParse String deriving (Show) + Dissolve f | -- d (Dissolve; transparency) + Refraction f | -- Ni (Index of refraction; optical_density) + MapDiffuse s | -- map_Kd + MapAmbient s | -- map_Ka + NewMaterial s -- newmtl + deriving (Show, Eq) --- | Output type of the single-row MTL parser. -type MTLRow = (Int, Either MTLNoParse MTLToken, String) +-- | +-- 0. Color on and Ambient off +-- 1. Color on and Ambient on +-- 2. Highlight on +-- 3. Reflection on and Ray trace on +-- 4. Transparency: Glass on, Reflection: Ray trace on +-- 5. Reflection: Fresnel on and Ray trace on +-- 6. Transparency: Refraction on, Reflection: Fresnel off and Ray trace on +-- 7. Transparency: Refraction on, Reflection: Fresnel on and Ray trace on +-- 8. Reflection on and Ray trace off +-- 9. Transparency: Glass on, Reflection: Ray trace off +-- 10. Casts shadows onto invisible surfaces +type Illumination = Int + -- | 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) +-- TODO | - Add type for processed MTL (eg. a map between names and materials) +type MTL f s m = m (MTLToken f s) -- (line number, MTL token, comment) -- | -type MTLTable = Map.Map String (Map.Map String Material) +type MTLTable f s = M.Map s (M.Map s (Material f s)) -- Model ----------------------------------------------------------------------------------------------------------------------------------- --- | --- 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] - --- General types --------------------------------------------------------------------------------------------------------------------------- - -type Vector num = (num, num, num) -- Queen Vectoria -type Point num = (num, num) -- Haskell is no longer Point-free +type Vertices f m = m (V3 f) +type TexCoords f m = m (Maybe (V2 f)) +type Normals f m = m (Maybe (V3 f)) +type Materials f s m = m (Material f s) -- 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) +-- TODO | - Validation (eg. length ivertices == length == ivertices == length itextures if length isn't 0) +-- - Pack indices in a tuple (eg. indices :: [(Int, Int, Int)]) (?) +-- - Use (String, String) for the names of the mtl file and material instead of Material (?) +-- - Use types so as not to confuse the indices (eg. newtype INormal, newtype ITexcoord) +data Face f s i m = Face { + fIndices :: m (VertexIndices i), + fMaterial :: Material f s +} --deriving (Show, Eq) -- | -type Colour = (Float, Float, Float, Float) +-- TODO | - Use a type from the colour package instead (?) +data Colour f = Colour { + fRed :: f, + fGreen :: f, + fBlue :: f, + fAlpha :: f +} deriving (Show, Eq, Functor, Foldable) -- | --- 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) +-- TODO | - Do all materials have an ambient, a diffuse and a specular colour (?) +-- - Support more attributes (entire spec) (?) +-- - Lenses (?) +data Material f s = Material { + fAmbient :: Colour f, + fDiffuse :: Colour f, + fSpecular :: Colour f, + fTexture :: Maybe s +} deriving (Show, Eq) -- | 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) (?) +-- TODO | - Rename (?) +-- - Include metadata, comments, rejected data (?) +-- - Separate type for processed OBJTokens (ie. token + context) +-- - Perform index lookups (?) +-- - Reconsider the types (especially of the materials) +-- - 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) +-- fTextures :: Set s, +-- data Model f s i m = Model { +data Model f s i m = Model { + fVertices :: m (V3 f), + fNormals :: m (V3 f), + fTexcoords :: m (V2 f), + fFaces :: m (Face f s i m), + fMaterials :: MTLTable f s, -- TODO: Type synonym (?) + fGroups :: M.Map (Set s) (i, i), -- TODO: Type synonym + fObjects :: M.Map (Set s) (i, i), -- TODO: Type synonym + fRoot :: Maybe FilePath -- This is where we should look for related assets +} -- deriving (Show, Eq) --- Foreign --------------------------------------------------------------------------------------------------------------------------------- +-- Monomorphic defaults -------------------------------------------------------------------------------------------------------------------- --- | -newtype COBJ = COBJ OBJ +-- Instances ------------------------------------------------------------------------------------------------------------------------------- --- | -newtype CMTL = CMTL MTL +-- TODO: Use Show1, Eq1, etc. (?) +-- deriving instance (Show1 m) => Show1 (m a) +-- deriving instance (Show1 m) => Show1 (m a) +-- deriving instance (Show1 m) => Show1 (m a) +-- TODO: Clean this up --- | We -instance Storable COBJ where - sizeOf = const 0 - alignment = const 0 - peek _ = error "Work in progress" - poke _ = error "Work in progress" +-- showsPrec1 :: (Show1 f, Show a) => Int -> f a -> ShowS +deriving instance (Show1 m, + Show (m f), + Show (m (V2 f)), + Show (m (V3 f)), + Show (m (Face f s i m)), + Show (m s), + Show f, + Show s, + Show i) => Show (Model f s i m) -- where showsPrec = showsPrec1 +deriving instance (Show1 m, + Show (m f), + Show (m (VertexIndices i)), + Show (m (V3 f)), + Show (m s), + Show f, + Show s, + Show i) => Show (Face f s i m) -- where showsPrec = _ --- | We -instance Storable CMTL where - sizeOf = const 0 - alignment = const 0 - peek _ = error "Work in progress" - poke _ = error "Work in progress" +deriving instance (Show1 m, + Show (m f), + Show (m (VertexIndices i)), + Show (m (V3 f)), + Show (m s), + Show f, + Show s, + Show i) => Show (OBJToken f s i m) -- where showsPrec = _ diff --git a/src/Graphics/WaveFront/Utilities.hs b/src/Graphics/WaveFront/Utilities.hs deleted file mode 100644 --- a/src/Graphics/WaveFront/Utilities.hs +++ /dev/null @@ -1,116 +0,0 @@ --- | --- 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 :: [a -> Bool] -> a -> Bool - satisfiesAny ps x = any ($ x) ps - - --- | --- 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" - --- 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)