1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
|
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) = rtf3 $ genericIndex (objVertices model) v
(tu, tv) = rtf2 $ if isJust t then genericIndex (objTexCoords model) $ fromJust t else (0, 0)
(nx, ny, nz) = rtf3 $ if isJust n then genericIndex (objNormals model) $ fromJust n else (0, 0, 0)
rtf2 (x, y) = (realToFrac x, realToFrac y)
rtf3 (x, y, z) = (realToFrac x, realToFrac y, realToFrac z)
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
|
