Initial commit

1 files changed, 106 insertions, 0 deletions

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