obj (empty) → 0.1
raw patch · 17 files changed
+1403/−0 lines, 17 filesdep +Codec-Image-DevILdep +OpenGLdep +OpenGLChecksetup-changed
Dependencies added: Codec-Image-DevIL, OpenGL, OpenGLCheck, QuickCheck, array, base, binary, bytestring, checkers, containers, directory, filepath, graphicsFormats, haskell98
Files
- LICENSE +9/−0
- README +20/−0
- Setup.lhs +4/−0
- examples/LoadObject.hs +59/−0
- examples/Setup.lhs +4/−0
- examples/exampleModels/TieFighter.mtl +13/−0
- examples/exampleModels/TieFighter.obj too large to diff
- examples/loadObject.cabal +24/−0
- obj.cabal +44/−0
- src/Graphics/Formats/Mtl/Contents.hs +152/−0
- src/Graphics/Formats/Mtl/Parse.hs +104/−0
- src/Graphics/Formats/Obj.hs +62/−0
- src/Graphics/Formats/Obj/Contents.hs +114/−0
- src/Graphics/Formats/Obj/ObjModel.hs +456/−0
- src/Graphics/Formats/Obj/Parse.hs +239/−0
- src/Graphics/Formats/Obj/ParserBits.hs +79/−0
- src/Graphics/Formats/Obj/Tests.hs +20/−0
+ LICENSE view
@@ -0,0 +1,9 @@+Copyright (c) 2008 Anygma BVBA & Thomas Davie+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 the Anygma BVBA nor the names of its 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.
+ README view
@@ -0,0 +1,20 @@+ mkbndl+ ======++Generates OS X .app bundles from binaries.++Install:+========+> runhaskell Setup.lhs configure+> runhaskell Setup.lhs build+> runhaskell Setup.lhs install (as root)++Documentation:+==============+> runhaskell Setup.lhs haddock --executables++or++> mkbndl --help++Copyright (c) 2008 Thomas Davie
+ Setup.lhs view
@@ -0,0 +1,4 @@+#! /usr/bin/env runhaskell++> import Distribution.Simple+> main = defaultMain
+ examples/LoadObject.hs view
@@ -0,0 +1,59 @@+{-# OPTIONS_GHC -Wall #-}+----------------------------------------------------------------------+-- |+-- Module : LoadObject+-- Copyright : (c) Anygma BVBA and Thomas Davie 2008+-- License : BSD3+-- +-- Maintainer : tom.davie@gmail.com+-- Stability : experimental+-- +-- Based on BSD Licenced Source code by Conal Elliott and Andy J Gill.+--+-- Load an Obj model at a specified scale, and spin it round on screen+----------------------------------------------------------------------++module Main where++import System+import System.FilePath++import Data.Monoid+import Control.Applicative+import Control.Applicative.Infix++import FRP.Reactive+import FRP.Reactive.GLUT.Adapter+import Graphics.FieldTrip++import Graphics.Formats+import Graphics.Formats.Obj+import Codec.Image.DevIL++-- | Load an object at a specified scale and render it.+main :: IO ()+main =+ do [file,scale] <- System.getArgs+ ilInit+ simpleInit ("ObjModel: " ++ file)+ dl <- objFromFile file [fst (splitFileName file)] >>= displayListR+ adapt . spinningR (read scale) . renderableG $ dl++-- | Produces a Behavior of rendering actions based on a piece of geometry.+-- The geometry is rendered spinning at a specified scale.+spinningR :: Double -> Geometry3 -> UI -> Behavior Action+spinningR scale g = const (render3 <$> spinningG scale g)++-- | Produces a Behavior of geometry based on transforming a static piece of+-- Geometry. The transformation spins the geometry over time.+spinningG :: Double -> Geometry3 -> Behavior Geometry3+spinningG scale g = spinning scale <^(*%)^> pure g++-- | A Behavior of transformations. Specifies how something should be moved+-- at any time point. This Behavior describes a spinning motion.+spinning :: Double -> Behavior (Transform3 Double)+spinning scale = f <$> time+ where+ f t = translate3 (Vector3 (0::Double) 0 (2*sin (-t/5) - 3))+ `mappend` rotate3 t (Vector3 0.2 0.2 0.3)+ `mappend` uscale3 scale
+ examples/Setup.lhs view
@@ -0,0 +1,4 @@+#! /usr/bin/env runhaskell++> import Distribution.Simple+> main = defaultMain
+ examples/exampleModels/TieFighter.mtl view
@@ -0,0 +1,13 @@+newmtl lambert2SG+illum 4+Kd 0.07 0.07 0.07+Ka 0.00 0.00 0.00+Tf 1.00 1.00 1.00+Ni 1.00+newmtl material09+illum 4+Kd 0.44 0.44 0.44+Ka 0.00 0.00 0.00+Tf 1.00 1.00 1.00+Ni 1.00+Ks 0.50 0.50 0.50
+ examples/exampleModels/TieFighter.obj view
file too large to diff
+ examples/loadObject.cabal view
@@ -0,0 +1,24 @@+Name: loadObject+Cabal-Version: >= 1.2+Version: 0.1+Synopsis: Demo of obj loading with the obj package.+Description: Demo of obj loading with the obj package.+Author: Thomas Davie+Maintainer: Thomas Davie (tom.davie@gmail.com)+Category: Graphics+build-type: Simple++Executable loadModel+ Build-Depends: obj >= 0.1,+ haskell98 >= 1.0,+ base >= 3,+ filepath >= 1.1,+ FieldTrip >= 0.1,+ reactive >= 0.8.3,+ reactive-glut >= 0.0.1,+ Codec-Image-DevIL >= 0.1,+ OpenGL >= 2.2,+ graphicsFormats >= 0.1,+ InfixApplicative >= 1.0+ Ghc-Options: -O2+ Main-is: LoadObject.hs
+ obj.cabal view
@@ -0,0 +1,44 @@+Name: obj+Cabal-Version: >= 1.2+Version: 0.1+Synopsis: Reads and writes obj models.+Description: Reads and writes obj models.+License: BSD3+License-file: LICENSE+Author: Thomas Davie+Maintainer: Thomas Davie (tom.davie@gmail.com)+extra-source-files: README+ examples/loadObject.cabal+ examples/Setup.lhs+ examples/LoadObject.hs+ examples/exampleModels/TieFighter.obj+ examples/exampleModels/TieFighter.mtl+Category: Graphics+Stability: experimental+build-type: Simple++Library+ Build-Depends: base >= 3.0,+ haskell98 >= 1.0,+ QuickCheck >= 1.1,+ graphicsFormats >= 0.1,+ OpenGL >= 2.2,+ checkers >= 0.1.1,+ array >= 0.1,+ containers >= 0.1,+ directory >= 1.0,+ filepath >= 1.1,+ OpenGLCheck >= 0.1,+ bytestring >= 0.9,+ binary >= 0.4.2,+ Codec-Image-DevIL >= 0.1+ Hs-Source-Dirs: src+ Ghc-Options: -O2+ Exposed-Modules: Graphics.Formats.Obj+ Other-Modules: Graphics.Formats.Obj.Parse+ Graphics.Formats.Obj.ParserBits+ Graphics.Formats.Obj.ObjModel+ Graphics.Formats.Obj.Contents+ Graphics.Formats.Mtl.Parse+ Graphics.Formats.Mtl.Contents+ Graphics.Formats.Obj.Tests
+ src/Graphics/Formats/Mtl/Contents.hs view
@@ -0,0 +1,152 @@+{-# OPTIONS_GHC -Wall #-}+----------------------------------------------------------------------+-- |+-- Module : Graphcs.Formats.Mtl.Contents+-- Copyright : (c) Anygma BVBA & Thomas Davie 2008+-- License : BSD3+-- +-- Maintainer : tom.davie@gmail.com+-- Stability : experimental+-- +-- Mtl file content description+----------------------------------------------------------------------+module Graphics.Formats.Mtl.Contents+ (MtlFile(..),Material(..)+ ,setName,setMatFile+ ,setAmbient ,setDiffuse ,setSpecular+ ,setAmbientTexName,setDiffuseTexName,setSpecularTexName+ ,loadTextures+ ,emptyMat,whiteMat) where++import Data.Map (Map)+import qualified Data.Map as M+import qualified Data.Traversable as T+import Data.List++import Graphics.Rendering.OpenGL+import Control.Monad++import Test.QuickCheck+import Test.QuickCheck.Instances+import Test.QuickCheck.Instances.OpenGL ()++import Codec.Image.DevIL++newtype MtlFile = MF (Map String Material)+ deriving Show++data Material = Mat {name :: String+ ,matFile :: FilePath+ ,ambientColour :: Color4 GLfloat+ ,diffuseColour :: Color4 GLfloat+ ,specularColour :: Color4 GLfloat+ ,ambientTex :: Either String TextureObject+ ,diffuseTex :: Either String TextureObject+ ,specularTex :: Either String TextureObject}+ deriving (Show,Eq,Ord)++instance Arbitrary Material where+ arbitrary = liftM2 setName+ (liftM2 setMatFile+ (liftM2 setDiffuse+ (liftM2 setAmbient+ (liftM2 setSpecular+ (return emptyMat)+ arbitrary)+ arbitrary)+ arbitrary)+ (anyList nonSpace))+ (anyList nonSpace)+ coarbitrary m = coarbitrary (name m)+ . coarbitrary (matFile m)+ . coarbitrary (ambientColour m)+ . coarbitrary (diffuseColour m)+ . coarbitrary (specularColour m)+ . coarbitrary (ambientTex m)+ . coarbitrary (diffuseTex m)+ . coarbitrary (specularTex m)++loadTextures :: (FilePath -> IO (Maybe FilePath))+ -> MtlFile+ -> IO ([FilePath],MtlFile)+loadTextures f (MF ms) =+ do loaded <- mmapM (loadMtlTextures f) $ ms+ return (filter (/= "") . nub . concat . M.elems . M.map fst $ loaded+ ,MF $ M.map snd loaded)++mmapM :: (Monad m) => (a -> m b) -> Map k a -> m (Map k b)+mmapM f = T.sequence . M.map f ++loadMtlTextures :: (FilePath -> IO (Maybe FilePath))+ -> Material+ -> IO ([FilePath],Material)+loadMtlTextures f m =+ do at <- maybeLoadTex (ambientTex m)+ dt <- maybeLoadTex (diffuseTex m)+ st <- maybeLoadTex (specularTex m)+ let missing = missing' at ++ missing' dt ++ missing' st+ return (missing,m {ambientTex = at, diffuseTex = dt, specularTex = st})+ where+ missing' :: Either String TextureObject -> [String]+ missing' (Left x) = [x]+ missing' (Right _) = []+ maybeLoadTex :: Either String TextureObject+ -> IO (Either String TextureObject)+ maybeLoadTex mat =+ case mat of+ Left "" -> return $ Left ""+ Left x -> do fn <- f x+ (case fn of+ Just fn' ->+ do t <- loadTexture fn'+ return $ Right t+ Nothing ->+ return $ Left x)+ Right x -> return $ Right x ++loadTexture :: FilePath -> IO TextureObject+loadTexture f = buildTexture =<< readImage f++setName :: Material -> String -> Material+setName m n = m {name = n}++setMatFile :: Material -> FilePath -> Material+setMatFile m f = m {matFile = f}++setAmbient :: Material -> Color4 GLfloat -> Material+setAmbient m c = m {ambientColour = c}++setDiffuse :: Material -> Color4 GLfloat -> Material+setDiffuse m c = m {diffuseColour = c}++setSpecular :: Material -> Color4 GLfloat -> Material+setSpecular m c = m {specularColour = c}++setAmbientTexName :: Material -> String -> Material+setAmbientTexName m t = m {ambientTex = Left t}++setDiffuseTexName :: Material -> String -> Material+setDiffuseTexName m t = m {diffuseTex = Left t}++setSpecularTexName :: Material -> String -> Material+setSpecularTexName m t = m {specularTex = Left t}++emptyMat :: Material+emptyMat = Mat {name = ""+ ,matFile = ""+ ,ambientColour = Color4 0.0 0.0 0.0 0.0+ ,diffuseColour = Color4 0.0 0.0 0.0 0.0+ ,specularColour = Color4 0.0 0.0 0.0 0.0+ ,ambientTex = Left ""+ ,diffuseTex = Left ""+ ,specularTex = Left ""}++whiteMat :: Material+whiteMat = Mat {name = "white"+ ,matFile = ""+ ,ambientColour = Color4 1 1 1 1+ ,diffuseColour = Color4 0.5 0.5 0.5 1+ ,specularColour = Color4 0 0 0 1+ ,ambientTex = Left ""+ ,diffuseTex = Left ""+ ,specularTex = Left ""}
+ src/Graphics/Formats/Mtl/Parse.hs view
@@ -0,0 +1,104 @@+{-# OPTIONS_GHC -Wall -fno-warn-orphans #-}+----------------------------------------------------------------------+-- |+-- Module : Graphics.Formats.Mtl.Parse+-- Copyright : (c) Anygma BVBA & Thomas Davie 2008+-- License : BSD3+-- +-- Maintainer : tom.davie@gmail.com+-- Stability : experimental+-- +-- Mtl format parser using bytestrings+----------------------------------------------------------------------+module Graphics.Formats.Mtl.Parse where++import qualified Data.ByteString.Char8 as CBS+import qualified Data.ByteString.Lazy as LBS++import Data.Binary+import Data.Binary.Get++import qualified Data.Map as M++import Graphics.Rendering.OpenGL++import Graphics.Formats.Mtl.Contents+import Graphics.Formats.Obj.ParserBits++import Control.Monad++instance Binary MtlFile where+ put (MF x) = forM_ (M.elems x) put+ get =+ return . MF+ . buildMap+ . map decodeMtl+ . chunk (CBS.pack "newmtl")+ . CBS.concat+ . LBS.toChunks =<< getRemainingLazyByteString++instance (Show a, Binary a) => Binary (Color4 a) where+ put (Color4 r g b a) = put (show r) >> put ' ' >> put (show g) >> put ' ' >>+ put (show b) >> put ' ' >> put (show a)+ get = undefined++buildMap :: [Material] -> M.Map String Material+buildMap x = M.fromList $ zip (map name x) x++chunk :: CBS.ByteString -> CBS.ByteString -> [CBS.ByteString]+chunk x y = h : if CBS.null t then [] else chunk x (CBS.drop (CBS.length x) t)+ where+ (h,t) = CBS.breakSubstring x y++instance Binary Material where+ put m = do put "newmtl " >> put (name m) >> put '\n'+ put "Ka " >> put (ambientColour m) >> put '\n'+ put "Kd " >> put (diffuseColour m) >> put '\n'+ put "Ks " >> put (specularColour m) >> put '\n'+ get = undefined++decodeMtl :: CBS.ByteString -> Material+decodeMtl = foldr ($) (Mat {name = ""+ ,matFile = ""+ ,ambientColour = Color4 0 0 0 1+ ,diffuseColour = Color4 0 0 0 1+ ,specularColour = Color4 0 0 0 1+ ,ambientTex = Left ""+ ,diffuseTex = Left ""+ ,specularTex = Left ""})+ . map decodeLine+ . CBS.lines++decodeLine :: CBS.ByteString -> Material -> Material+decodeLine = decodeLine' . consumeWS . removeComments++decodeLine' :: CBS.ByteString -> Material -> Material+decodeLine' s =+ if CBS.length s > 0 then+ case s of+ _ | (CBS.pack "Ka") `CBS.isPrefixOf` s ->+ colour setAmbient (CBS.drop 2 s)+ _ | (CBS.pack "Kd") `CBS.isPrefixOf` s ->+ colour setDiffuse (CBS.drop 2 s)+ _ | (CBS.pack "Ks") `CBS.isPrefixOf` s ->+ colour setSpecular (CBS.drop 2 s)+ _ | (CBS.pack "map_Ka") `CBS.isPrefixOf` s ->+ applyTex setAmbientTexName (CBS.drop 6 s)+ _ | (CBS.pack "map_Kd") `CBS.isPrefixOf` s ->+ applyTex setDiffuseTexName (CBS.drop 6 s)+ _ | (CBS.pack "map_Ks") `CBS.isPrefixOf` s ->+ applyTex setSpecularTexName (CBS.drop 6 s)+ x ->+ flip setName . parseName $ x+ else id++colour :: (a -> Color4 GLfloat -> c) -> CBS.ByteString -> a -> c+colour f = (flip f) . makeColour . bSwords unsafeReadFloat++applyTex :: (a -> String -> c) -> CBS.ByteString -> a -> c+applyTex f = (flip f) . parseName++makeColour :: [Float] -> Color4 GLfloat+makeColour [r,g,b] = Color4 r g b 1+makeColour (r:g:b:a:_) = Color4 r g b a+makeColour x = error (show x)
+ src/Graphics/Formats/Obj.hs view
@@ -0,0 +1,62 @@+{-# OPTIONS_GHC -Wall #-}+----------------------------------------------------------------------+-- |+-- Module : Graphics.Formats.Obj+-- Copyright : (c) Anygma BVBA & Thomas Davie 2008+-- License : BSD3+-- +-- Maintainer : tom.davie@gmail.com+-- Stability : experimental+-- +-- Obj model loader+----------------------------------------------------------------------+module Graphics.Formats.Obj+ (objFromFile+ ,ObjModel+ ) where++import Data.Binary++import Control.Applicative++import System.Directory+import System.FilePath++import qualified Data.Map as M+import Data.Maybe hiding (fromJust)++import Graphics.Formats.Obj.Parse+import Graphics.Formats.Obj.ObjModel+import Graphics.Formats.Mtl.Contents+import Graphics.Formats.Mtl.Parse ()++-- | Loads an Obj model from a file given a list of search paths to find+-- materials and textures at.+objFromFile :: FilePath -> [FilePath] -> IO ObjModel+objFromFile x sps =+ do -- Parse the obj+ cs <- decodeFile x+ -- Find the material files and parse them too+ let mtlfs = mtllibs cs+ files <- mapM (findFile sps) mtlfs+ mapM_ (putStrLn . ("Warning: File not found: " ++) . fst)+ . filter ((==Nothing) . snd)+ $ zip mtlfs files+ parsedMats <- mapM decodeFile (catMaybes files)+ let ms = MF . M.unions . map (\(MF a) -> a) $ parsedMats+ -- Now find all the textures and load them+ (missingTexFiles,ms') <- loadTextures (findFile sps) ms+ mapM_ (putStrLn . ("Warning: File not found: " ++)) missingTexFiles+ -- Put everything together and hand it back+ return $ geometry cs ms'++-- | Finds a file given a list of search paths to look for it at.+-- The first file found is returned.+findFile :: [FilePath] -> FilePath -> IO (Maybe FilePath)+findFile sps f = (listToMaybe . catMaybes) <$> (mapM (tryFile f) sps)++-- | Checks if a file exists at a specified search path+-- If it does, returns that filepath in a maybe+tryFile :: FilePath -> FilePath -> IO (Maybe FilePath)+tryFile x y = do e <- doesFileExist (y </> x)+ if e then return . Just $ (y </> x) else return Nothing
+ src/Graphics/Formats/Obj/Contents.hs view
@@ -0,0 +1,114 @@+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# OPTIONS_GHC -Wall #-}+----------------------------------------------------------------------+-- |+-- Module : Graphics.Formats.Obj.Contents+-- Copyright : (c) Anygma BVBA & Thomas Davie 2008+-- License : BSD3+-- +-- Maintainer : tom.davie@gmail.com+-- Stability : experimental+-- +-- Describes the concrete syntax of an Obj file+----------------------------------------------------------------------+module Graphics.Formats.Obj.Contents+ (ObjFile(..),Statement(..),VTriple,VDouble+ ,isVertex,isNormal,isTexCoord+ ,isPoints,isLines,isFace,isObject+ ,isUseMtl,isSmoothG+ ,contentsTests) where++import Test.QuickCheck+import Test.QuickCheck.Instances++import Control.Monad+import Control.Applicative++import Data.Char++newtype ObjFile = OF [Statement]+ deriving (Show,Eq)++instance Arbitrary ObjFile where+ arbitrary = liftM OF arbitrary+ coarbitrary (OF x) = coarbitrary x++data Statement = V Float Float Float Float+ | VN Float Float Float+ | VT Float Float Float+ | P [Int]+ | L [VDouble]+ | F [VTriple]+ | G [Group]+ | SG (Maybe Int)+ | MtlLib [String]+ | UseMtl String+ deriving (Show,Read,Eq)++type VTriple = (Int, Maybe Int, Maybe Int)+type VDouble = (Int, Maybe Int)+type Group = String++instance Arbitrary Statement where+ arbitrary =+ oneof [V <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary+ ,VN <$> arbitrary <*> arbitrary <*> arbitrary+ ,VT <$> arbitrary <*> arbitrary <*> arbitrary+ ,P <$> (nonEmpty nonZero_)+ ,L <$> (nonEmpty (nonZero_ >*< (maybeGen nonZero_)))+ ,F <$> (nonEmpty ((>**<) nonZero_+ (maybeGen nonZero_)+ (maybeGen nonZero_)))+ ,G <$> (nonEmpty (nonEmpty (notOneof " \t\n\r#")))+ ,SG <$> (maybeGen positive)]+ coarbitrary (V x y z w) =+ coarbitrary x . coarbitrary y . coarbitrary z . coarbitrary w+ coarbitrary (VN x y z) =+ coarbitrary x . coarbitrary y . coarbitrary z+ coarbitrary (VT x y z) =+ coarbitrary x . coarbitrary y . coarbitrary z+ coarbitrary (P n) = coarbitrary n+ coarbitrary (L n) = coarbitrary n+ coarbitrary (F n) = coarbitrary n+ coarbitrary (G n) = coarbitrary n+ coarbitrary (SG g) = coarbitrary g+ coarbitrary (UseMtl xs) = coarbitrary xs+ coarbitrary (MtlLib x) = coarbitrary x+ +isNormal :: Statement -> Bool+isNormal (VN _ _ _) = True+isNormal _ = False++isTexCoord :: Statement -> Bool+isTexCoord (VT _ _ _) = True+isTexCoord _ = False++isVertex :: Statement -> Bool+isVertex (V _ _ _ _) = True+isVertex _ = False++isPoints :: Statement -> Bool+isPoints (P _) = True+isPoints _ = False++isLines :: Statement -> Bool+isLines (L _) = True+isLines _ = False++isFace :: Statement -> Bool+isFace (F _) = True+isFace _ = False++isObject :: Statement -> Bool+isObject = liftA2 (||) isFace (liftA2 (||) isLines isPoints)++isUseMtl :: Statement -> Bool+isUseMtl (UseMtl _) = True+isUseMtl _ = False++isSmoothG :: Statement -> Bool+isSmoothG (SG _) = True+isSmoothG _ = False++contentsTests :: IO ()+contentsTests = return ()
+ src/Graphics/Formats/Obj/ObjModel.hs view
@@ -0,0 +1,456 @@+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# OPTIONS_GHC -Wall #-}+----------------------------------------------------------------------+-- |+-- Module : Graphics.Formats.Obj.ObjModel+-- Copyright : (c) Anygma BVBA and Thomas Davie 2008+-- License : BSD3+-- +-- Maintainer : tom.davie@gmail.com+-- Stability : experimental+-- +-- Describes an Obj Model+----------------------------------------------------------------------+module Graphics.Formats.Obj.ObjModel+ (geometryTests+ ,ObjModel()+ ,geometry,objFile+ ) where++import Graphics.Formats+import Graphics.Formats.Obj.Contents+import Graphics.Formats.Obj.ParserBits (anyOf)+import Graphics.Formats.Mtl.Contents++import Graphics.Rendering.OpenGL++import Test.QuickCheck+import Test.QuickCheck.Checkers+import Test.QuickCheck.Instances++import Data.List+import Data.Array+import Data.Function+import Data.Map (Map)+import qualified Data.Map as M++import Control.Monad+import Control.Applicative++data ObjModel = OM BufferSet [Object]+ deriving (Show)++type BufferSet = (VertexBuffer, TexCoordBuffer, NormalBuffer)++type VertexBuffer = Array Int (Vertex4 GLfloat)+type TexCoordBuffer = Array Int (TexCoord2 GLfloat)+type NormalBuffer = Array Int (Normal3 GLfloat)++data Object = OFace Material [VTriple]+ | OQuad Material [VTriple]+ | OTriangle Material [VTriple]+ | OLine [VDouble]+ | OPoint [Int]+ deriving (Show,Eq,Ord)++instance EqProp ObjModel where+ m =-= m' = property (normalForm m == normalForm m')++normalForm :: ObjModel -> (BufferSet,[Object])+normalForm (OM (vb,tb,nb) os) =+ let lb = fst . bounds+ ub = snd . bounds+ indicies = (uncurry enumFromTo) . bounds+ mkArray a =+ let b = lb a+ in array (0,ub a - lb a) [(i - b,a ! i) | i <- indicies a]+ stripMat (OFace _ bs) = OFace emptyMat bs+ stripMat (OTriangle _ bs) = OFace emptyMat bs+ stripMat (OQuad _ bs) = OFace emptyMat bs+ stripMat x = x+ in ((mkArray vb,mkArray tb,mkArray nb)+ ,sort $ offsetObjects (lb vb) (lb nb) (lb tb) (map stripMat os))++instance Eq ObjModel where+ (OM bs os) == (OM bs' os') = bs == bs' && os == os'++instance Arbitrary ObjModel where+ arbitrary = OM <$> ((>**<) arbitrary arbitrary arbitrary) <*> arbitrary+ coarbitrary (OM (v,t,n) os) =+ coarbitrary v . coarbitrary t . coarbitrary n . coarbitrary os++instance Arbitrary Object where+ arbitrary = oneof [OFace <$> (return whiteMat)+ <*> (nonEmpty + ((>**<) positive (maybeGen positive)+ (maybeGen positive)))+ ,OTriangle <$> (return whiteMat)+ <*> (setLength 3+ ((>**<) positive+ (maybeGen positive)+ (maybeGen positive)))+ ,OQuad <$> (return whiteMat)+ <*> (setLength 4+ ((>**<) positive+ (maybeGen positive)+ (maybeGen positive)))+ ,OLine <$> (nonEmpty+ (positive >*< (maybeGen positive)))+ ,OPoint <$> (nonEmpty positive)]+ coarbitrary (OFace _ n) = coarbitrary n+ coarbitrary (OTriangle _ n) = coarbitrary n+ coarbitrary (OQuad _ n) = coarbitrary n+ coarbitrary (OLine n) = coarbitrary n+ coarbitrary (OPoint n) = coarbitrary n++instance Renderable ObjModel where+ render (OM bs os) = + let (textured,unTextured) = partition isTextured os+ texturedGroups = groupBy ((==) `on` texID)+ . sortBy (compare `on` texID)+ $ textured+ in do colorMaterial $= Just (FrontAndBack, AmbientAndDiffuse)+ mapM_ (renderOs bs) (unTextured:texturedGroups)++renderOs :: BufferSet -> [Object] -> IO ()+renderOs bs os =+ case os of+ [] -> return ()+ (o:_) -> do setTexturing o+ renderList bs (filter isTriangle os) Triangles+ renderList bs (filter isQuad os) Quads+ mapM_ (renderObject bs) (filter isPolygon os)++material :: Object -> Maybe Material+material (OFace m _) = Just m+material (OTriangle m _) = Just m+material (OQuad m _) = Just m+material _ = Nothing++points :: Object -> Maybe [VTriple]+points (OFace _ ps) = Just ps+points (OTriangle _ ps) = Just ps+points (OQuad _ ps) = Just ps+points _ = Nothing++faceTexture :: Object -> Either String TextureObject+faceTexture = maybe (Left "") diffuseTex . material++faceColour :: Object -> IO ()+faceColour f = + either (const (setColour (ambientColour m)+ (diffuseColour m)+ (specularColour m)))+ (const (setColour (Color4 (1.0 :: GLfloat) 1.0 1.0 1.0)+ (Color4 (1.0 :: GLfloat) 1.0 1.0 1.0)+ (Color4 (1.0 :: GLfloat) 1.0 1.0 1.0)))+ (diffuseTex m)+ where+ m = maybe (error "Face has no material") id $ material f++texID :: Object -> GLuint+texID = either (const 0) unTexObj . faceTexture+ where+ unTexObj (TextureObject x) = x++setTexturing :: Object -> IO ()+setTexturing o =+ case faceTexture o of+ Left _ -> texture Texture2D $= Disabled+ Right t -> do texture Texture2D $= Enabled+ textureBinding Texture2D $= Just t++isTextured :: Object -> Bool+isTextured = either (const False) (const True) . faceTexture++renderList :: BufferSet -> [Object] -> PrimitiveMode -> IO ()+renderList bs x f =+ do renderPrimitive f $ forM_ x (renderCalls bs)++renderCalls :: BufferSet -> Object -> IO ()+renderCalls bs f =+ do faceColour f+ maybe (return ()) (mapM_ (renderOperation3 bs)) $ points f++renderObject :: BufferSet -> Object -> IO ()+renderObject bs (OFace _ ps) = + renderPrimitive Polygon $ forM_ ps (renderOperation3 bs)+renderObject bs (OTriangle _ ps) =+ renderPrimitive Triangles $ forM_ ps (renderOperation3 bs)+renderObject bs (OQuad _ ps) =+ renderPrimitive Quads $ forM_ ps (renderOperation3 bs)+renderObject bs (OLine ps) =+ renderPrimitive LineStrip $ forM_ ps (renderOperation2 bs)+renderObject bs (OPoint ps) =+ renderPrimitive Points $ forM_ ps (renderOperation1 bs)++renderOperation3 :: BufferSet -> VTriple -> IO ()+renderOperation3 (vs,ts,ns) (v,t,n) =+ let nop = maybe top ((>> top) . normal . (ns !)) n+ top = maybe vop ((>> vop) . texCoord . (ts !)) t+ vop = vertex (vs ! v)+ in nop++renderOperation2 :: BufferSet -> VDouble -> IO ()+renderOperation2 bs (v,t) = renderOperation3 bs (v,Nothing,t)++renderOperation1 :: BufferSet -> Int -> IO ()+renderOperation1 bs v = renderOperation3 bs (v,Nothing,Nothing)+ +isTriangle :: Object -> Bool+isTriangle (OTriangle _ _) = True+isTriangle _ = False++isQuad :: Object -> Bool+isQuad (OQuad _ _ ) = True+isQuad _ = False++isPolygon :: Object -> Bool+isPolygon (OFace _ _) = True+isPolygon _ = False++setColour :: (ColorComponent a, ColorComponent b, ColorComponent c) =>+ Color4 a -> Color4 b -> Color4 c -> IO ()+setColour _ d _ = color d+{- do materialAmbient FrontAndBack $= a+ materialDiffuse FrontAndBack $= d+ materialSpecular FrontAndBack $= s -}++{-renderNormals :: BufferSet -> VTriple -> IO ()+renderNormals (vs,_,ns) (v,_,n) =+ case n of+ Just n' -> vertex (vs ! v) >> vertex ((vs ! v) ..+^^ (ns ! n'))+ Nothing -> return ()++(..+^^) :: Vertex4 GLfloat -> Normal3 GLfloat -> Vertex4 GLfloat+(..+^^) (Vertex4 x y z w) (Normal3 i j k) = Vertex4 (x+i) (y+j) (z+k) w-}++geometry :: ObjFile -> MtlFile -> ObjModel+geometry (OF f) mtls =+ OM bs (unsmoothedObjects ++ smoothedObjects)+ where+ vertexBuffer = listArray (1,length vertexList ) vertexList+ normalBuffer = listArray (1,length fullNormalList) fullNormalList+ texCoordBuffer = listArray (1,length texCoordList ) texCoordList+ vertexList = map vToVertex . filter isVertex $ f+ normalList = map vnToNormal . filter isNormal $ f+ fullNormalList = normalList ++ concat newNormals+ texCoordList = map vtToTexCoord . filter isTexCoord $ f+ bs = (vertexBuffer,texCoordBuffer,normalBuffer)+ unsmoothedObjects = maybe [] id (M.lookup Nothing objects)+ (smoothedObjects,newNormals,_) =+ foldr (smoothGroup vertexBuffer)+ ([],[],length normalList + 1)+ smoothingGroups+ smoothingGroups = M.elems . M.filterWithKey (\k _ -> k /= Nothing)+ $ objects+ objects = fst6 $ foldl (addObj mtls)+ (M.empty,whiteMat,Nothing,1,1,1)+ (filter (anyOf [isNormal,isTexCoord,isVertex+ ,isObject,isUseMtl,isSmoothG]) f)++fst6 :: (a,b,c,d,e,f) -> a+fst6 (x,_,_,_,_,_) = x++addObj :: MtlFile+ -> (Map (Maybe Int) [Object],Material,Maybe Int,Int,Int,Int)+ -> Statement+ -> (Map (Maybe Int) [Object],Material,Maybe Int,Int,Int,Int)+addObj (MF mtls) (os,_,sg,vc,nc,tc) (UseMtl m) =+ maybe (error ("Material not found: " ++ show m))+ (\mtl' -> (os,mtl',sg,vc,nc,tc))+ (M.lookup m mtls)+addObj _ (os,cm,sg,vc,nc,tc) (P ps) =+ (M.insertWith (++) sg [OPoint (map (mkAbs vc) ps)] os, cm,sg,vc,nc,tc)+addObj _ (os,cm,sg,vc,nc,tc) (L ps) =+ (M.insertWith (++) sg [OLine (absoluteRefs2 vc tc ps)] os, cm,sg,vc,nc,tc)+addObj _ (os,cm,sg,vc,nc,tc) (F ps) =+ case length ps of+ 3 -> (M.insertWith (++) sg [OTriangle cm (absoluteRefs3 vc nc tc ps)] os+ ,cm,sg,vc,nc,tc)+ 4 -> (M.insertWith (++) sg [OQuad cm (absoluteRefs3 vc nc tc ps)] os+ ,cm,sg,vc,nc,tc)+ _ -> (M.insertWith (++) sg [OFace cm (absoluteRefs3 vc nc tc ps)] os+ ,cm,sg,vc,nc,tc)+addObj _ (os,cm,sg,vc,nc,tc) (V _ _ _ _) = (os,cm,sg,vc+1,nc ,tc )+addObj _ (os,cm,sg,vc,nc,tc) (VN _ _ _) = (os,cm,sg,vc ,nc+1,tc )+addObj _ (os,cm,sg,vc,nc,tc) (VT _ _ _) = (os,cm,sg,vc ,nc ,tc+1)+addObj _ (os,cm,_ ,vc,nc,tc) (SG s) = (os,cm,s ,vc ,nc ,tc )+addObj _ (os,cm,sg,vc,nc,tc) _ = (os,cm,sg,vc ,nc ,tc )++smoothGroup :: VertexBuffer -> [Object]+ -> ([Object],[[Normal3 GLfloat]],Int)+ -> ([Object],[[Normal3 GLfloat]],Int)+smoothGroup vb g (os,ns,nns) =+ (gos ++ os,gns : ns, nns + (length gns))+ where+ gos = map (applyNormals normalMap) g+ normalMap = M.fromList $ zip vs [nns..]+ gns = map (makeNormal vb g) vs+ vs = concatMap objVerticies g++applyNormals :: Map Int Int -> Object -> Object+applyNormals m (OFace mat vs) = OFace mat (appNorms m vs)+applyNormals m (OTriangle mat vs) = OTriangle mat (appNorms m vs)+applyNormals m (OQuad mat vs) = OQuad mat (appNorms m vs)+applyNormals _ x = x++appNorms :: Map Int Int -> [VTriple] -> [VTriple]+appNorms m vs = map (\(v,t,n) -> case n of+ Just _ -> (v,t,n )+ Nothing -> (v,t,M.lookup v m))+ vs++makeNormal :: VertexBuffer -> [Object] -> Int -> Normal3 GLfloat+makeNormal vb os =+ uncurry3 Normal3 . averageVec+ . map (uncurry crossProduct . createVectors+ . lookupVerticies vb)+ . (findVertexNeighbors os)+ where+ findVertexNeighbors :: [Object] -> Int -> [(Int,Int,Int)]+ findVertexNeighbors objs v = foldr (findVertexPair v) [] objs+ + findVertexPair :: Int -> Object -> [(Int,Int,Int)] -> [(Int,Int,Int)]+ findVertexPair v (OFace _ vtripples) x = findVP v vtripples x+ findVertexPair v (OTriangle _ vtripples) x = findVP v vtripples x+ findVertexPair v (OQuad _ vtripples) x = findVP v vtripples x+ findVertexPair _ _ x = x++ findVP v vtripples ns =+ maybe ns (:ns) (find3 v (map trippleVertex vtripples))+ where+ find3 :: Int -> [Int] -> Maybe (Int,Int,Int)+ find3 x ys = find3' x (length ys) $ cycle ys+ find3' :: Int -> Int -> [Int] -> Maybe (Int,Int,Int)+ find3' _ 0 _ = Nothing+ find3' x r (l:c:n:ys)+ | x == c = Just (l,c,n)+ | otherwise = find3' x (r-1) (c:n:ys)+ find3' _ _ _ =+ error "find3' called incorrectly. Input list not infinite."+ + lookupVerticies :: VertexBuffer+ -> (Int,Int,Int)+ -> (Vertex4 GLfloat,Vertex4 GLfloat,Vertex4 GLfloat)+ lookupVerticies buff (a,b,c) = (buff ! a, buff ! b, buff ! c)+ + createVectors :: (Vertex4 GLfloat,Vertex4 GLfloat,Vertex4 GLfloat)+ -> ((GLfloat,GLfloat,GLfloat),(GLfloat,GLfloat,GLfloat))+ createVectors (a,b,c) = (a .-. b,c .-. b)+ + crossProduct :: Num a => (a,a,a) -> (a,a,a) -> (a,a,a)+ crossProduct (x,y,z) (x',y',z') =+ (y * z' - z * y', z * x' - x * z', x * y' - y * x')+ + averageVec :: Floating a => [(a,a,a)] -> (a,a,a)+ averageVec [] = error "Average vectors: no vectors to average."+ averageVec xs = normalise ((sumVec (map normalise xs)) ^/ (fromIntegral $ length xs))+ + normalise :: Floating a => (a,a,a) -> (a,a,a)+ normalise x = x ^/ (mag x)+ + sumVec = foldr1 (^+^)+ + mag (x,y,z) = sqrt (x * x + y * y + z * z)+ + (^+^) (x,y,z) (x',y',z') = (x + x', y + y', z + z')+ (.-.) (Vertex4 x y z w) (Vertex4 x' y' z' w') = + (x * w - x' * w', y * w - y' * w', z * w - z' * w')+ + v ^/ s = v ^* (1 / s)+ (x,y,z) ^* s = (x * s, y * s, z * s)++objVerticies :: Object -> [Int]+objVerticies (OFace _ vs) = map trippleVertex vs+objVerticies (OTriangle _ vs) = map trippleVertex vs+objVerticies (OQuad _ vs) = map trippleVertex vs+objVerticies _ = []++mkAbs :: Int -> Int -> Int+mkAbs c x = if x < 0 then c+x else x++absoluteRefs2 :: Int -> Int -> [(Int,Maybe Int)] -> [(Int,Maybe Int)]+absoluteRefs2 c c' =+ uncurry zip . (\(x,y) -> (map (mkAbs c) x+ ,map (liftM (mkAbs c')) y)) . unzip++absoluteRefs3 :: Int -> Int -> Int -> [(Int,Maybe Int,Maybe Int)]+ -> [(Int,Maybe Int,Maybe Int)]+absoluteRefs3 c c' c'' =+ uncurry3 zip3 . (\(x,y,z) -> (map (mkAbs c) x+ ,map (liftM (mkAbs c')) y+ ,map (liftM (mkAbs c'')) z)) . unzip3++uncurry3 :: (a -> b -> c -> d) -> (a,b,c) -> d+uncurry3 f (x,y,z) = f x y z++trippleVertex :: (Int,Maybe Int,Maybe Int) -> Int+trippleVertex (v,_,_) = v++offsetObjects :: Int -> Int -> Int -> [Object] -> [Object]+offsetObjects vo no to = map (offsetObj vo no to)+offsetObj :: Int -> Int -> Int -> Object -> Object+offsetObj vo no to (OFace m ts) =+ OFace m $ map (\(x,y,z) -> (x-vo+ ,y >>= return . ((flip (-)) no)+ ,z >>= return . ((flip (-)) to))) ts+offsetObj vo no to (OTriangle m ts) =+ OTriangle m $ map (\(x,y,z) -> (x-vo+ ,y >>= return . ((flip (-)) no)+ ,z >>= return . ((flip (-)) to))) ts+offsetObj vo no to (OQuad m ts) =+ OQuad m $ map (\(x,y,z) -> (x-vo+ ,y >>= return . ((flip (-)) no)+ ,z >>= return . ((flip (-)) to))) ts+offsetObj vo _ to (OLine ts) =+ OLine $ map (\(x,z) -> (x-vo+ ,z >>= return . ((flip (-)) to))) ts+offsetObj vo _ _ (OPoint ts) =+ OPoint $ map ((flip (-)) vo) ts++objFile :: ObjModel -> ObjFile+objFile (OM (vb,tb,nb) os) =+ OF $ concat [writeBuffer vertexToV vb+ ,writeBuffer texCoordToVT tb+ ,writeBuffer normalToVN nb+ ,map writeObject (offsetObjects (-1) (-1) (-1) os)]+ where+ writeBuffer :: (a -> Statement) -> Array Int a -> [Statement]+ writeBuffer f b =+ map f $ elems b+ writeObject :: Object -> Statement+ writeObject (OFace _ fs) = F fs+ writeObject (OTriangle _ fs) = F fs+ writeObject (OQuad _ fs) = F fs+ writeObject (OLine ls) = L ls+ writeObject (OPoint ps) = P ps++vnToNormal :: Statement -> Normal3 GLfloat+vnToNormal (VN i j k) = Normal3 i j k+vnToNormal _ = error "Obj statement was not a normal."++vtToTexCoord :: Statement -> TexCoord2 GLfloat+vtToTexCoord (VT u v _) = TexCoord2 u v+vtToTexCoord _ = error "Obj statement was not a texture coordinate."++vToVertex :: Statement -> Vertex4 GLfloat+vToVertex (V x y z w) = Vertex4 x y z w+vToVertex _ = error "Obj statement was not a vertex."++vertexToV :: Vertex4 GLfloat -> Statement+vertexToV (Vertex4 x y z w) = V x y z w++normalToVN :: Normal3 GLfloat -> Statement+normalToVN (Normal3 i j k) = VN i j k++texCoordToVT :: TexCoord2 GLfloat -> Statement+texCoordToVT (TexCoord2 u v) = VT u v 0.0++prop_geomUnGeom :: ObjModel -> Property+prop_geomUnGeom x =+ ((((flip geometry) (MF M.empty)) . objFile $ x) =-= x)++geometryTests :: IO ()+geometryTests = do putStr "prop_geomUnGeom: "+ quickCheck prop_geomUnGeom
+ src/Graphics/Formats/Obj/Parse.hs view
@@ -0,0 +1,239 @@+{-# OPTIONS_GHC -Wall -fno-warn-orphans #-}+----------------------------------------------------------------------+-- |+-- Module : Graphics.Formats.Obj.Parse+-- Copyright : (c) Anygma BVBA & Thomas Davie 2008+-- License : BSD3+-- +-- Maintainer : tom.davie@gmail.com+-- Stability : experimental+-- +-- Obj file parsing+----------------------------------------------------------------------+module Graphics.Formats.Obj.Parse (parseTests,mtllibs) where++import Graphics.Formats.Obj.Contents+import Graphics.Formats.Obj.ParserBits++import Test.QuickCheck++import Data.Maybe hiding (fromJust)++import Data.Binary+import Data.Binary.Get+import Data.Binary.Put++import qualified Data.ByteString.Lazy as LBS+import qualified Data.ByteString.Char8 as CBS++import Control.Monad+import Control.Applicative++instance Binary ObjFile where+ put (OF sts) =+ forM_ sts put+ get =+ return . OF+ . catMaybes+ . map decodeStmt+ . CBS.lines+ . CBS.concat+ . LBS.toChunks =<< getRemainingLazyByteString++instance Binary Statement where+ put (V x y z w) =+ do putString "v "+ putShow x >> put ' '+ putShow y >> put ' '+ putShow z >> put ' '+ putShow w >> put ' '+ put '\n'+ put (VN x y z) =+ do putString "vn "+ putShow x >> put ' '+ putShow y >> put ' '+ putShow z >> put ' '+ put '\n'+ put (VT x y z) =+ do putString "vt "+ putShow x >> put ' '+ putShow y >> put ' '+ putShow z >> put ' '+ put '\n'+ put (P is) = put 'p' >> putList putShow is >> put '\n'+ put (L is) = put 'l' >> putList putDouble is >> put '\n'+ put (F is) = put 'f' >> putList putTriple is >> put '\n'+ put (G gs) = put 'g' >> putList putString gs >> put '\n'+ put (SG g) = putString "s " >> case g of+ Nothing -> putString "0\n"+ Just x -> putShow x >> put '\n'+ put (MtlLib m) = put "mtllib" >> putList putString m >> put '\n'+ put (UseMtl m) = put "usemtl " >> putString m >> put '\n'+ get = undefined+++putString :: String -> Put+putString = putByteString . CBS.pack++putShow :: Show a => a -> Put+putShow = putString . show++putList :: Binary a => (a -> Put) -> [a] -> Put+putList f x = forM_ x (\i -> put ' ' >> f i)++putDouble :: VDouble -> Put+putDouble (x,Just y ) = putShow x >> put '/' >> putShow y+putDouble (x,Nothing) = putShow x++putTriple :: VTriple -> Put+putTriple (v,t,n) =+ putShow v >>+ case (t,n) of+ (Nothing,Just n') -> putString "//" >> putShow n'+ _ -> put' t >> put' n+ where+ put' x = case x of+ Nothing -> return ()+ Just x' -> put '/' >> putShow x'++decodeStmt :: CBS.ByteString -> Maybe Statement+decodeStmt = decodeStmt' . consumeWS . removeComments++decodeStmt' :: CBS.ByteString -> Maybe Statement+decodeStmt' s =+ if CBS.length s > 0 then+ case CBS.head s of+ 'p' -> Just . P $ runParse parsePoints s+ 'l' -> Just . L $ runParse parseLines s+ 'f' -> Just . F $ runParse parseFace s+ 'g' -> Just . G $ runParse parseGroups s+ 's' -> Just . SG $ runParse parseSmoothGroup s+ _ -> if (CBS.pack "mtllib") `CBS.isPrefixOf` s+ then Just . MtlLib $ runParse parseMtlLib (CBS.drop 5 s)+ else if (CBS.pack "usemtl") `CBS.isPrefixOf` s+ then Just . UseMtl $ runParse parseUseMtl (CBS.drop 5 s)+ else if (CBS.pack "vn") `CBS.isPrefixOf` s+ then Just . (uncurry3 VN) $ runParse parseNormal (CBS.tail s)+ else if (CBS.pack "vt") `CBS.isPrefixOf` s+ then Just . (uncurry3 VT) $ runParse parseTexCoord (CBS.tail s)+ else if 'v' == CBS.head s+ then Just . (uncurry4 V) $ runParse parseVertex s+ else Nothing+ else Nothing++runParse :: (CBS.ByteString -> a) -> CBS.ByteString -> a+runParse x = x . consumeWS . CBS.tail++if' :: Bool -> a -> a -> a+if' c t e = if c then t else e++parsePoints :: CBS.ByteString -> [Int]+parseLines :: CBS.ByteString -> [VDouble]+parseFace :: CBS.ByteString -> [VTriple]+parsePoints = bSwords unsafeReadInt+parseLines = bSwords readDouble+parseFace = bSwords readTriple++parseGroups :: CBS.ByteString -> [String]+parseSmoothGroup :: CBS.ByteString -> Maybe Int+parseGroups = bSwords (CBS.unpack)+parseSmoothGroup g =+ if g == (CBS.pack "off")+ then Nothing+ else (if' <$> (== 0) <*> (const Nothing) <*> Just) . unsafeReadInt $ g++parseMtlLib :: CBS.ByteString -> [String]+parseUseMtl :: CBS.ByteString -> String+parseMtlLib = bSwords parseName+parseUseMtl = head . bSwords parseName++parseNormal :: CBS.ByteString -> (Float,Float,Float)+parseTexCoord :: CBS.ByteString -> (Float,Float,Float)+parseVertex :: CBS.ByteString -> (Float,Float,Float,Float)+parseNormal = normalTuple+parseTexCoord = texCoordTuple+parseVertex = vertexTuple++unsafeReadInt :: CBS.ByteString -> Int+unsafeReadInt x = case CBS.readInt x of+ Just (i,_) -> i+ Nothing -> error "unsafeReadInt: No integer to read."++readDouble :: CBS.ByteString -> VDouble+readDouble x =+ if CBS.length b > 1+ then (unsafeReadInt a, Just . unsafeReadInt $ CBS.tail b)+ else (unsafeReadInt a, Nothing)+ where+ (a,b) = CBS.break (=='/') x++-- | Read a vertex/texcoord/normal triple.+-- Triples can take these forms:+-- v, v/t, v//n, v/t/n+readTriple :: CBS.ByteString -> VTriple+readTriple vtns = + (v,t,n)+ where+ (vs,tnr) = CBS.break (=='/') vtns+ (ts,nr ) = if CBS.length tnr > 0+ then CBS.break (=='/') . CBS.tail $ tnr+ else (CBS.empty, CBS.empty)+ ns = if CBS.length nr > 0+ then CBS.tail nr+ else CBS.empty+ + v = unsafeReadInt vs+ t = getMaybeInt ts+ n = getMaybeInt ns+ + getMaybeInt x = if CBS.length x > 0+ then Just $ unsafeReadInt x+ else Nothing++normalTuple :: CBS.ByteString -> (Float,Float,Float)+normalTuple s =+ let Just (x,s' ) = unsafeRFloat s+ Just (y,s'') = unsafeRFloat s'+ Just (z,_ ) = unsafeRFloat s''+ in (x,y,z)++vertexTuple :: CBS.ByteString -> (Float,Float,Float,Float)+vertexTuple s =+ let Just (x,s' ) = unsafeRFloat s+ Just (y,s'' ) = unsafeRFloat s'+ Just (z,s''') = unsafeRFloat s''+ w = unsafeRFloat s'''+ in case w of+ Just (w',_) -> (x,y,z,w')+ Nothing -> (x,y,z,1 )++texCoordTuple :: CBS.ByteString -> (Float,Float,Float)+texCoordTuple s =+ let Just (x,s') = unsafeRFloat s+ y = unsafeRFloat s'+ in case y of+ Just (y',r) -> case unsafeRFloat r of+ Just (z,_) -> (x,y',z)+ Nothing -> (x,y',0)+ Nothing -> (x,0,0)++uncurry3 :: (a -> b -> c -> d) -> (a,b,c) -> d+uncurry3 f (x,y,z) = f x y z++uncurry4 :: (a -> b -> c -> d -> e) -> (a,b,c,d) -> e+uncurry4 f (x,y,z,w) = f x y z w++mtllibs :: ObjFile -> [String]+mtllibs (OF f) = concatMap stmtMtlLibs f++stmtMtlLibs :: Statement -> [String]+stmtMtlLibs (MtlLib xs) = xs+stmtMtlLibs _ = []++prop_parseUnParse :: ObjFile -> Bool+prop_parseUnParse x =+ (decode . encode $ x) == x++parseTests :: IO ()+parseTests = do putStr "prop_parseUnParse: "+ quickCheck prop_parseUnParse
+ src/Graphics/Formats/Obj/ParserBits.hs view
@@ -0,0 +1,79 @@+{-# LANGUAGE ForeignFunctionInterface #-}+{-# OPTIONS_GHC -funbox-strict-fields -Wall #-}+----------------------------------------------------------------------+-- |+-- Module : Graphics.Formats.Obj.ParserBits+-- Copyright : (c) Anygma BVBA & Thomas Davie 2008+-- License : BSD3+-- +-- Maintainer : tom.davie@gmail.com+-- Stability : experimental+-- +-- Common pieces of parsers for obj model parsing+----------------------------------------------------------------------+module Graphics.Formats.Obj.ParserBits+ (unsafeReadFloat,unsafeRFloat+ ,anyOf+ ,consumeWS,firstWord, bSwords,removeComments,parseName) where++import Foreign+import Foreign.C.String++import Data.ByteString.Internal+import qualified Data.ByteString.Char8 as CBS+import qualified Data.ByteString.Unsafe as BS++import Data.Maybe++import Control.Applicative hiding ((<|>))++unsafeReadFloat :: CBS.ByteString -> Float+unsafeReadFloat =+ fst . maybe (error "unsafeReadFloat: No float to read.") id . unsafeRFloat++foreign import ccall unsafe "stdlib.h strtof" + c_strtof :: CString -> Ptr CString -> IO Float++-- | Bare bones, unsafe wrapper for strtof. This provides a non-copying+-- direct parsing of Float values from a ByteString. It uses strtof+-- directly on the bytestring buffer. strtof requires the string to be+-- null terminated, or for a guarantee that parsing will find a floating+-- point value before the end of the string.+-- Taken from Bytestring's ReadDouble+unsafeRFloat :: ByteString -> Maybe (Float, ByteString)+unsafeRFloat b | CBS.null b = Nothing+unsafeRFloat b = inlinePerformIO $+ alloca $ \resptr ->+ BS.unsafeUseAsCString b $ \ptr ->+ do -- copy just the bytes we want to parse+ d <- c_strtof ptr resptr -- + newPtr <- peek resptr+ return $! case d of+ 0 | newPtr == ptr -> Nothing+ _ | otherwise ->+ let rest = BS.unsafeDrop (newPtr `minusPtr` ptr) b+ z = realToFrac d+ in z `seq` rest `seq` Just $! (z, rest)+{-# INLINE unsafeReadFloat #-}++anyOf :: [a -> Bool] -> a -> Bool+anyOf = foldr (liftA2 (||)) (const False)++bSwords :: (CBS.ByteString -> a) -> CBS.ByteString -> [a]+bSwords f = map f . filter ((>0) . CBS.length)+ . CBS.splitWith (liftA2 (||) (==' ') (=='\t'))++removeComments :: CBS.ByteString -> CBS.ByteString+removeComments bs = case CBS.split '#' bs of+ [] -> CBS.empty+ (x:_) -> x++consumeWS :: CBS.ByteString -> CBS.ByteString+consumeWS = CBS.dropWhile (liftA2 (||) (==' ') (=='\t'))++firstWord :: CBS.ByteString -> CBS.ByteString+firstWord = CBS.takeWhile ( not+ . anyOf [(==' '), (=='\t'), (=='\n'), (=='\r')])++parseName :: CBS.ByteString -> String+parseName = CBS.unpack . firstWord . consumeWS
+ src/Graphics/Formats/Obj/Tests.hs view
@@ -0,0 +1,20 @@+{-# OPTIONS_GHC -Wall #-}+----------------------------------------------------------------------+-- |+-- Module : Graphics.Formats.Obj.Tests+-- Copyright : (c) Thomas Davie 2008+-- License : MIT+-- +-- Maintainer : tom.davie@gmail.com+-- Stability : experimental+-- +-- Testing for Obj model loading+----------------------------------------------------------------------+module Graphics.Formats.Obj.Tests (runTests) where++import Graphics.Formats.Obj.Contents+import Graphics.Formats.Obj.Parse+import Graphics.Formats.Obj.ObjModel++runTests :: IO ()+runTests = contentsTests >> parseTests >> geometryTests