diff options
| -rw-r--r-- | .gitignore | 2 | ||||
| -rw-r--r-- | LICENSE | 26 | ||||
| -rw-r--r-- | Setup.lhs | 3 | ||||
| -rw-r--r-- | obj-model-gl.cabal | 16 | ||||
| -rw-r--r-- | src/Data/Obj3D/GL.hs | 106 |
5 files changed, 153 insertions, 0 deletions
diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..733412c --- /dev/null +++ b/.gitignore @@ -0,0 +1,2 @@ +*~ +dist @@ -0,0 +1,26 @@ +Copyright (c) The Regents of the University of California. +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. +2. 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. +3. Neither the name of the University 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 REGENTS 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 REGENTS 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.lhs b/Setup.lhs new file mode 100644 index 0000000..5bde0de --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +> import Distribution.Simple +> main = defaultMain diff --git a/obj-model-gl.cabal b/obj-model-gl.cabal new file mode 100644 index 0000000..b64098a --- /dev/null +++ b/obj-model-gl.cabal @@ -0,0 +1,16 @@ +name: obj-model-gl +version: 0.1 +synopsis: OBJ model file loader OpenGL glue +description: Provides functions to prepare OBJ model data for efficient access from OpenGL +category: Graphics +license: BSD3 +license-file: LICENSE +author: Matthias Schiffer +maintainer: matthias@gamezock.de +build-type: Simple +Cabal-Version: >=1.2 + +library + build-depends: base >= 4, obj-model, containers, mtl, OpenGL + exposed-modules: Data.Obj3D.GL + hs-source-dirs: src diff --git a/src/Data/Obj3D/GL.hs b/src/Data/Obj3D/GL.hs new file mode 100644 index 0000000..fb089ba --- /dev/null +++ b/src/Data/Obj3D/GL.hs @@ -0,0 +1,106 @@ +module Data.Obj3D.GL ( InterleavedObj + , interleavedArrayFormat + , indexArrayFormat + , interleaveObj + , makeInterleavedArrays + , bindInterleavedArrays + , drawObject + , GLuint + , ForeignPtr + ) where + +import Data.Obj3D + +import Control.Arrow +import Control.Monad.State +import Data.Function (on) +import Data.List (genericIndex, sortBy) +import Data.Maybe +import Graphics.Rendering.OpenGL.GL (GLfloat, GLuint) +import Graphics.Rendering.OpenGL.GL.BeginEnd (PrimitiveMode(..)) +import Graphics.Rendering.OpenGL.GL.VertexArrays (DataType(..), InterleavedArrays(..), interleavedArrays, drawElements) +import Foreign.ForeignPtr +import Foreign.Marshal.Array (pokeArray) +import Foreign.Ptr +import Foreign.Storable + +import qualified Data.Map as M + + +data InterleavedObj = InterleavedObj + { texCoordS :: GLfloat + , texCoordT :: GLfloat + , normalX :: GLfloat + , normalY :: GLfloat + , normalZ :: GLfloat + , vertexX :: GLfloat + , vertexY :: GLfloat + , vertexZ :: GLfloat + } deriving Show + +instance Storable InterleavedObj where + sizeOf _ = 8 * sizeOf (undefined :: GLfloat) + alignment _ = alignment (undefined :: GLfloat) + + peek _ = fail "Can't read InterleavedObj" + + poke ptr obj = pokeArray (castPtr ptr) $ map ($ obj) [texCoordS, texCoordT, normalX, normalY, normalZ, vertexX, vertexY, vertexZ] + +interleavedArrayFormat :: InterleavedArrays +interleavedArrayFormat = T2fN3fV3f + +indexArrayFormat :: DataType +indexArrayFormat = UnsignedInt + + +type Interleaver a = State (Integer, M.Map FaceVertex Integer) a + + +getIndex :: FaceVertex -> Interleaver Integer +getIndex v = do + ix <- gets $ M.lookup v . snd + case ix of + Just i -> return i + Nothing -> do + i <- gets $ fst + modify $ (+1) *** (M.insert v i) + return i + +makeVertexData :: ObjModel -> FaceVertex -> InterleavedObj +makeVertexData model (v, t, n) = InterleavedObj ts tt nx ny nz vx vy vz + where + (vx, vy, vz) = genericIndex (objVertices model) v + (ts, tt) = if isJust t then genericIndex (objTexCoords model) $ fromJust t else (0, 0) + (nx, ny, nz) = if isJust n then genericIndex (objNormals model) $ fromJust n else (0, 0, 0) + + +interleaveObj :: ObjModel -> ([InterleavedObj], [[Integer]]) +interleaveObj model = evalState interleaveObj' (0, M.empty) + where + interleaveObj' :: Interleaver ([InterleavedObj], [[Integer]]) + interleaveObj' = do + indices <- forM (objFaces model) $ mapM getIndex . concatMap (\(v1, v2, v3) -> [v1, v2, v3]) + + packedVertices <- gets $ map fst . sortBy (compare `on` snd) . M.toList . snd + + return (map (makeVertexData model) packedVertices, indices) + +makeInterleavedArrays :: ObjModel -> IO (ForeignPtr InterleavedObj, [(ForeignPtr GLuint, Int)]) +makeInterleavedArrays model = do + let (vertexdata, indices) = interleaveObj model + + interleavedptr <- mallocForeignPtrArray $ length vertexdata + withForeignPtr interleavedptr $ \ptr -> pokeArray ptr vertexdata + + indexptrs <- forM indices $ \objindices -> do + indexptr <- mallocForeignPtrArray $ length objindices + withForeignPtr indexptr $ \ptr -> pokeArray ptr $ map fromIntegral objindices + return (indexptr, length objindices) + + return (interleavedptr, indexptrs) + +bindInterleavedArrays :: ForeignPtr InterleavedObj -> IO () +bindInterleavedArrays obj = withForeignPtr obj $ interleavedArrays interleavedArrayFormat 0 + +drawObject :: ForeignPtr GLuint -> Int -> IO () +drawObject buf l = withForeignPtr buf $ drawElements Triangles (fromIntegral l) indexArrayFormat |