107 lines
3.8 KiB
Haskell
107 lines
3.8 KiB
Haskell
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
|