wavefront (empty) → 0.1
raw patch · 13 files changed
+532/−0 lines, 13 filesdep +attoparsecdep +basedep +dlistsetup-changed
Dependencies added: attoparsec, base, dlist, filepath, mtl, text, transformers
Files
- CHANGELOG.md +3/−0
- LICENSE +30/−0
- Setup.hs +2/−0
- src/Codec/Wavefront/Face.hs +15/−0
- src/Codec/Wavefront/IO.hs +21/−0
- src/Codec/Wavefront/Line.hs +15/−0
- src/Codec/Wavefront/Location.hs +19/−0
- src/Codec/Wavefront/Normal.hs +18/−0
- src/Codec/Wavefront/Object.hs +123/−0
- src/Codec/Wavefront/Point.hs +15/−0
- src/Codec/Wavefront/TexCoord.hs +19/−0
- src/Codec/Wavefront/Token.hs +202/−0
- wavefront.cabal +50/−0
+ CHANGELOG.md view
@@ -0,0 +1,3 @@+# 0.1++- Initial revision.
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2015, Dimitri Sabadie <dimitri.sabadie@gmail.com>++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 Dimitri Sabadie <dimitri.sabadie@gmail.com> 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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ src/Codec/Wavefront/Face.hs view
@@ -0,0 +1,15 @@+-----------------------------------------------------------------------------+-- |+-- Copyright : (C) 2015 Dimitri Sabadie+-- License : BSD3+--+-- Maintainer : Dimitri Sabadie <dimitri.sabadie@gmail.com>+-- Stability : experimental+-- Portability : portable+--+-----------------------------------------------------------------------------++module Codec.Wavefront.Face where++data Face = Face {-# UNPACK #-} !(Int,Maybe Int,Maybe Int) deriving (Eq,Show)+
+ src/Codec/Wavefront/IO.hs view
@@ -0,0 +1,21 @@+-----------------------------------------------------------------------------+-- |+-- Copyright : (C) 2015 Dimitri Sabadie+-- License : BSD3+--+-- Maintainer : Dimitri Sabadie <dimitri.sabadie@gmail.com>+-- Stability : experimental+-- Portability : portable+--+-----------------------------------------------------------------------------++module Codec.Wavefront.IO where++import Codec.Wavefront.Object ( WavefrontOBJ, lexer )+import Codec.Wavefront.Token ( tokenize )+import Control.Monad.IO.Class ( MonadIO(..) )+import qualified Data.Text.IO as T ( readFile )++-- |Extract a 'WavefrontOBJ' from a Wavefront OBJ formatted file.+fromFile :: (MonadIO m) => FilePath -> m (Either String WavefrontOBJ)+fromFile fd = liftIO $ fmap (fmap lexer . tokenize) (T.readFile fd)
+ src/Codec/Wavefront/Line.hs view
@@ -0,0 +1,15 @@+-----------------------------------------------------------------------------+-- |+-- Copyright : (C) 2015 Dimitri Sabadie+-- License : BSD3+--+-- Maintainer : Dimitri Sabadie <dimitri.sabadie@gmail.com>+-- Stability : experimental+-- Portability : portable+--+-----------------------------------------------------------------------------++module Codec.Wavefront.Line where++data Line = Line {-# UNPACK #-} !(Int,Maybe Int) deriving (Eq,Show)+
+ src/Codec/Wavefront/Location.hs view
@@ -0,0 +1,19 @@+-----------------------------------------------------------------------------+-- |+-- Copyright : (C) 2015 Dimitri Sabadie+-- License : BSD3+--+-- Maintainer : Dimitri Sabadie <dimitri.sabadie@gmail.com>+-- Stability : experimental+-- Portability : portable+--+-----------------------------------------------------------------------------++module Codec.Wavefront.Location where++data Location = Location+ {-# UNPACK #-} !Float+ {-# UNPACK #-} !Float+ {-# UNPACK #-} !Float+ {-# UNPACK #-} !Float+ deriving (Eq,Show)
+ src/Codec/Wavefront/Normal.hs view
@@ -0,0 +1,18 @@+-----------------------------------------------------------------------------+-- |+-- Copyright : (C) 2015 Dimitri Sabadie+-- License : BSD3+--+-- Maintainer : Dimitri Sabadie <dimitri.sabadie@gmail.com>+-- Stability : experimental+-- Portability : portable+--+-----------------------------------------------------------------------------++module Codec.Wavefront.Normal where++data Normal = Normal+ {-# UNPACK #-} !Float+ {-# UNPACK #-} !Float+ {-# UNPACK #-} !Float+ deriving (Eq,Show)
+ src/Codec/Wavefront/Object.hs view
@@ -0,0 +1,123 @@+-----------------------------------------------------------------------------+-- |+-- Copyright : (C) 2015 Dimitri Sabadie+-- License : BSD3+--+-- Maintainer : Dimitri Sabadie <dimitri.sabadie@gmail.com>+-- Stability : experimental+-- Portability : portable+--+-----------------------------------------------------------------------------++module Codec.Wavefront.Object (+ -- * Context and elements+ Ctxt(..)+ , emptyCtxt+ , Element(..)+ , lexer+ -- * Wavefront OBJ+ , WavefrontOBJ+ ) where++import Codec.Wavefront.Face+import Codec.Wavefront.Line+import Codec.Wavefront.Location+import Codec.Wavefront.Normal+import Codec.Wavefront.Point+import Codec.Wavefront.Token+import Codec.Wavefront.TexCoord+import Control.Monad.State ( State, execState, gets, modify )+import Data.DList ( DList, append, empty, fromList, snoc )+import Data.Text ( Text )+import Data.Foldable ( traverse_ )++-- |An element holds a value along with the user-defined object’s name (if exists), the associated+-- groups and the used material.+data Element a = Element {+ elObject :: Maybe Text+ , elGroups :: [Text]+ , elMtl :: Maybe Text+ , elValue :: a+ } deriving (Eq,Show)++-- |The lexer context. The result of lexing a stream of tokens is this exact type.+data Ctxt = Ctxt {+ -- |Name of the object. 'Nothing' means that the object is not user-defined.+ ctxtName :: Maybe Text+ -- |Locations.+ , ctxtLocations :: DList Location+ -- |Texture coordinates.+ , ctxtTexCoords :: DList TexCoord+ -- |Normals.+ , ctxtNormals :: DList Normal+ -- |Points.+ , ctxtPoints :: DList (Element Point)+ -- |Lines.+ , ctxtLines :: DList (Element Line)+ -- |Faces.+ , ctxtFaces :: DList (Element Face)+ -- |Current object.+ , ctxtCurrentObject :: Maybe Text+ -- |Current groups.+ , ctxtCurrentGroups :: [Text]+ -- |Current material.+ , ctxtCurrentMtl :: Maybe Text+ -- |Material libraries.+ , ctxtMtlLibs :: DList Text+ } deriving (Eq,Show)++-- |Wavefront OBJ type.+type WavefrontOBJ = Ctxt++-- |The empty 'Ctxt'. Such a context exists at the beginning of the token stream and gets altered+-- as we consume tokens.+emptyCtxt :: Ctxt +emptyCtxt = Ctxt {+ ctxtName = Nothing+ , ctxtLocations = empty+ , ctxtTexCoords = empty+ , ctxtNormals = empty+ , ctxtPoints = empty+ , ctxtLines = empty+ , ctxtFaces = empty+ , ctxtCurrentObject = Nothing+ , ctxtCurrentGroups = ["default"]+ , ctxtCurrentMtl = Nothing+ , ctxtMtlLibs = empty+ }++-- |The lexer function, consuming tokens and yielding a 'Ctxt'.+lexer :: TokenStream -> Ctxt+lexer stream = execState (traverse_ consume stream) emptyCtxt+ where+ consume tk = case tk of+ TknV v -> do+ locations <- gets ctxtLocations+ modify $ \ctxt -> ctxt { ctxtLocations = locations `snoc` v }+ TknVN vn -> do+ normals <- gets ctxtNormals+ modify $ \ctxt -> ctxt { ctxtNormals = normals `snoc` vn }+ TknVT vt -> do+ texCoords <- gets ctxtTexCoords+ modify $ \ctxt -> ctxt { ctxtTexCoords = texCoords `snoc` vt }+ TknP p -> do+ (pts,element) <- prepareElement ctxtPoints+ modify $ \ctxt -> ctxt { ctxtPoints = pts `append` fmap element (fromList p) }+ TknL l -> do+ (lns,element) <- prepareElement ctxtLines+ modify $ \ctxt -> ctxt { ctxtLines = lns `append` fmap element (fromList l) }+ TknF f -> do+ (fcs,element) <- prepareElement ctxtFaces+ modify $ \ctxt -> ctxt { ctxtFaces = fcs `append` fmap element (fromList f) }+ TknG g -> modify $ \ctxt -> ctxt { ctxtCurrentGroups = g }+ TknO o -> modify $ \ctxt -> ctxt { ctxtCurrentObject = Just o }+ TknMtlLib l -> do+ libs <- gets ctxtMtlLibs+ modify $ \ctxt -> ctxt { ctxtMtlLibs = libs `append` fromList l }+ TknUseMtl mtl -> modify $ \ctxt -> ctxt { ctxtCurrentMtl = Just mtl }++-- Prepare to create a new 'Element' by retrieving its associated list.+prepareElement :: (Ctxt -> DList (Element a)) -> State Ctxt (DList (Element a),a -> Element a)+prepareElement field = do+ (aList,obj,grp,mtl) <- gets $ (\ctxt -> (field ctxt,ctxtCurrentObject ctxt,ctxtCurrentGroups ctxt,ctxtCurrentMtl ctxt))+ pure (aList,Element obj grp mtl)
+ src/Codec/Wavefront/Point.hs view
@@ -0,0 +1,15 @@+-----------------------------------------------------------------------------+-- |+-- Copyright : (C) 2015 Dimitri Sabadie+-- License : BSD3+--+-- Maintainer : Dimitri Sabadie <dimitri.sabadie@gmail.com>+-- Stability : experimental+-- Portability : portable+--+-----------------------------------------------------------------------------++module Codec.Wavefront.Point where++data Point = Point {-# UNPACK #-} !Int deriving (Eq,Show)+
+ src/Codec/Wavefront/TexCoord.hs view
@@ -0,0 +1,19 @@+-----------------------------------------------------------------------------+-- |+-- Copyright : (C) 2015 Dimitri Sabadie+-- License : BSD3+--+-- Maintainer : Dimitri Sabadie <dimitri.sabadie@gmail.com>+-- Stability : experimental+-- Portability : portable+--+-----------------------------------------------------------------------------++module Codec.Wavefront.TexCoord where++data TexCoord = TexCoord+ {-# UNPACK #-} !Float+ {-# UNPACK #-} !Float+ {-# UNPACK #-} !Float+ deriving (Eq,Show)+
+ src/Codec/Wavefront/Token.hs view
@@ -0,0 +1,202 @@+-----------------------------------------------------------------------------+-- |+-- Copyright : (C) 2015 Dimitri Sabadie+-- License : BSD3+--+-- Maintainer : Dimitri Sabadie <dimitri.sabadie@gmail.com>+-- Stability : experimental+-- Portability : portable+--+-----------------------------------------------------------------------------++module Codec.Wavefront.Token where++import Codec.Wavefront.Face+import Codec.Wavefront.Line+import Codec.Wavefront.Location+import Codec.Wavefront.Normal+import Codec.Wavefront.Point+import Codec.Wavefront.TexCoord+import Control.Applicative ( Alternative(..) )+import Data.Attoparsec.Text as AP+import Data.Char ( isDigit, isLetter, isSpace )+import Data.Maybe ( catMaybes )+import Data.Text ( Text, unpack )+import qualified Data.Text as T ( empty )+import Prelude hiding ( lines )++----------------------------------------------------------------------------------------------------+-- Token -------------------------------------------------------------------------------------------++data Token+ = TknV Location+ | TknVN Normal+ | TknVT TexCoord+ | TknP [Point]+ | TknL [Line]+ | TknF [Face]+ | TknG [Text]+ | TknO Text + | TknMtlLib [Text]+ | TknUseMtl Text+ deriving (Eq,Show)++-- |A stream of 'Token'.+type TokenStream = [Token]++tokenize :: Text -> Either String TokenStream+tokenize = fmap cleanupTokens . analyseResult False . parse (many1 tokenizer)+ where+ tokenizer = foldl1 (<|>)+ [+ fmap (Just . TknV) location+ , fmap (Just . TknVN) normal+ , fmap (Just . TknVT) texCoord+ , fmap (Just . TknP) points+ , fmap (Just . TknL) lines+ , fmap (Just . TknF) faces+ , fmap (Just . TknG) groups+ , fmap (Just . TknO) object+ , fmap (Just . TknMtlLib) mtllib+ , fmap (Just . TknUseMtl) usemtl+ , Nothing <$ comment+ ]++analyseResult :: Bool -> Result [Maybe Token] -> Either String [Maybe Token]+analyseResult partial r = case r of+ Done _ tkns -> Right tkns+ Fail i _ e -> Left $ "`" ++ Prelude.take 10 (unpack i) ++ "` [...]: " ++ e+ Partial p -> if partial then Left "not completely tokenized" else analyseResult True (p T.empty)++cleanupTokens :: [Maybe Token] -> TokenStream+cleanupTokens = catMaybes++----------------------------------------------------------------------------------------------------+-- Location ----------------------------------------------------------------------------------------++location :: Parser Location+location = skipSpace *> string "v " *> skipHSpace *> parseXYZW <* eol+ where+ parseXYZW = do+ xyz <- float `sepBy1` skipHSpace+ case xyz of+ [x,y,z] -> pure (Location x y z 1)+ [x,y,z,w] -> pure (Location x y z w)+ _ -> fail "wrong number of x, y and z arguments for location"++----------------------------------------------------------------------------------------------------+-- Normal ------------------------------------------------------------------------------------------++normal :: Parser Normal+normal = skipSpace *> string "vn " *> skipHSpace *> parseIJK <* eol+ where+ parseIJK = do+ ijk <- float `sepBy1` skipHSpace+ case ijk of+ [i,j,k] -> pure (Normal i j k)+ _ -> fail "wrong number of i, j and k arguments for normal"++----------------------------------------------------------------------------------------------------+-- Texture coordinates -----------------------------------------------------------------------------++texCoord :: Parser TexCoord+texCoord = skipSpace *> string "vt " *> skipHSpace *> parseUVW <* eol+ where+ parseUVW = do+ uvw <- float `sepBy1` skipHSpace+ case uvw of+ [u,v] -> pure (TexCoord u v 0)+ [u,v,w] -> pure (TexCoord u v w)+ _ -> fail "wrong number of u, v and w arguments for texture coordinates"++----------------------------------------------------------------------------------------------------+-- Points ------------------------------------------------------------------------------------------++points :: Parser [Point]+points = skipSpace *> string "p " *> skipHSpace *> fmap Point decimal `sepBy1` skipHSpace <* eol++----------------------------------------------------------------------------------------------------+-- Lines -------------------------------------------------------------------------------------------++-- TODO: ensure we have at least 2 pairs, otherwise it should fail+lines :: Parser [Line]+lines = skipSpace *> string "l " *> skipHSpace *> fmap Line parseLinePair `sepBy1` skipHSpace <* eol+ where+ parseLinePair = do+ v <- decimal+ slashThenElse (fmap (\vt -> (v, Just vt)) decimal) (pure (v,Nothing))++----------------------------------------------------------------------------------------------------+-- Faces -------------------------------------------------------------------------------------------++-- TODO: ensure we have at least 3 triples, otherwise it should fail+faces :: Parser [Face]+faces = skipSpace *> string "f " *> skipHSpace *> fmap Face parseFaceTriple `sepBy1` skipHSpace <* eol+ where+ parseFaceTriple = do+ v <- decimal+ slashThenElse (parseVT v) (pure (v,Nothing,Nothing))+ parseVT v = slashThenElse (parseVN v Nothing) $ do+ vt <- decimal+ slashThenElse (parseVN v $ Just vt) (pure (v,Just vt,Nothing))+ parseVN v vt = do+ vn <- decimal+ pure (v,vt,Just vn)++----------------------------------------------------------------------------------------------------+-- Groups ------------------------------------------------------------------------------------------++groups :: Parser [Text]+groups = skipSpace *> string "g " *> skipHSpace *> identifier `sepBy1` skipHSpace <* eol++----------------------------------------------------------------------------------------------------+-- Objects -----------------------------------------------------------------------------------------++object :: Parser Text+object = skipSpace *> string "o " *> skipHSpace *> identifier <* eol++----------------------------------------------------------------------------------------------------+-- Material libraries ------------------------------------------------------------------------------++mtllib :: Parser [Text]+mtllib = skipSpace *> string "mtllib " *> skipHSpace *> name `sepBy1` skipHSpace <* eol++----------------------------------------------------------------------------------------------------+-- Using materials ---------------------------------------------------------------------------------++usemtl :: Parser Text+usemtl = skipSpace *> string "usemtl " *> skipHSpace *> name <* skipHSpace <* eol++----------------------------------------------------------------------------------------------------+-- Comments ----------------------------------------------------------------------------------------+comment :: Parser ()+comment = skipSpace *> string "#" *> (() <$ manyTill anyChar eol)++----------------------------------------------------------------------------------------------------+-- Special parsers ---------------------------------------------------------------------------------++-- Read a slash ('/') and run the @thenP@ parser on success. Otherwise, call the @elseP@ parser.+slashThenElse :: Parser a -> Parser a -> Parser a+slashThenElse thenP elseP = do+ c <- peekChar+ case c of+ Just '/' -> AP.take 1 *> thenP+ _ -> elseP++-- End of line.+eol :: Parser ()+eol = skipMany (satisfy isHorizontalSpace) *> (endOfLine <|> endOfInput)++-- Parse a digital and/or alpha identifier.+identifier :: Parser Text+identifier = takeWhile1 $ \c -> isDigit c || isLetter c++-- Parse a name (any character but space).+name :: Parser Text+name = takeWhile1 $ not . isSpace++skipHSpace :: Parser ()+skipHSpace = () <$ AP.takeWhile isHorizontalSpace++float :: Parser Float+float = fmap realToFrac double
+ wavefront.cabal view
@@ -0,0 +1,50 @@+name: wavefront+version: 0.1+synopsis: Wavefront OBJ loader+description: A Wavefront OBJ loader. Currently supports polygonal information. More could+ be added if needed (like curves and surface) if people contribute. Feel free+ to help!+homepage: https://github.com/phaazon/wavefront+bug-reports: https://github.com/phaazon/wavefront/issues+license: BSD3+license-file: LICENSE+author: Dimitri Sabadie <dimitri.sabadie@gmail.com>+maintainer: Dimitri Sabadie <dimitri.sabadie@gmail.com>+copyright: Dimitri Sabadie++category: Codec+build-type: Simple+extra-source-files: CHANGELOG.md+cabal-version: >=1.10++source-repository head+ type: git+ location: git://github.com/phaazon/wavefront.git++library+ ghc-options: -W -Wall++ exposed-modules: Codec.Wavefront.Face+ , Codec.Wavefront.IO+ , Codec.Wavefront.Line+ , Codec.Wavefront.Location+ , Codec.Wavefront.Normal+ , Codec.Wavefront.Object+ , Codec.Wavefront.Point+ , Codec.Wavefront.TexCoord++ other-modules: Codec.Wavefront.Token++ default-extensions: OverloadedStrings++ build-depends: base >= 4.8 && < 4.9+ , attoparsec >= 0.13 && < 0.14+ , dlist >= 0.7 && < 0.8+ , filepath >= 1.4 && < 1.5+ , mtl >= 2.2 && < 2.3+ , text >= 1.2 && < 1.3+ , transformers >= 0.4 && < 0.5++ hs-source-dirs: src++ default-language: Haskell2010