Renamed obj-model-gl to obj-model-opengl

1 files changed, 107 insertions, 0 deletions

diff --git a/src/Data/Obj3D/OpenGL.hs b/src/Data/Obj3D/OpenGL.hs
new file mode 100644
index 0000000..0e9b5c5
--- /dev/null
+++ b/src/Data/Obj3D/OpenGL.hs
@@ -0,0 +1,107 @@
+module Data.Obj3D.OpenGL ( Interleaved
+                         , InterleavedObj
+                         , interleavedArrayFormat
+                         , indexArrayFormat
+                         , interleaveObj
+                         , makeInterleavedArrays
+                         , bindInterleavedArrays
+                         , drawObject
+                         ) 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 Interleaved = Interleaved
+    { texCoordS :: GLfloat
+    , texCoordT :: GLfloat
+    , normalX   :: GLfloat
+    , normalY   :: GLfloat
+    , normalZ   :: GLfloat
+    , vertexX   :: GLfloat
+    , vertexY   :: GLfloat
+    , vertexZ   :: GLfloat
+    } deriving Show
+
+instance Storable Interleaved where
+    sizeOf _ = 8 * sizeOf (undefined :: GLfloat)
+    alignment _ = alignment (undefined :: GLfloat)
+    
+    peek _ = fail "Can't read Interleaved"
+    
+    poke ptr obj = pokeArray (castPtr ptr) $ map ($ obj) [texCoordS, texCoordT, normalX, normalY, normalZ, vertexX, vertexY, vertexZ]
+
+type InterleavedObj = (ForeignPtr Interleaved, [(ForeignPtr GLuint, Int)])
+
+type Interleaver a = State (Integer, M.Map FaceVertex Integer) a
+
+interleavedArrayFormat :: InterleavedArrays
+interleavedArrayFormat = T2fN3fV3f
+
+indexArrayFormat :: DataType
+indexArrayFormat = UnsignedInt
+
+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 -> Interleaved
+makeVertexData model (v, t, n) = Interleaved tu (-tv) nx ny nz vx vy vz
+    where
+      (vx, vy, vz) = genericIndex (objVertices model) v
+      (tu, tv) = 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 -> ([Interleaved], [[Integer]])
+interleaveObj model = evalState interleaveObj' (0, M.empty)
+    where
+      interleaveObj' :: Interleaver ([Interleaved], [[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 InterleavedObj
+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 :: InterleavedObj -> IO ()
+bindInterleavedArrays (obj, _) = withForeignPtr obj $ interleavedArrays interleavedArrayFormat 0
+
+drawObject :: InterleavedObj -> Int -> IO ()
+drawObject (_, bufs) i = withForeignPtr buf $ drawElements Triangles (fromIntegral l) indexArrayFormat
+    where
+      (buf, l) = bufs!!i