content: {-# 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.DeepSeq (force)
  import Control.Exception ( bracket, evaluate )
  import Textures
  import qualified Data.HashTable.IO as HT
  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
              evaluate $ force contents
              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(fmap (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
     evaluate $ force contents
     let filteredStr =  (words (replace contents))
     let files = fmap stripExt filteredStr
     case (files == []) of
           True -> return []
           False -> return files
  
  
  
  
  -- - - - - - - - - - - - - - - - - - -
  -- used by readShader and readSkin
  
  
  stripExt :: String -> String
  stripExt str = (head (words(fmap (replace' ['.']) str)))
  
  
  findfiles :: [String] -> [(String,String)]
  findfiles [] = []
  findfiles (s:ss) = (s,(stripExt(stripPath (head ss)))):(findfiles (tail ss))
  
  replace :: String -> String
  replace str = fmap (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 (fmap (replace' ['/']) str))
  
  
  
  
  -- - - - - - - - - - - - - - - - - - -
  --  reads the textures
  
  
  readMD3Textures ::
     [FilePath] -> String ->
           IO (HT.BasicHashTable String (Maybe TextureObject))
  readMD3Textures files dir = do
                  texs <- mapM readMD3Skin files
                  let texF = concat texs
                  let unqtex = nub (fmap snd texF)
                  textures <- mapM getAndCreateTexture (fmap (dir++) unqtex)
                  let nmobj = concat $ fmap (assoc texF) (zip unqtex textures)
                  HT.fromList nmobj
  
  assoc ::
     [(String,String)] -> (String,Maybe TextureObject) ->
           [(String,Maybe TextureObject)]
  assoc list (c,d) = zip (fmap fst (Data.List.filter ((c ==).snd) list)) (cycle[d])
  
  
  
  
  -- - - - - - - - - - - - - - - - - - -
  -- reads the entire model
  
  
  
  readModel :: String -> Model -> IO (Model)
  readModel modelname weaponModel = do
     hash <- readMD3Textures
          (fmap (("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 ->
     (HT.BasicHashTable 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 (fmap 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      = (fmap 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) = (fmap (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 (fmap ("tga/models/weapons/"++) weaponTex)
     readBones handle header
     readTags handle header
     hash1 <- HT.fromList []
     objs    <- readMeshes handle header hash1
     let objs2      = fmap 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 ->
           (HT.BasicHashTable 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 ->
           (HT.BasicHashTable 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] ->
            (HT.BasicHashTable String (Maybe TextureObject)) -> IO MeshObject
  convertMesh header faceIndex texcoords vertices hashTable = do
      let verts           = fmap vert vertices
      let scaledVerts = fmap devideBy64 verts
      let keyframes       = devideIntoKeyframes (numVertices  header) scaledVerts
  
      imPTR <- mapM (Foreign.Marshal.Array.newArray) (fmap 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 <- HT.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 = fmap (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 = Data.List.filter (matchPrefix "TORSO") anms
             let lowerAnims = Data.List.filter (matchPrefix "LEGS") anms
             let bothAnims  = Data.List.filter (matchPrefix "BOTH") anms
             let fixedLower =
                     fmap (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  = fmap (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 (fmap (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 = fmap fromIntegral a
  
  toFloats :: (Real a) => [a] -> [Float]
  toFloats a = fmap 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= fmap ((plusPtr ptr).(size*)) [0.. (lngth-1)]
  
  
  