Initial commit

.gitignore

@@ -0,0 +1,2 @@
+*~
+dist

LICENSE

@@ -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.

Setup.lhs

@@ -0,0 +1,3 @@
+#!/usr/bin/env runhaskell
+> import Distribution.Simple
+> main = defaultMain

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

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