diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Alexis Williams (c) 2016 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Alexis Williams nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/src/Data/WavefrontObj.hs b/src/Data/WavefrontObj.hs new file mode 100644 --- /dev/null +++ b/src/Data/WavefrontObj.hs @@ -0,0 +1,34 @@ +{-| +Module : Data.WavefrontObj +Description : Wavefront .obj 3D model loading microlibrary. +Copyright : (c) Alexis Williams 2016 +License : BSD3 +Maintainer : sasinestro@gmail.com +Stability : experimental +A (very) minimal microlibrary to load 3D geometry from Wavefront .obj files. +-} +module Data.WavefrontObj ( + -- * Types + WavefrontVertex(..) + , WavefrontFace'(..), WavefrontFace + , WavefrontModel'(..), WavefrontModel + -- * Interface + , parseWavefrontObj, loadWavefrontObj + ) where + +import qualified Data.Text as T +import qualified Data.Text.IO as T +import Data.WavefrontObj.Parsers +import Data.WavefrontObj.Types + +{-| + Takes a 'Text' and gives you either an error message or a 'WavefrontModel' containing the geometry data from the input. +-} +parseWavefrontObj :: T.Text -> (Either String WavefrontModel) +parseWavefrontObj = runWavefrontParser objFileParser + +{-| + A convienence function for the common case of loading a model from a text file on disk. +-} +loadWavefrontObj :: FilePath -> IO (Either String WavefrontModel) +loadWavefrontObj = fmap parseWavefrontObj . T.readFile diff --git a/src/Data/WavefrontObj/Parsers.hs b/src/Data/WavefrontObj/Parsers.hs new file mode 100644 --- /dev/null +++ b/src/Data/WavefrontObj/Parsers.hs @@ -0,0 +1,101 @@ +{-# LANGUAGE OverloadedStrings #-} +module Data.WavefrontObj.Parsers (vertexPointParser, textureCoordParser, vertexNormalParser, faceParser, objFileParser) where + +import Control.Applicative +import Control.Monad.Trans.Class +import Data.Attoparsec.Text +import Data.Maybe +import Data.WavefrontObj.Types +import Linear +import Linear.Affine + +vertexPointParser :: WavefrontParser () +vertexPointParser = do + lift $ char 'v' + lift skipSpace + x <- lift double + lift skipSpace + y <- lift double + lift skipSpace + z <- lift double + lift (skipWhile $ not . isEndOfLine) + appendVertexPoint $ P (V3 x y z) + +textureCoordParser :: WavefrontParser () +textureCoordParser = do + lift $ string "vt" + lift skipSpace + u <- lift double + lift skipSpace + v <- lift double + lift (skipWhile $ not . isEndOfLine) + appendTextureCoordinate $ P (V2 u v) + +vertexNormalParser :: WavefrontParser () +vertexNormalParser = do + lift $ string "vn" + lift skipSpace + x <- lift double + lift skipSpace + y <- lift double + lift skipSpace + z <- lift double + lift (skipWhile $ not . isEndOfLine) + appendVertexNormal $ V3 x y z + +faceParser :: WavefrontParser WavefrontFace +faceParser = do + lift $ char 'f' + lift $ skipSpace + vertices <- (vertexWithPointTextureCoordNormal <|> vertexWithPointNormal <|> vertexWithPointTextureCoord <|> vertexWithPoint) `sepBy` lift space + lift (skipWhile $ not . isEndOfLine) + return $ WavefrontFace vertices + where + vertexWithPoint :: WavefrontParser WavefrontVertex + vertexWithPoint = do + vertexPointIdx <- lift $ signed decimal + + vertexPoint <- getVertexPoint vertexPointIdx + return $ WavefrontVertex vertexPoint Nothing Nothing + vertexWithPointTextureCoord :: WavefrontParser WavefrontVertex + vertexWithPointTextureCoord = do + vertexPointIdx <- lift (signed decimal) + lift $ char '/' + textureCoordinateIdx <- lift (signed decimal) + + vertexPoint <- getVertexPoint vertexPointIdx + textureCoordinate <- getTextureCoordinate textureCoordinateIdx + return $ WavefrontVertex vertexPoint (Just textureCoordinate) Nothing + vertexWithPointNormal :: WavefrontParser WavefrontVertex + vertexWithPointNormal = do + vertexPointIdx <- lift (signed decimal) + lift $ string "//" + vertexNormalIdx <- lift (signed decimal) + + vertexPoint <- getVertexPoint vertexPointIdx + vertexNormal <- getVertexNormal vertexNormalIdx + return $ WavefrontVertex vertexPoint Nothing (Just vertexNormal) + vertexWithPointTextureCoordNormal :: WavefrontParser WavefrontVertex + vertexWithPointTextureCoordNormal = do + vertexPointIdx <- lift (signed decimal) + lift $ char '/' + textureCoordinateIdx <- lift (signed decimal) + lift $ char '/' + vertexNormalIdx <- lift (signed decimal) + + vertexPoint <- getVertexPoint vertexPointIdx + textureCoordinate <- getTextureCoordinate textureCoordinateIdx + vertexNormal <- getVertexNormal vertexNormalIdx + return $ WavefrontVertex vertexPoint (Just textureCoordinate) (Just vertexNormal) + +objFileParser :: WavefrontParser WavefrontModel +objFileParser = do + faces <- ((vertexPointParser *> pure Nothing) + <|> (textureCoordParser *> pure Nothing) + <|> (vertexNormalParser *> pure Nothing) + <|> (commentParser *> pure Nothing) + <|> (Just <$> faceParser)) + `sepBy` (lift $ some endOfLine) + return $ WavefrontModel (catMaybes faces) + where + commentParser = lift $ char '#' *> (skipWhile $ not . isEndOfLine) diff --git a/src/Data/WavefrontObj/Types.hs b/src/Data/WavefrontObj/Types.hs new file mode 100644 --- /dev/null +++ b/src/Data/WavefrontObj/Types.hs @@ -0,0 +1,122 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module Data.WavefrontObj.Types ( + WavefrontParser + , runWavefrontParser + , debugWavefrontParser + , WavefrontVertex(..) + , WavefrontFace'(..) + , WavefrontFace + , WavefrontModel'(..) + , WavefrontModel + , getVertexPoint + , appendVertexPoint + , getTextureCoordinate + , appendTextureCoordinate + , getVertexNormal + , appendVertexNormal + ) where + +import Control.Applicative +import Control.Monad.Trans.State.Strict +import Data.Attoparsec.Text +import Data.Sequence ((|>)) +import qualified Data.Sequence as S +import qualified Data.Text as T +import Linear.Affine +import Linear.V2 +import Linear.V3 + +type WavefrontParser a = StateT WavefrontState Parser a + +runWavefrontParser :: WavefrontParser a -> T.Text -> Either String a +runWavefrontParser p = parseOnly (evalStateT p emptyWavefrontState) + +debugWavefrontParser :: WavefrontParser a -> T.Text -> Either String (a, WavefrontState) +debugWavefrontParser p = parseOnly (runStateT p emptyWavefrontState) + +data WavefrontState = WavefrontState { + _vertexPoints :: !(S.Seq (Point V3 Double)) + , _textureCoordinates :: !(S.Seq (Point V2 Double)) + , _vertexNormals :: !(S.Seq (V3 Double)) + } + deriving (Show, Eq) + +emptyWavefrontState :: WavefrontState +emptyWavefrontState = WavefrontState (S.empty) (S.empty) (S.empty) + +{-| + Contains the data for an individual vertex, with the world-space coordinate, (optional) texture-space coordinate, and the (optional) precalculated normal vector. + + TODO: Add an option to add normals for models without them(?). +-} +data WavefrontVertex = WavefrontVertex { + _vertexPoint :: !(Point V3 Double) + , _textureCoordinate :: !(Maybe (Point V2 Double)) + , _vertexNormal :: !(Maybe (V3 Double)) + } + deriving (Show, Eq) + +-- | The underlying datatype to store the vertices for a face. +newtype WavefrontFace' a = WavefrontFace [a] + deriving (Show, Eq, Functor, Foldable) + +-- | An alias to make the the type signatures look nicer while still allowing the instances that you would want (without pulling in mono-traversable). +type WavefrontFace = WavefrontFace' WavefrontVertex + +-- | Models are not exactly complicated in this system, just a list of faces. +newtype WavefrontModel' a = WavefrontModel [a] + deriving (Show, Eq, Functor, Foldable) + +-- | Another alias to beautify type signatures. +type WavefrontModel = WavefrontModel' WavefrontFace + +-- + +getVertexPoint :: (Monad m) => Int -> StateT WavefrontState m (Point V3 Double) +getVertexPoint idx' = do + vertexPoints <- _vertexPoints <$> get + let idx = if idx' > 0 + then idx' + else idx' + (S.length vertexPoints) + 1 + if (idx > S.length vertexPoints) || (idx <= 0) + then fail $ "Invalid model! Vertex point at index " ++ show idx' ++ " doesn't exist." + else return $ S.index vertexPoints (idx - 1) + +appendVertexPoint :: (Monad m) => Point V3 Double -> StateT WavefrontState m () +appendVertexPoint p = do + curState <- get + put $ curState { _vertexPoints = (_vertexPoints curState) |> p } + +-- + +getTextureCoordinate :: (Monad m) => Int -> StateT WavefrontState m (Point V2 Double) +getTextureCoordinate idx' = do + textureCoordinates <- _textureCoordinates <$> get + let idx = if idx' > 0 + then idx' + else idx' + (S.length textureCoordinates) + 1 + if (idx > S.length textureCoordinates) || (idx <= 0) + then fail $ "Invalid model! Texture coordinate at index " ++ show idx' ++ " doesn't exist." + else return $ S.index textureCoordinates (idx - 1) + +appendTextureCoordinate :: (Monad m) => Point V2 Double -> StateT WavefrontState m () +appendTextureCoordinate t = do + curState <- get + put $ curState { _textureCoordinates = (_textureCoordinates curState) |> t } + +-- + +getVertexNormal :: (Monad m) => Int -> StateT WavefrontState m (V3 Double) +getVertexNormal idx' = do + vertexNormals <- _vertexNormals <$> get + let idx = if idx' > 0 + then idx' + else idx' + (S.length vertexNormals) + 1 + if (idx > S.length vertexNormals) || (idx <= 0) + then fail $ "Invalid model! Vertex normal at index " ++ show idx' ++ " doesn't exist." + else return $ S.index vertexNormals (idx - 1) + +appendVertexNormal :: (Monad m) => V3 Double -> StateT WavefrontState m () +appendVertexNormal n = do + curState <- get + put $ curState { _vertexNormals = (_vertexNormals curState) |> n } diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/wavefront-obj.cabal b/wavefront-obj.cabal new file mode 100644 --- /dev/null +++ b/wavefront-obj.cabal @@ -0,0 +1,46 @@ +name: wavefront-obj +version: 0.1.0.0 +cabal-version: >=1.10 +build-type: Simple +license: BSD3 +license-file: LICENSE +copyright: Copyright: (c) 2016 Alexis Williams +maintainer: sasinestro@gmail.com +homepage: https://github.com/sasinestro/wavefront-obj#readme +synopsis: Wavefront .obj file loader +description: + See . +category: Graphics +author: Alexis Williams + +source-repository head + type: git + location: https://github.com/sasinestro/wavefront-obj + +library + exposed-modules: + Data.WavefrontObj + build-depends: + base >=4.7 && <5, + containers >=0.5.7.1 && <0.6, + text >=1.2.0.6 && <1.3, + transformers >=0.3.0.0 && <0.6, + attoparsec >=0.12.1.5 && <0.14, + linear >=1.20.5 && <1.21 + default-language: Haskell2010 + hs-source-dirs: src + other-modules: + Data.WavefrontObj.Types + Data.WavefrontObj.Parsers + +test-suite wavefront-obj-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + build-depends: + base >=4.9.0.0 && <4.10, + linear >=1.20.5 && <1.21, + wavefront-obj >=0.1.0.0 && <0.2, + hspec >=2.1.5 && <2.4 + default-language: Haskell2010 + hs-source-dirs: test + ghc-options: -threaded -rtsopts -with-rtsopts=-N