frag-1.1: src/MD3.hs
{-# LANGUAGE BangPatterns #-}
{- MD3.hs; Mun Hon Cheong (mhch295@cse.unsw.edu.au) 2005
This module has functions to read and animate MD3 models.
credits go to Ben Humphrey who wrote the MD3 tutorial
Yet another module where i'm thinking of using
vertex buffer objects instead of vertex arrays
-}
module MD3 (
readModel,
readWeaponModel,
updateAnim,
setAnim,
MD3Model(..),
Model(..),
MD3Animation(..),
AnimState(..),
drawModel,
death1,
dead1,
death2,
dead2,
death3,
dead3,
gesture,
attack1,
attack2,
dropWeap,
raiseWeap,
stand,
stand2,
walkcr,
walk,
run,
back,
swim,
jump,
land,
jumpb,
landb,
idleLegs,
idlecrLegs,
turn
)where
import Graphics.UI.GLUT
import Foreign
import Foreign.C.Types
import Foreign.C.String
import System.IO hiding (withBinaryFile)
import Control.Exception ( bracket )
import Textures
import Data.HashTable
import Data.Maybe
import Data.List
import Data.Array
import Quaternion
import Data.IORef
import Foreign.Storable
import Foreign.Marshal.Array
-------------------------------------------------------------------------------
-- Types
data MD3Bone =
MD3Bone {
minPos :: (Float,Float,Float),
maxPos :: (Float,Float,Float),
bonePos :: (Float,Float,Float),
bscale :: Float,
creator :: String
} deriving Show
data MD3Header =
MD3Header {
fileID :: String,
version :: Int,
md3FileName :: String,
numFrames :: Int,
numTags :: Int,
numMeshes :: Int,
numMaxSkins :: Int,
headerSize :: Int,
tagStart :: Int,
tagEnd :: Int,
fileSize :: Int
} deriving Show
data MD3Tag =
MD3Tag {
tagName :: String,
tagPos :: (Float,Float,Float),
rotation :: (Float,Float,Float,Float)
} deriving Show
data MD3MeshHeader =
MD3MeshHeader {
meshID :: String,
strName :: String,
numMeshFrames :: Int,
numSkins :: Int,
numVertices :: Int,
numTriangles :: Int,
triStart :: Int,
meshHeaderSize:: Int,
uvStart :: Int,
vertexStart :: Int,
meshSize :: Int
} deriving Show
data MD3Vertex =
MD3Vertex {
vert :: (Float,Float,Float),
norm :: (CUChar,CUChar)
} deriving Show
data Model =
Model {
modelRef :: !MD3Model,
weapFire :: IORef (Maybe (IO())),
pitch :: IORef (Maybe (IO())),
upperState :: IORef AnimState,
lowerState :: IORef AnimState
}
data MD3Model =
MD3Model {
numOfTags :: Int,
modelObjects :: [MeshObject],
links :: [(MD3Model,IORef(AnimState))],
auxFunc :: IORef(Maybe (IO())),
auxFunc2 :: IORef(Maybe (IO())),
tags :: Array Int [((Float,Float,Float),
(Float,Float,Float,Float))]
} |
MD3Weapon {
wmodelObjects :: IORef [MeshObject]
}
data MeshObject =
MeshObject {
numOfVerts :: Int,
numOfFaces :: NumArrayIndices,
numTexVertex :: Int,
materialID :: Maybe TextureObject,
bHasTexture :: Bool,
objName :: String,
verticesp :: Array Int (Ptr Float),
normals :: [(Float,Float,Float)],
texCoordsl :: [((Float,Float),(Float,Float),(Float,Float))],
texCoords :: Ptr Float,
vertPtr :: Ptr Float,
numIndices :: GLsizei,
vertIndex :: Ptr CInt,
indexBuf :: BufferObject,
texBuf :: BufferObject,
vertBuf :: BufferObject
}
data MD3Animation =
MD3Animation {
animName :: String,
startFrame :: Int,
endFrame :: Int,
loopFrames :: Int,
fp :: Float
} deriving Show
data AnimState =
AnimState {
anims :: !(Array Int MD3Animation),
currentAnim :: !MD3Animation,
currentFrame :: !Int,
nextFrame :: !Int,
currentTime :: !Float,
lastTime :: !Float
}
type MD3Face = (Int,Int,Int)
type MD3TexCoord = (Float,Float)
-------------------------------------------------------------------------------
-- A list of animations stored in MD3 files
animList :: [String]
animList = ["BOTH_DEATH1", --The first twirling death animation
"BOTH_DEAD1", --The end of the first twirling death animation
"BOTH_DEATH2", --The second twirling death animation
"BOTH_DEAD2", --The end of the second twirling death animation
"BOTH_DEATH3", --The back flip death animation
"BOTH_DEAD3", --The end of the back flip death animation
"TORSO_GESTURE", --The torso's gesturing animation
"TORSO_ATTACK", --The torso's attack1 animation
"TORSO_ATTACK2", --The torso's attack2 animation
"TORSO_DROP", --The torso's weapon drop animation
"TORSO_RAISE", --The torso's weapon pickup animation
"TORSO_STAND", --The torso's idle stand animation
"TORSO_STAND2", --The torso's idle stand2 animation
"LEGS_WALKCR", --The legs's crouching walk animation
"LEGS_WALK", --The legs's walk animation
"LEGS_RUN", --The legs's run animation
"LEGS_BACK", --The legs's running backwards animation
"LEGS_SWIM", --The legs's swimming animation
"LEGS_JUMP", --The legs's jumping animation
"LEGS_LAND", --The legs's landing animation
"LEGS_JUMPB", --The legs's jumping back animation
"LEGS_LANDB", --The legs's landing back animation
"LEGS_IDLE", --The legs's idle stand animation
"LEGS_IDLECR", --The legs's idle crouching animation
"LEGS_TURN"] --The legs's turn animation
-- animation index
death1 :: Int
death1 = 0
dead1 :: Int
dead1 = 1
death2 :: Int
death2 = 2
dead2 :: Int
dead2 = 3
death3 :: Int
death3 = 4
dead3 :: Int
dead3 = 5
gesture :: Int
gesture = 6
attack1 :: Int
attack1 = 7
attack2 :: Int
attack2 = 8
dropWeap :: Int
dropWeap = 9
raiseWeap :: Int
raiseWeap = 10
stand :: Int
stand = 11
stand2 :: Int
stand2 = 12
walkcr :: Int
walkcr = 6
walk :: Int
walk = 7
run :: Int
run = 8
back :: Int
back = 9
swim :: Int
swim = 10
jump :: Int
jump = 11
land :: Int
land = 12
jumpb :: Int
jumpb = 13
landb :: Int
landb = 14
idleLegs :: Int
idleLegs = 15
idlecrLegs :: Int
idlecrLegs = 16
turn :: Int
turn = 17
-------------------------------------------------------------------------------
-- Functions for updating animations
-- sets the animation in the animation state
setAnim :: (Int,AnimState) -> AnimState
setAnim (animIndex,animState)
| (animName newAnim) == (animName (currentAnim animState)) = animState
| otherwise = AnimState {
anims = anims animState,
currentAnim = newAnim,
currentFrame = startFrame newAnim,
nextFrame = nextFrame animState,
currentTime = currentTime animState,
lastTime = lastTime animState
}
where newAnim = (anims animState)! animIndex
-- updates the animation
updateAnim :: (Int,Double,AnimState) -> (Bool,AnimState)
updateAnim (animIndex,time,animState)
| snd(Data.Array.bounds(anims animState)) == 0 =
let
(haslooped,nextNF) =
cycleFrame cAnim 0 1 (currentFrame animStateN)
(t,lastT,nextCF) =
updateTime (lastTime animStateN)
(currentFrame animStateN) nextNF cAnim time
in (haslooped,AnimState {
anims = anims animStateN ,
currentAnim = currentAnim animStateN,
currentFrame = nextCF + 0,
nextFrame = nextNF + 0,
currentTime = t + 0,
lastTime = lastT + 0
})
| otherwise =
let
(haslooped,nextNF) =
cycleFrame cAnim (startFrame cAnim)
(endFrame cAnim) (currentFrame animStateN)
(t,lastT,nextCF) =
updateTime (lastTime animStateN)
(currentFrame animStateN) nextNF cAnim time
in (haslooped,AnimState {
anims = anims animStateN,
currentAnim = currentAnim animStateN ,
currentFrame = nextCF + 0,
nextFrame = nextNF + 0,
currentTime = t + 0,
lastTime = lastT + 0
})
where
animStateN = setAnim (animIndex,animState)
cAnim = (currentAnim animStateN)
-- increment the frame
cycleFrame :: MD3Animation -> Int -> Int -> Int -> (Bool,Int)
cycleFrame _ startframe endframe currentframe
| currentframe == (endframe-2) = (True,nextFrme)
| nextFrme == 0 = (False,startframe)
| otherwise = (False,nextFrme)
where
nextFrme = (currentframe + 1) `mod` endframe
updateTime :: Float -> Int -> Int -> MD3Animation-> Double ->(Float,Float,Int)
updateTime lasttime currentframe nextframe anim presentTime =
let
animSpeed = (fp anim)
presentTimef = 1000*(realToFrac presentTime)
elapsedtime = presentTimef - lasttime
t = elapsedtime/animSpeed
in case ((realToFrac elapsedtime) >= animSpeed) of
True -> (t,presentTimef ,nextframe)
_ -> (t,lasttime,currentframe)
-------------------------------------------------------------------------------
-- renders the model
drawModel :: (MD3Model,IORef(AnimState)) -> IO( )
drawModel (model,stateRef) = do
texture Texture2D $= Enabled
--texture Texture2D $= Disabled
clientState TextureCoordArray $= Enabled
clientState VertexArray $= Enabled
--clientState VertexArray $= Disabled
--clientState TextureCoordArray $= Disabled
animState <- readIORef stateRef
mapM (drawObject animState) (modelObjects model)
let currentTag = (tags model)!(currentFrame animState)
let nextTag = (tags model)!(nextFrame animState)
aux <- readIORef (auxFunc model)
aux2 <- readIORef (auxFunc2 model)
case aux2 of
Just func -> func
Nothing -> return ()
recurseDraw (currentTime animState) aux (links model) currentTag nextTag
texture Texture2D $= Disabled
recurseDraw :: Float ->
Maybe (IO())-> [(MD3Model,IORef(AnimState))] ->
[((Float,Float,Float),(Float,Float,Float,Float))] ->
[((Float,Float,Float),(Float,Float,Float,Float))] -> IO()
recurseDraw _ _ [] _ _ = return ()
recurseDraw t func ((model,state):mss)
(((c1,c2,c3),quat1):ccqs) (((n1,n2,n3),quat2):ncqs) = do
let (i1,i2,i3) = (c1+(t*(n1-c1)), c2+(t*(n2-c2)), c3+(t*(n3-c3)))
let iquat = slerp quat1 quat2 t
mat <- quat2Mat iquat (i1,i2,i3)
unsafePreservingMatrix $ do
multMatrix mat
case func of
Just f -> f
Nothing -> return ()
drawModel (model,state)
recurseDraw t func mss ccqs ncqs
-- draws a mesh object with vertex arrays
drawObject :: AnimState -> MeshObject -> IO ()
drawObject animState obj = do
let curindex = (currentFrame animState)
let nextIndex = (nextFrame animState)
case (curindex /= nextIndex) of
True -> do
convertToVertArray
(currentTime animState)
((verticesp obj)!curindex)
((verticesp obj)!nextIndex)
(vertPtr obj) 0 (numOfVerts obj)
arrayPointer VertexArray $=
VertexArrayDescriptor 3 Float 0 (vertPtr obj)
_ -> do
arrayPointer VertexArray $=
VertexArrayDescriptor 3 Float 0 ((verticesp obj)!curindex)
{-clientState VertexArray $= Enabled
lockArrays $= (Just (0, (numOfFaces obj)))-}
arrayPointer TextureCoordArray $=
VertexArrayDescriptor 2 Float 0 (texCoords obj)
{-clientState TextureCoordArray $= Enabled
texture Texture2D $= Enabled-}
textureBinding Texture2D $= (materialID obj)
{-lockArrays $= (Just (0, (numOfFaces obj)))
drawElements Triangles (numOfFaces obj) UnsignedInt (vertIndex obj)-}
drawRangeElements Triangles (0,(numOfFaces obj))
(numOfFaces obj) UnsignedInt (vertIndex obj)
{-lockArrays $= Nothing
clientState VertexArray $= Disabled
clientState TextureCoordArray $= Disabled
texture Texture2D $= Disabled-}
convertToVertArray ::
Float -> Ptr Float -> Ptr Float -> Ptr Float -> Int -> Int ->IO()
convertToVertArray t cs ns arr ind limit
| ind == limit= return()
| otherwise = do
c <- peekElemOff cs ind
n <- peekElemOff ns ind
pokeElemOff arr ind (i c n)
convertToVertArray t cs ns arr (ind+1) limit
where i x y = x+(t*(y-x))
-------------------------------------------------------------------------------
-- reads the MD3 files
readMD3Header :: Handle -> IO MD3Header
readMD3Header handle = do
buf <- mallocBytes 108
hGetBuf handle buf 108
fID <- getString buf 4
ver <- peek (plusPtr (castPtr buf :: Ptr CInt) 4)
mfilename <- getString (plusPtr buf 8) 68
[i1,i2,i3,i4,i5,i6,i7,i8] <- getInts (plusPtr buf 76) 8
free buf
return $ MD3Header {
fileID = fID,
version = ver,
md3FileName = mfilename,
numFrames = i1,
numTags = i2,
numMeshes = i3,
numMaxSkins = i4,
headerSize = i5,
tagStart = i6,
tagEnd = i7,
fileSize = i8
}
-- - - - - - - - - - - - - - - - - - -
-- reads the .skin files
readMD3Skin :: FilePath -> IO [(String,String)]
readMD3Skin filepath = withBinaryFile filepath $ \handle -> do
contents <- hGetContents handle
let filteredStr = (words (replace contents))
let files = findfiles (stripTags filteredStr)
case (files == []) of
True -> return []
False -> return files
stripTags :: [String] -> [String]
stripTags [] = []
stripTags (s:ss)
| (head (words(map (replace' ['_']) s))) == "tag" = stripTags ss
| otherwise = s:(stripTags ss)
-- - - - - - - - - - - - - - - - - - -
-- reads the shader file for the weapon
readMD3Shader :: FilePath -> IO [String]
readMD3Shader filepath = withBinaryFile filepath $ \handle -> do
contents <- hGetContents handle
let filteredStr = (words (replace contents))
let files = map stripExt filteredStr
case (files == []) of
True -> return []
False -> return files
-- - - - - - - - - - - - - - - - - - -
-- used by readShader and readSkin
stripExt :: String -> String
stripExt str = (head (words(map (replace' ['.']) str)))
findfiles :: [String] -> [(String,String)]
findfiles [] = []
findfiles (s:ss) = (s,(stripExt(stripPath (head ss)))):(findfiles (tail ss))
replace :: String -> String
replace str = map (replace' [',','\n','\r']) str
replace' :: [Char] -> Char -> Char
replace' list char
| elem char list = ' '
| otherwise = char
stripPath :: String -> String
stripPath str = splitPath!!((length splitPath)-1)
where splitPath = (words (map (replace' ['/']) str))
-- - - - - - - - - - - - - - - - - - -
-- reads the textures
readMD3Textures ::
[FilePath] -> String ->
IO (HashTable String (Maybe TextureObject))
readMD3Textures files dir = do
texs <- mapM readMD3Skin files
let texF = concat texs
let unqtex = nub (map snd texF)
textures <- mapM getAndCreateTexture (map (dir++) unqtex)
let nmobj = concat $ map (assoc texF) (zip unqtex textures)
fromList hashString nmobj
assoc ::
[(String,String)] -> (String,Maybe TextureObject) ->
[(String,Maybe TextureObject)]
assoc list (c,d) = zip (map fst (filter ((c ==).snd) list)) (cycle[d])
-- - - - - - - - - - - - - - - - - - -
-- reads the entire model
readModel :: String -> Model -> IO (Model)
readModel modelname weaponModel = do
hash <- readMD3Textures
(map (("tga/models/players/"++modelname)++)
["/head_default.skin",
"/upper_default.skin",
"/lower_default.skin"])
("models/players/"++modelname++"/")
get elapsedTime
weaponAS <- noAnims
headAS <- noAnims
(upperanims,loweranims) <-
readAnimations ("tga/models/players/"++modelname++"/animation.cfg")
let lowerS = AnimState {
anims = loweranims,
currentAnim = loweranims!8,
currentFrame = (startFrame (loweranims!8)),
nextFrame = 0,
currentTime = 0,
lastTime = 0
}
let upperS = AnimState {
anims = upperanims,
currentAnim = upperanims!6,
currentFrame = (startFrame (upperanims!6)),
nextFrame = 0,
currentTime = 0,
lastTime = 0
}
lowerstate <- newIORef lowerS
upperstate <- newIORef upperS
hed <- readMD3 ("tga/models/players/"++modelname++"/head.md3") hash []
let weapon = modelRef weaponModel
upper <- readMD3
("tga/models/players/"++modelname++"/upper.md3")
hash [("tag_weapon",(weapon,weaponAS)),("tag_head",(hed,headAS))]
lower <- readMD3
("tga/models/players/"++modelname++"/lower.md3")
hash [("tag_torso",(upper,upperstate))]
return Model {
modelRef = lower,
pitch = auxFunc lower,
weapFire = auxFunc2 weapon,
upperState = upperstate,
lowerState = lowerstate
}
-- just returns an empty animation
noAnims :: IO (IORef(AnimState))
noAnims = do
let noanim =
MD3Animation {
animName = "",
startFrame = 0,
endFrame = 0,
loopFrames = 0,
fp = 0
}
let noanimState =
AnimState {
anims = listArray (0,0) [],
currentAnim = noanim,
currentFrame = 0,
nextFrame = 0,
currentTime = 0,
lastTime = 0
}
newIORef noanimState
-- - - - - - - - - - - - - - - - - - -
-- reads a .MD3 file
readMD3 :: FilePath ->
(HashTable String (Maybe TextureObject))->
[(String,(MD3Model,IORef(AnimState)))] -> IO MD3Model
readMD3 filePath hashtable lns = withBinaryFile filePath $ \handle -> do
header <- readMD3Header handle
readBones handle header
tag <- readTags handle header
objs <- readMeshes handle header hashtable
let splittedTags = splitTags (numTags header) tag
orderedlinks <- scanTag lns tag
let trimmedTags = trimTags (map fst orderedlinks) splittedTags
let trimmedArray = listArray (0,((length trimmedTags)-1)) trimmedTags
aux <- newIORef (Nothing)
aux2 <- newIORef (Nothing)
return MD3Model {
numOfTags = numTags header,
modelObjects = objs,
links = (map snd orderedlinks),
auxFunc = aux,
auxFunc2 = aux2,
tags = trimmedArray
}
scanTag :: [(String,(MD3Model,IORef(AnimState)))] -> [MD3Tag] -> IO [(Int,(MD3Model,IORef(AnimState)))]
scanTag [] _ = return []
scanTag ((s,m):sms) tgs = do
case (findIndex ((s==) . tagName)tgs) of
Just x -> do
rest <- (scanTag sms tgs)
return ((x,m):rest)
splitTags :: Int -> [MD3Tag] -> [[MD3Tag]]
splitTags _ [] = []
splitTags n tgs = (take n tgs):(splitTags n $ drop n tgs)
trimTags ::
[Int] ->
[[MD3Tag]] ->
[[((Float,Float,Float),(Float,Float,Float,Float))]]
trimTags _ [] = []
trimTags n (t:ts) = (map (getTagpos.(t!!)) n):(trimTags n ts)
where getTagpos u = (tagPos u, rotation u)
-- - - - - - - - - - - - - - - - - - -
-- read the weapon models
readWeaponModel :: FilePath -> FilePath -> IO Model
readWeaponModel filePath shader = do
weapon <- readWeapon filePath shader
anim <- noAnims
p <- newIORef (Nothing)
wf <- newIORef (Nothing)
return Model {
modelRef = weapon,
pitch = p,
weapFire = wf,
upperState =anim,
lowerState =anim
}
readWeapon :: FilePath -> FilePath -> IO MD3Model
readWeapon filePath shader = withBinaryFile filePath $ \handle -> do
header <- readMD3Header handle
weaponTex <- (readMD3Shader shader)
texObj <- mapM getAndCreateTexture (map ("tga/models/weapons/"++) weaponTex)
readBones handle header
readTags handle header
hash1 <- (fromList hashString [])
objs <- readMeshes handle header hash1
let objs2 = map attachTex (zip texObj objs)
let emptyList = listArray (0,0) []
aux <- newIORef (Nothing)
aux2 <- newIORef (Nothing)
return MD3Model {
numOfTags = 0,
modelObjects = objs2,
links = [],
auxFunc = aux,
auxFunc2 = aux2,
tags = emptyList
}
-- attaches the texture to the weapon
attachTex :: (Maybe TextureObject,MeshObject) -> MeshObject
attachTex (texObj,object) =
MeshObject {
numOfVerts = numOfVerts object,
numOfFaces = numOfFaces object,
numTexVertex = numTexVertex object,
materialID = texObj,
bHasTexture = True,
objName = objName object,
verticesp = verticesp object,
normals = normals object,
texCoordsl = texCoordsl object,
texCoords = texCoords object,
vertPtr = vertPtr object,
numIndices = numIndices object,
vertIndex = vertIndex object,
indexBuf = indexBuf object,
texBuf = texBuf object,
vertBuf = vertBuf object
}
-- - - - - - - - - - - - - - - - - - -
-- reads the mesh information
readMeshes ::
Handle -> MD3Header ->
(HashTable String (Maybe TextureObject)) -> IO [MeshObject]
readMeshes handle header hashTable= do
posn <- hTell handle
meshObjects <- readMeshData handle posn (numMeshes header) hashTable
return meshObjects
readMeshData ::
Handle -> Integer -> Int ->
(HashTable String (Maybe TextureObject)) -> IO [MeshObject]
readMeshData handle posn meshesLeft hashTable
| meshesLeft <= 0 = return []
| otherwise = do
header <- readMD3MeshHeader handle
readSkins handle header
faces <- readFaces handle posn header
texcoords <- readTexCoords handle posn header
vertices <- readVertices handle posn header
hSeek handle AbsoluteSeek (posn+(fromIntegral (meshSize header)))
object <- convertMesh header faces texcoords vertices hashTable
objects <-
readMeshData handle
(posn+(fromIntegral (meshSize header))) (meshesLeft-1) hashTable
return (object:objects)
-- - - - - - - - - - - - - - - - - - -
-- converts the vertex, texture, face information into
-- a meshobject
convertMesh :: MD3MeshHeader ->
[MD3Face] -> [MD3TexCoord] -> [MD3Vertex] ->
(HashTable String (Maybe TextureObject)) -> IO MeshObject
convertMesh header faceIndex texcoords vertices hashTable = do
let verts = map vert vertices
let scaledVerts = map devideBy64 verts
let keyframes = devideIntoKeyframes (numVertices header) scaledVerts
imPTR <- mapM (Foreign.Marshal.Array.newArray) (map convertVert keyframes)
let facesArrayp = listArray (0,((length imPTR)-1)) imPTR
uvs <- convertTex faceIndex texcoords
uvptr <- Foreign.Marshal.Array.newArray (convertTex2 texcoords)
indces <- Foreign.Marshal.Array.newArray (convertInd faceIndex)
vPtr <- mallocBytes ((length (head keyframes))*12)
[a] <- genObjectNames 1
{-bindBuffer ArrayBuffer $= Just a
bufferData ArrayBuffer $=
(fromIntegral (3*((length (head keyframes))*3)*4),
facesArrayp!0 , StaticDraw)
arrayPointer VertexArray $=
VertexArrayDescriptor 3 Float 0 nullPtr-}
[b] <- genObjectNames 1
{-bindBuffer ArrayBuffer $= Just b
bufferData ArrayBuffer $=
(fromIntegral (4*(length (convertTex2 texcoords))),
uvptr, StaticDraw)
arrayPointer TextureCoordArray $=
VertexArrayDescriptor 2 Float 0 nullPtr-}
[c] <- genObjectNames 1
{-bindBuffer ElementArrayBuffer $= Just c
bufferData ElementArrayBuffer $=
(fromIntegral ((fromIntegral (length (head faces)))*12),
indices, StaticDraw)
arrayPointer TextureCoordArray $=
VertexArrayDescriptor 2 Float 0 nullPtr-}
tex <- (Data.HashTable.lookup hashTable (strName header))
return MeshObject {
numOfVerts = (length (head keyframes))*3,
numOfFaces = 3*(fromIntegral (numTriangles header)),
numTexVertex = numVertices header,
materialID = fromJust tex,
bHasTexture = False,
objName = strName header,
verticesp = facesArrayp,
normals = [],
texCoords = uvptr,
texCoordsl = uvs,
vertPtr = vPtr,
numIndices = fromIntegral ((numTriangles header)*3),
vertIndex = indces,
indexBuf = c,
texBuf = b,
vertBuf = a
}
convertInd :: [(Int,Int,Int)] -> [CInt]
convertInd [] = []
convertInd ((i1,i2,i3):is) =
[fromIntegral i1,fromIntegral i2,fromIntegral i3]++(convertInd is)
convertTex2 :: [(Float,Float)] -> [Float]
convertTex2 [] = []
convertTex2 ((u,v):uvs) = [u,v]++(convertTex2 uvs)
convertVert :: [(Float,Float,Float)] -> [Float]
convertVert [] = []
convertVert ((x,y,z):xyzs) = [x,y,z]++(convertVert xyzs)
convertTex ::
[(Int,Int,Int)] ->
[(Float,Float)] ->
IO [((Float,Float),(Float,Float),(Float,Float))]
convertTex indces uvs = do
let uvarray = listArray (0,((length uvs)-1)) uvs
let uv = map (getUVs uvarray) indces
return uv
getUVs ::
Array Int (Float,Float) ->
(Int,Int,Int) ->
((Float,Float),(Float,Float),(Float,Float))
getUVs uvs (i1,i2,i3) = (uvs ! i1, uvs ! i2 , uvs ! i3)
devideIntoKeyframes :: Int ->
[(Float,Float,Float)] -> [[(Float,Float,Float)]]
devideIntoKeyframes _ [] = []
devideIntoKeyframes n verts =
(take n verts):(devideIntoKeyframes n (drop n verts))
devideBy64 :: (Float,Float,Float) -> (Float,Float,Float)
devideBy64 (x,y,z) = (x / 64,y /64,z / 64)
-- - - - - - - - - - - - - - - - - - -
-- reads the vertices
readVertices ::
Handle -> Integer -> MD3MeshHeader -> IO [MD3Vertex]
readVertices handle posn header = do
hSeek handle AbsoluteSeek (posn+(fromIntegral (vertexStart header)))
buf <- mallocBytes ((numMeshFrames header)*(numVertices header)*8)
hGetBuf handle buf ((numMeshFrames header)*(numVertices header)*8)
let ptrs = getPtrs buf ((numMeshFrames header)*(numVertices header)) 8
triangles <- mapM readVertex ptrs
free buf
return triangles
readVertex :: Ptr a -> IO MD3Vertex
readVertex ptr = do
[f1,f2,f3] <- peekArray 3 (castPtr ptr :: Ptr CShort)
[n1,n2] <- peekArray 2 (plusPtr (castPtr ptr :: Ptr CUChar) 6)
return MD3Vertex {
vert =(realToFrac f1,realToFrac f2,realToFrac f3),
norm = (n1,n2)
}
-- - - - - - - - - - - - - - - - - - -
-- reads the texture coordinates
readTexCoords :: Handle -> Integer -> MD3MeshHeader -> IO [MD3TexCoord]
readTexCoords handle posn header = do
hSeek handle AbsoluteSeek (posn+(fromIntegral (uvStart header)))
buf <- mallocBytes ((numVertices header)*8)
hGetBuf handle buf ((numVertices header)*8)
let ptrs = getPtrs buf (numVertices header) 8
texcoords <- mapM readTexCoord ptrs
free buf
return texcoords
readTexCoord :: Ptr a -> IO MD3TexCoord
readTexCoord ptr = do [f1,f2] <- getFloats ptr 2
return (f1,f2)
-- - - - - - - - - - - - - - - - - - -
-- reads the models faces
readFaces :: Handle -> Integer -> MD3MeshHeader -> IO [MD3Face]
readFaces handle posn header = do
hSeek handle AbsoluteSeek (posn+(fromIntegral (triStart header)))
buf <- mallocBytes ((numTriangles header)*12)
hGetBuf handle buf ((numTriangles header)*12)
let ptrs = getPtrs buf (numTriangles header) 12
faces <- mapM readFace ptrs
free buf
return faces
readFace :: Ptr a -> IO MD3Face
readFace ptr = do
[f1,f2,f3] <- getInts ptr 3
return (f1,f2,f3)
-- - - - - - - - - - - - - - - - - - -
-- reads the MD3 skins
readSkins ::Handle -> MD3MeshHeader -> IO [String]
readSkins handle header = do
buf <- mallocBytes ((numSkins header)*68)
hGetBuf handle buf ((numSkins header)*68)
let skinPtrs = getPtrs buf (numSkins header) 68
skins <- mapM readSkin skinPtrs
free buf
return skins
readSkin :: Ptr a -> IO String
readSkin buf = do
skin <- getString buf 68
return skin
-- - - - - - - - - - - - - - - - - - -
-- reads a meshheader
readMD3MeshHeader :: Handle -> IO MD3MeshHeader
readMD3MeshHeader handle = do
buf <- mallocBytes 108
hGetBuf handle buf 108
mID <- getString buf 4
meshName <- getString (plusPtr buf 4) 68
[i1,i2,i3,i4,i5,i6,i7,i8,i9] <- getInts (plusPtr buf 72) 9
free buf
return $
MD3MeshHeader {
meshID = mID,
strName = meshName,
numMeshFrames = i1,
numSkins = i2,
numVertices = i3,
numTriangles = i4,
triStart = i5,
meshHeaderSize= i6,
uvStart = i7,
vertexStart = i8,
meshSize = i9
}
-- - - - - - - - - - - - - - - - - - -
-- reads the tags
readTags :: Handle -> MD3Header -> IO [MD3Tag]
readTags handle header = do
buf <- mallocBytes (112*(numFrames header)*(numTags header))
hGetBuf handle buf (112*(numFrames header)*(numTags header))
let ptrs = getPtrs buf ((numFrames header)*(numTags header)) 112
tgs <- mapM readTag ptrs
free buf
return tgs
readTag :: Ptr a -> IO MD3Tag
readTag buf = do
tName <- getString buf 64
[f1,f2,f3,f4,f5,f6,f7,f8,f9,f10,f11,f12] <- getFloats (plusPtr buf 64) 12
let quat = mat2Quat ((f4,f5,f6),(f7,f8,f9),(f10,f11,f12))
return $ MD3Tag {
tagName = tName,
tagPos =(f1,f2,f3),
rotation = quat
}
-- - - - - - - - - - - - - - - - - - -
-- reads the bones which we don't use
readBones :: Handle -> MD3Header -> IO [MD3Bone]
readBones handle header = do
buf <- mallocBytes (56*(numFrames header))
hGetBuf handle buf (56*(numFrames header))
let ptrs = getPtrs buf (numFrames header) 56
bones <- mapM readBone ptrs
free buf
return bones
readBone :: Ptr a-> IO MD3Bone
readBone buf = do
[f1,f2,f3,f4,f5,f6,f7,f8,f9,f10] <- getFloats buf 10
string <- getString (plusPtr buf 40) 16
return MD3Bone {
minPos = (f1,f2,f3),
maxPos = (f4,f5,f6),
bonePos = (f7,f8,f9),
bscale = f10,
creator = string
}
-- - - - - - - - - - - - - - - - - - -
-- reads animations from the animation.cfg file
readAnimations ::
FilePath -> IO (Array Int MD3Animation,Array Int MD3Animation)
readAnimations filepath = withBinaryFile filepath $ \handle -> do
lnes <- readLines handle
animsl <- mapM readAnimation lnes
let anms = concat animsl
let upperAnims = filter (matchPrefix "TORSO") anms
let lowerAnims = filter (matchPrefix "LEGS") anms
let bothAnims = filter (matchPrefix "BOTH") anms
let fixedLower =
map (fixLower $ (startFrame $ head lowerAnims)-
(startFrame $ head upperAnims)) lowerAnims
return (listArray
(0,((length (bothAnims++upperAnims))-1))
(bothAnims++upperAnims),
listArray (0,((length (bothAnims++fixedLower))-1))
(bothAnims++fixedLower))
readAnimation :: String -> IO [MD3Animation]
readAnimation line
| length subStrings <= 0 = do
return []
| length subStrings >= 5 =
case (elem (subStrings !! 4) animList) of
True -> do
let startF = (read $ subStrings!!0):: Int
let numF = (read $ subStrings!!1):: Int
let loopF = (read $ subStrings!!2):: Int
let f = (read $ subStrings!!3):: Int
let aName = subStrings!!4
return [MD3Animation {
animName = aName,
startFrame = startF,
endFrame = startF + numF,
loopFrames = loopF,
fp = 1000 * (1 / realToFrac f)
}]
_ -> return []
| otherwise = do
return []
where
replc str = map (replace' ['/','\n','\r']) str
subStrings = (words (replc line))
fixLower :: Int -> MD3Animation -> MD3Animation
fixLower offset anim = MD3Animation {
animName = animName anim,
startFrame = (startFrame anim) - offset,
endFrame = (endFrame anim) - offset,
loopFrames = loopFrames anim,
fp = fp anim
}
matchPrefix :: String -> MD3Animation -> Bool
matchPrefix prefix anim =
prefix == head (words (map (replace' ['_']) (animName anim)))
readLines :: Handle -> IO [String]
readLines handle = do
eof <- hIsEOF handle
case (eof) of
False -> do
lne <- hGetLine handle
lnes <- readLines handle
return (lne:lnes)
_ -> return []
-------------------------------------------------------------------------------
withBinaryFile :: FilePath -> (Handle -> IO a) -> IO a
withBinaryFile filePath = bracket (openBinaryFile filePath ReadMode) hClose
toInts :: (Integral a)=>[a] -> [Int]
toInts a = map fromIntegral a
toFloats :: (Real a) => [a] -> [Float]
toFloats a = map realToFrac a
getInts :: Ptr a -> Int -> IO [Int]
getInts ptr n = do ints <- peekArray n (castPtr ptr:: Ptr CInt)
return $ toInts ints
getFloats :: Ptr a -> Int -> IO [Float]
getFloats ptr n = do floats <- peekArray n (castPtr ptr :: Ptr CFloat)
return $ toFloats floats
getString :: Ptr a -> Int -> IO String
getString ptr _ = do string <- peekCString (castPtr ptr :: Ptr CChar)
return string
getPtrs :: Ptr a -> Int -> Int -> [Ptr a]
getPtrs ptr lngth size= map ((plusPtr ptr).(size*)) [0.. (lngth-1)]