diff --git a/obj.cabal b/obj.cabal --- a/obj.cabal +++ b/obj.cabal @@ -1,6 +1,6 @@ Name: obj Cabal-Version: >= 1.2 -Version: 0.1.1 +Version: 0.1.2 Synopsis: Reads and writes obj models. Description: Reads and writes obj models. License: BSD3 @@ -34,7 +34,6 @@ Codec-Image-DevIL >= 0.1, InfixApplicative >= 1.0 Hs-Source-Dirs: src - Ghc-Options: -O2 Exposed-Modules: Graphics.Formats.Obj Other-Modules: Graphics.Formats.Obj.Parse Graphics.Formats.Obj.ParserBits diff --git a/src/Graphics/Formats/Mtl/Contents.hs b/src/Graphics/Formats/Mtl/Contents.hs --- a/src/Graphics/Formats/Mtl/Contents.hs +++ b/src/Graphics/Formats/Mtl/Contents.hs @@ -23,6 +23,10 @@ import qualified Data.Traversable as T import Data.List +import Foreign hiding (newArray) + +import Data.Array.Unboxed + import Graphics.Rendering.OpenGL import Control.Applicative import Control.Monad @@ -109,6 +113,39 @@ loadTexture :: FilePath -> IO TextureObject loadTexture f = buildTexture =<< readImage f + +{- Andy Gill's hacky texture loading code -} +buildTexture :: UArray (Int,Int,Int) Word8 -> IO TextureObject +buildTexture arr = + do let (width,height,mindepth) = + case bounds arr of + ((mw,mh,md),(w,h,_)) -> (w + 1 - mw,h + 1 - mh, md) + p <- mallocBytes (width * height * 4) + sequence_ + [ do pokeElemOff p (off+0) (arr ! (w,h,mindepth )) + pokeElemOff p (off+1) (arr ! (w,h,mindepth+1)) + pokeElemOff p (off+2) (arr ! (w,h,mindepth+2)) + pokeElemOff p (off+3) (arr ! (w,h,mindepth+3)) + | (off,(w,h)) <- zip [0,4 ..] [ (w,h) | w <- [ 0 .. width - 1 ] + , h <- [ 0 .. height - 1 ]] + ] + + texName <- liftM head (genObjectNames 1) + textureBinding Texture2D $= Just texName + textureFilter Texture2D $= ((Linear', Nothing), Linear') + + textureWrapMode Texture2D S $= (Repeated, Repeat) + textureWrapMode Texture2D T $= (Repeated, Repeat) + + let pd = PixelData RGBA UnsignedByte p + texImage2D Nothing + NoProxy + 0 + RGBA' + (TextureSize2D (fromIntegral width) (fromIntegral height)) + 0 + pd + return texName setName :: Material -> CBS.ByteString -> Material setName m n = m {name = n} diff --git a/src/Graphics/Formats/Obj/Contents.hs b/src/Graphics/Formats/Obj/Contents.hs --- a/src/Graphics/Formats/Obj/Contents.hs +++ b/src/Graphics/Formats/Obj/Contents.hs @@ -31,17 +31,17 @@ deriving (Show,Eq) instance Arbitrary ObjFile where - arbitrary = liftM OF arbitrary + arbitrary = 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 !Int +data Statement = V !Float !Float !Float !Float + | VN !Float !Float !Float + | VT !Float !Float !Float + | P ![Int] + | L ![VDouble] + | F ![VTriple] + | G ![Group] + | SG !Int | MtlLib ![CBS.ByteString] | UseMtl !CBS.ByteString deriving (Show,Read,Eq) @@ -81,43 +81,29 @@ coarbitrary (VTr v t n) = coarbitrary v . coarbitrary t . coarbitrary n instance Arbitrary VDouble where - arbitrary = VD <$> positive <*> maybeGen positive + arbitrary = VD <$> positive <*> maybeGen positive coarbitrary (VD v t) = coarbitrary v . coarbitrary t -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 = isFace <^(||)^> isLines <^(||)^> isPoints - -isUseMtl :: Statement -> Bool -isUseMtl (UseMtl _) = True -isUseMtl _ = False +isNormal, isTexCoord, isVertex, isPoints , isLines :: Statement -> Bool +isFace , isObject , isUseMtl, isSmoothG :: Statement -> Bool -isSmoothG :: Statement -> Bool -isSmoothG (SG _) = True -isSmoothG _ = False +isNormal (VN _ _ _ ) = True +isNormal _ = False +isTexCoord (VT _ _ _ ) = True +isTexCoord _ = False +isVertex (V _ _ _ _) = True +isVertex _ = False +isPoints (P _ ) = True +isPoints _ = False +isLines (L _ ) = True +isLines _ = False +isFace (F _ ) = True +isFace _ = False +isUseMtl (UseMtl _ ) = True +isUseMtl _ = False +isSmoothG (SG _ ) = True +isSmoothG _ = False +isObject = isFace <^(||)^> isLines <^(||)^> isPoints contentsTests :: IO () contentsTests = return () diff --git a/src/Graphics/Formats/Obj/ObjModel.hs b/src/Graphics/Formats/Obj/ObjModel.hs --- a/src/Graphics/Formats/Obj/ObjModel.hs +++ b/src/Graphics/Formats/Obj/ObjModel.hs @@ -108,8 +108,10 @@ texturedGroups = groupBy ((==) `on` texID) . sortBy (compare `on` texID) $ textured - in do colorMaterial $= Just (Front, AmbientAndDiffuse) - mapM_ (renderOs bs) (unTextured:texturedGroups) + in preservingAttrib + [AllServerAttributes] + (do colorMaterial $= Just (Front, AmbientAndDiffuse) + mapM_ (renderOs bs) (unTextured:texturedGroups)) renderOs :: BufferSet -> [FObject] -> IO () renderOs bs os = @@ -300,7 +302,7 @@ -> IObject -> ([FObject],[Normal3 GLfloat],Int) objectNormals loff vb (os,ns,nns) o = - (go : os, gns ++ ns, nns + vl) + (go : os, gns ++ ns, nns + vl) where go = applyNormals normalMap o normalMap = IM.fromList $ zip vs [(loff - nns - vl)..] @@ -320,13 +322,13 @@ -> [IObject] -> ([FObject],[Normal3 GLfloat],Int) smoothGroup loff vb (os,ns,nns) g = - (gos ++ os,gns ++ ns, nns + lgn) + (gos ++ os, gns ++ ns, nns + lgn) where - gos = map (applyNormals normalMap) g + gos = map (applyNormals normalMap) g normalMap = IM.fromList $ zip vs [(loff - nns - lgn)..] - gns = map (makeNormal vb g) vs - lgn = length gns - vs = concatMap objVerticies g + gns = map (makeNormal vb g) vs + lgn = length gns + vs = concatMap objVerticies g applyNormals :: IntMap Int -> IObject -> FObject applyNormals m (OFace mat vs) = OFace mat (appNorms m vs) @@ -447,8 +449,7 @@ (t >>= return . ((flip (-)) to)) (n-no)) ts offsetObj vo _ to (OLine ts) = - OLine $ map (\(VD v t) -> VD (v-vo) - (t >>= return . ((flip (-)) to))) ts + OLine $ map (\(VD v t) -> VD (v-vo) (t >>= return . ((flip (-)) to))) ts offsetObj vo _ _ (OPoint ts) = OPoint $ map ((flip (-)) vo) ts @@ -460,8 +461,7 @@ ,map writeObject (offsetObjects (-1) (-1) (-1) os)] where writeBuffer :: (a -> Statement) -> Array Int a -> [Statement] - writeBuffer f b = - map f $ elems b + writeBuffer f = map f . elems writeObject :: FObject -> Statement writeObject (OFace _ fs) = F (map nvToVTriple fs) writeObject (OTriangle _ fs) = F (map nvToVTriple fs) @@ -484,10 +484,10 @@ vToVertex _ = error "Obj statement was not a vertex." vertexToV :: Vertex4 GLfloat -> Statement -vertexToV (Vertex4 x y z w) = V x y z w +vertexToV (Vertex4 x y z w) = V x y z w normalToVN :: Normal3 GLfloat -> Statement -normalToVN (Normal3 i j k) = VN i j k +normalToVN (Normal3 i j k) = VN i j k texCoordToVT :: TexCoord2 GLfloat -> Statement texCoordToVT (TexCoord2 u v) = VT u v 0.0 diff --git a/src/Graphics/Formats/Obj/ParserBits.hs b/src/Graphics/Formats/Obj/ParserBits.hs --- a/src/Graphics/Formats/Obj/ParserBits.hs +++ b/src/Graphics/Formats/Obj/ParserBits.hs @@ -73,8 +73,7 @@ consumeWS = CBS.dropWhile ((==' ') <^(||)^> (=='\t')) firstWord :: CBS.ByteString -> CBS.ByteString -firstWord = CBS.takeWhile ( not - . anyOf [(==' '), (=='\t'), (=='\n'), (=='\r')]) +firstWord = CBS.takeWhile (not . anyOf [(==' '), (=='\t'), (=='\n'), (=='\r')]) parseName :: CBS.ByteString -> CBS.ByteString parseName = firstWord . consumeWS