{- BSP.hs; Mun Hon Cheong (mhch295@cse.unsw.edu.au) 2005

A module for loading Quake 3 BSP files

source code in c++ can be found at

http://www.paulsprojects.net/opengl/q3bsp/q3bsp.html

credits also go to Ben Humphrey for his excellent BSP tutorial

I might split this module up. Perhaps rendering performance
could be increased if i used Vertex Buffer Objects instead of
vertex arrays?

-}

module BSP (
   BSPMap(..),
   readBSP,
   renderBSP,
   Tree(..),
   BSPNode(..),
   BSPLeaf(..),
   BSPBrush(..),
   BSPBrushSide(..),
   isObjectVisible
  ) where

import Data.IORef
import Data.Word ( Word8, Word32 )
import Control.Exception ( bracket )
import Control.Monad ( liftM, when )
import System.IO
import System.IO.Error ( mkIOError, eofErrorType )
import Foreign
import Foreign.C.Types
import Foreign.C.String
import Foreign.Marshal.Utils
import Data.List
import Data.Typeable
import ReadImage
import Graphics.UI.GLUT
import BitSet
import Textures
import TGA
import Data.Array
import qualified Data.Array.MArray  as Arr
import qualified Data.Array.IO as IOArr
import Frustum
import Matrix
import Curves
import Data.Maybe

-------------------------------------------------------------------------------
-- lump directory indices

-- Stores player/object positions, etc..
kEntities :: Int
kEntities    = 0

-- Stores texture information
kTextures :: Int
kTextures    = 1

-- Stores the splitting planes
kPlanes     :: Int
kPlanes      = 2

-- Stores the BSP nodes
kNodes      :: Int
kNodes       = 3

-- Stores the leafs of the nodes
kLeafs :: Int
kLeafs = 4

-- Stores the leaf's indices into the faces
kLeafFaces :: Int
kLeafFaces = 5

-- Stores the leaf's indices into the brushes
kLeafBrushes :: Int
kLeafBrushes = 6

-- Stores the info of world models
kModels :: Int
kModels = 7

-- Stores the brushes info (for collision)
kBrushes :: Int
kBrushes = 8

-- Stores the brush surfaces
kBrushSides :: Int
kBrushSides = 9

-- Stores the level vertices
kVertices :: Int
kVertices = 10

-- Stores the level indices
kIndices :: Int
kIndices = 11

-- Stores the shader files (blending, anims..)
kShaders :: Int
kShaders = 12

-- Stores the faces for the level
kFaces :: Int
kFaces = 13

-- Stores the lightmaps for the level
kLightmaps :: Int
kLightmaps = 14

-- Stores extra world lighting information
kLightVolumes :: Int
kLightVolumes = 15

-- Stores PVS and cluster info (visibility)
kVisData      :: Int
kVisData    = 16

-- A constant to store the number of lumps
kMaxLumps     :: Int
kMaxLumps   = 17

-------------------------------------------------------------------------------
-- types used in this module

data BSPMap = BSPMap {
     vertexData :: !VertexArrays,
     vindices   :: !(Ptr GLint),
     leaves     :: ![BSPLeaf],
     tree     :: !Tree,
     visData    :: !(Maybe BSPVisData),
     bitset     :: !BitSet
}

type VertexArrays = (Ptr Float,Ptr Float,Ptr Float,Ptr Float,Ptr Word8)

data BSPLeaf = BSPLeaf {
    cluster    :: !Int,
    area       :: Int,
    leafMin    :: (Double,Double,Double),
    leafMax    :: (Double,Double,Double),
    leafface     :: Int,
    numOfLeafFaces   :: Int,
    leafBrush    :: Int,
    numOfLeafBrushes :: Int,
    leafFaces    :: [BSPFace],
    leafBrushes  :: [BSPBrush]
} deriving Show

data BSPFace = BSPFace {
    -- The index into the texture array
    textureObj     :: Maybe TextureObject,
    -- The index for the effects (or -1 = n/a)
    effect         :: Int,
    -- 1=polygon, 2=patch, 3=mesh, 4=billboard
    faceType       :: Int,
    -- The starting index into this face's first vertex
    startVertIndex :: Int,
    -- The number of vertices for this face
    numOfVerts     :: Int,
    -- The starting index into the indices array for this face
    startIndex     :: Int,
    -- The number of indices for this face
    numOfIndices   :: GLint,
    -- The texture index for the lightmap
    lightmapObj    :: Maybe TextureObject,
    -- The face's lightmap corner in the image
    lMapCorner     :: (Int,Int),
    -- The size of the lightmap section
    lMapSize       :: (Int,Int),
    -- The 3D origin of lightmap.
    lMapPos        :: (Float,Float,Float),
    -- The 3D space for s and t unit vectors.
    lMapVecs       :: [(Float,Float,Float)],
    -- The face normal.
    vNormal        :: (Float,Float,Float),
    -- The bezier patch dimensions.
    size           :: (Int,Int),
    faceNo         :: Int,
    patch          :: [BSPPatch],
    arrayPtrs      :: VertexPointers
} deriving Show

data BSPBrush = BSPBrush {
    brushSide      :: Int,
    numOfBrushSides    :: Int,
    brushSides     :: [BSPBrushSide],
    bTextureID     :: Int,
    textureType    :: Int
} deriving Show

data BSPBrushSide = BSPBrushSide {
    bsPlane     :: Int,
    bsPlaneNorm    :: (Double,Double,Double),
    bsPlaneDist    :: Double,
    bsTextureID    :: Int
} deriving Show

data Tree  = Leaf BSPLeaf | Branch BSPNode Tree Tree

data BSPNode = BSPNode {
    planeNormal :: (Double,Double,Double),
    dist     :: Double,
    front    :: Int,
    back     :: Int,
    nodeMin  :: (Int,Int,Int),
    nodeMax  :: (Int,Int,Int)
} deriving Show

data BSPVisData = BSPVisData {
    numOfClusters :: Int,
    bytesPerCluster :: Int,
    bitSets   :: IOArr.IOUArray Int Bool
}

data BSPLump = BSPLump {
    offset :: Int,
    len  :: Int
}  deriving Show

data BSPHeader = BSPHeader {
    strID   :: String,
    version :: Int
}  deriving Show

data BSPTexInfo = BSPTexInfo {
    strName  :: String,
    flags    :: Int,
    contents :: Int
} deriving Show

type VertexData = ([Float],[Float],[Float],[Float],[Word8])

type VertexPointers = (Ptr GLfloat, Ptr GLfloat, Ptr GLfloat, Ptr GLint)

type BSPLeafBrush = Int

type BSPLeafFace = Int

data BSPPlane = BSPPlane {
    pNormal  :: (Double,Double,Double),
    distance :: Double
} deriving Show

type BSPLightmap = Ptr Word8




-------------------------------------------------------------------------------
--BSP rendering

renderBSP :: IORef(BSPMap) -> (Double,Double,Double)-> IO()
renderBSP mapRef (x,y,z) = do
   activeTexture $= TextureUnit 0
   clientActiveTexture $= TextureUnit 0
   clientState TextureCoordArray $= Enabled
   texture Texture2D $= Enabled

   activeTexture $= TextureUnit 1
   clientActiveTexture $= TextureUnit 1
   clientState TextureCoordArray $= Enabled
   texture Texture2D $= Enabled

   map <- readIORef mapRef
   leaf <- findLeaf (x,y,z) (tree map)
   renderBSP' leaf map
   return ()


-- given a position finds a in the tree where the position lies in
findLeaf :: (Double, Double,Double) -> Tree -> IO BSPLeaf
findLeaf (x,y,z) (Branch node left right) = do
   let (px,py,pz) = (planeNormal node)
   let d = (dist node)
   let distance = (px*x)+(py*y)+(pz*z)-d
   case (distance >= 0) of
      True  -> do
                 leaf <- findLeaf (x,y,z) left
                 return leaf
      False -> do
                 leaf <- findLeaf (x,y,z) right
                 return leaf
findLeaf (x,y,z) (Leaf leaf) = do return leaf


-- we are actually going across all the leaves in the tree
-- instead of walking the tree and pushing the leaves that
-- we want to render into a stack
renderBSP' :: BSPLeaf -> BSPMap -> IO()
renderBSP' leaf map = do
   size <- sizeBS (bitset map)
   newbs <- emptyBS size
   frustum <- getFrustum
   mapM_ (renderLeaves frustum newbs visFunc map) (leaves map)
   renderBSPCleanUp
   where visFunc = (isClusterVisible (visData map) (cluster leaf))


-- we have to reset the openGL state after rendering
renderBSPCleanUp :: IO()
renderBSPCleanUp = do
    activeTexture $= TextureUnit 1
    clientState TextureCoordArray $= Disabled
    texture Texture2D $= Disabled
    activeTexture $= TextureUnit 0
    clientActiveTexture $= TextureUnit 0
    clientState TextureCoordArray $= Disabled
    texture Texture2D $= Disabled


-- renders a BSP leaf if it is visible
renderLeaves ::
   Frustum -> BitSet -> (Int -> IO Bool) -> BSPMap -> BSPLeaf -> IO()
renderLeaves  frustum bitSet func map leaf  = do
   clusterVisible <- func (cluster leaf)
   case (clusterVisible) of
      True -> case ((boxInFrustum frustum (leafMin leaf) (leafMax leaf))) of
         True -> renderFaces bitSet map (leafFaces leaf)
         _ -> return ()
      _   -> return()


-- is an object visible
isObjectVisible :: BSPMap -> Vec3 -> Vec3 -> IO Bool
isObjectVisible bsp (x,y,z) (ox,oy,oz) = do
   currentLeaf <- findLeaf (x,y,z) (tree bsp)
   objectLeaf  <- findLeaf (ox,oy,oz) (tree bsp)
   isVis   <- isClusterVisible
     (visData bsp) (cluster currentLeaf) (cluster objectLeaf)
   return (isVis)

isClusterVisible ::Maybe BSPVisData -> Int -> Int -> IO Bool
isClusterVisible (Just visdata) current target
    | current < 0 = do
     return True
    | target  < 0 = do
     return False
    | otherwise   = do
     Arr.readArray
       (bitSets visdata)
          (((bytesPerCluster visdata)*current*8) + target)


renderFaces :: BitSet -> BSPMap -> [BSPFace] -> IO()
renderFaces bitSet map [] = do return ()
renderFaces bitSet map (face:faces) = do
    isSet <- (isSetBS bitSet (faceNo face))
    case (isSet, (faceType face)) of
      (False, 1) -> do
          setBS bitSet (faceNo face)
          renderPolygonFace face (vertexData map) (vindices map)
          renderFaces bitSet map faces
      (False, 2) -> do
          setBS bitSet (faceNo face)
          renderPatches face
          renderFaces bitSet map faces
      (False, 3) -> do
          setBS bitSet (faceNo face)
          renderMeshFace face (vertexData map) (vindices map)
          renderFaces bitSet map faces
      (_  , _) -> do
          renderFaces bitSet map faces




-------------------------------------------------------------------------------
-- surface rendering

-- renders a polygon surface
renderPolygonFace :: BSPFace -> VertexArrays -> Ptr GLint -> IO ()
renderPolygonFace face (vertexPtr,texturePtr,c,d,e)  vIndex =  do
   let (a,b,c,d) = arrayPtrs face
   arrayPointer VertexArray $=
      VertexArrayDescriptor 3 Float 0 a
   clientState VertexArray $= Enabled

   activeTexture $= TextureUnit 0
   clientActiveTexture $= TextureUnit 0
   arrayPointer TextureCoordArray $=
      VertexArrayDescriptor 2 Float 0 b
   textureBinding Texture2D $= (textureObj face)

   activeTexture $= TextureUnit 1
   clientActiveTexture $= TextureUnit 1
   arrayPointer TextureCoordArray $=
      VertexArrayDescriptor 2 Float 0 c
   textureBinding Texture2D $= (lightmapObj face)

   drawRangeElements Triangles (0,(numOfIndices face))
      (numOfIndices face) UnsignedInt d
   --drawElements Triangles (numOfIndices face) UnsignedInt d


-- renders a mesh face
renderMeshFace :: BSPFace -> VertexArrays -> Ptr GLint -> IO ()
renderMeshFace face (vertexPtr,texturePtr,c,d,e)  vIndex =  do
   startVIndex <- return (startVertIndex face)
   arrayPointer VertexArray $=
      VertexArrayDescriptor 3 Float 0
         (plusPtr vertexPtr (12*(startVIndex)))
   clientState VertexArray  $= Enabled

   activeTexture $= TextureUnit 0
   clientActiveTexture $= TextureUnit 0
   arrayPointer TextureCoordArray $=
      VertexArrayDescriptor 2 Float 0
         (advancePtr texturePtr (2*(startVertIndex face)))
   clientState TextureCoordArray $= Enabled
   texture Texture2D $= Enabled
   textureBinding Texture2D $= (textureObj face)

   activeTexture $= TextureUnit 1
   clientActiveTexture $= TextureUnit 1
   arrayPointer TextureCoordArray $=
      VertexArrayDescriptor 2 Float 0 (plusPtr c (8*(startVIndex)))
   clientState TextureCoordArray $= Enabled
   texture Texture2D $= Enabled
   textureBinding Texture2D $= (lightmapObj face)

   drawRangeElements Triangles (0,fromIntegral (numOfVerts face))
      (numOfIndices face ) UnsignedInt (plusPtr vIndex (4*(startIndex face)))


-- renders patch surfaces
renderPatches :: BSPFace -> IO()
renderPatches face = do
   mapM_ (renderPatch face) (patch face)


renderPatch :: BSPFace -> BSPPatch -> IO()
renderPatch face bsppatch=  do
   arrayPointer VertexArray $=
      VertexArrayDescriptor 3 Float 28 (patchPtr bsppatch)
   clientState VertexArray $= Enabled

   activeTexture $= TextureUnit 0
   clientActiveTexture $= TextureUnit 0
   arrayPointer TextureCoordArray $=
      VertexArrayDescriptor 2 Float 28 (plusPtr (patchPtr bsppatch) 12)
   clientState TextureCoordArray $= Enabled
   texture Texture2D $= Enabled
   textureBinding Texture2D $= (textureObj face)

   activeTexture $= TextureUnit 1
   clientActiveTexture $= TextureUnit 1
   arrayPointer TextureCoordArray $=
      VertexArrayDescriptor 2 Float 28 (plusPtr (patchPtr bsppatch) 20)
   clientState TextureCoordArray $= Enabled
   texture Texture2D $= Enabled
   textureBinding Texture2D $= (lightmapObj face)

   multiDrawElements TriangleStrip (numIndexPtr bsppatch)
      UnsignedInt (indexPtrPtr bsppatch)
         (fromIntegral (patchLOD bsppatch))



-------------------------------------------------------------------------------
-- reading functions

-- reads a BSP file
readBSP :: FilePath -> IO(IORef(BSPMap))
readBSP filePath = withBinaryFile filePath $ \handle -> do
   header          <- readHeader handle
   lumps           <- mapM (readLump handle)
                        [ 0 .. (kMaxLumps -1)] :: IO [BSPLump]
   (a,b,c,d,e)     <- readVertices handle lumps
   indices         <- readIndices  handle lumps
   newbitset       <- createBitset lumps
   newVertexArrays <- dataToPointers (a,b,c,d,e)
   indexPtr        <- newArray indices
   newNodes        <- readNodes handle lumps
   newLeaves       <- readLeaves handle lumps newVertexArrays indexPtr
   newVisData      <- readVisData handle lumps
   let leafArray = listArray (0,((length newLeaves)-1)) newLeaves
   let nodeArray = listArray (0,((length newNodes)-1)) newNodes
   ntree <- constructTree nodeArray leafArray 0
   bsp <-  (newIORef ( BSPMap  {
                          vertexData = newVertexArrays,
                          vindices   = indexPtr,
                          leaves     = (reverse newLeaves),
                          tree       = ntree,
                          visData    = newVisData,
                          bitset     = newbitset
   }))
   return bsp

constructTree :: Array Int BSPNode -> Array Int BSPLeaf -> Int -> IO(Tree)
constructTree nodes leaves index = do
   case (index >= 0) of
      True  -> do
         let currentNode = (nodes ! index)
         leftNode  <- constructTree nodes leaves (front currentNode)
         rightNode <- constructTree nodes leaves (back  currentNode)
         return (Branch currentNode leftNode rightNode)
      False -> do
         let currentLeaf = (leaves ! ((-1)*(index+1)))
         return (Leaf currentLeaf)


createBitset :: [BSPLump] -> IO BitSet
createBitset lumps = do
   (offset,length) <- (getLumpData (lumps !! kFaces))
   newbitset  <- emptyBS (length `div` 104)
   return newbitset




-- - - - - - - - - - - - - - - - - - -
-- reads the BSP files header information


readHeader :: Handle -> IO BSPHeader
readHeader handle = do
   buf <- mallocBytes 4
   hGetBuf handle buf 4
   id <- mapM (peekByteOff buf) [ 0 ..  3] :: IO [CChar]
   hGetBuf handle buf cIntSize
   ver <- (peek (castPtr buf :: Ptr CInt)) :: IO CInt
   free buf
   return (BSPHeader {
              strID   = map castCCharToChar id ,
              version = (fromIntegral ver)})




-- - - - - - - - - - - - - - - - - - -
-- reads the lumps in our bsp


readLump :: Handle -> Int -> IO BSPLump
readLump handle _ = do
   buf  <- mallocBytes cIntSize
   hGetBuf handle buf cIntSize
   offs <- (peek (castPtr buf :: Ptr CInt)) :: IO CInt
   hGetBuf handle buf cIntSize
   l    <- (peek (castPtr buf :: Ptr CInt)) :: IO CInt
   free buf
   return (BSPLump {offset = (fromIntegral offs),
                    len    = (fromIntegral l)})


getLumpData :: BSPLump -> IO (Int, Int)
getLumpData lump = do return (offset lump,len lump)




-- - - - - - - - - - - - - - - - - - -
-- reads the nodes

readNodes :: Handle -> [BSPLump] -> IO [BSPNode]
readNodes handle lumps = do
   planes <- readPlanes handle lumps
   let planeArray = listArray (0,((length planes)-1)) planes
   (offset,length) <- (getLumpData (lumps !! kNodes))
   offs <- getOffsets length offset 36
   nodes <- mapM (readNode handle planeArray) offs
   return  nodes


readNode :: Handle -> Array Int BSPPlane -> Int -> IO (BSPNode)
readNode handle planeArray offset = do
   hSeek handle AbsoluteSeek (fromIntegral offset)
   buf <- mallocBytes 4
   let getCInt  =
          getAndPeek handle (castPtr buf :: Ptr CInt) (undefined :: CInt)
   let getCInts =
          getAndPeeks handle (castPtr buf :: Ptr CInt) (undefined :: CInt)
   let ints    = liftM toInts (getCInts 3)
   let get3Ints   = liftM get3t ints
   plnIndex  <- getCInt
   frt  <- getCInt
   bck  <- getCInt
   nMin <- get3Ints
   nMax <- get3Ints
   let pln = planeArray ! (fromIntegral plnIndex)
   return $ BSPNode {
               planeNormal = (pNormal pln),
               dist        = (distance pln),
               front       = fromIntegral frt,
               back        = fromIntegral bck,
               nodeMin     = nMin,
               nodeMax     = nMax
            }




-- - - - - - - - - - - - - - - - - - -
-- reads the planes in the nodes

readPlanes :: Handle -> [BSPLump] -> IO [BSPPlane]
readPlanes handle lumps = do
   (offset,length) <- (getLumpData (lumps !! kPlanes))
   hSeek handle AbsoluteSeek (fromIntegral offset)
   buf <- mallocBytes length
   hGetBuf handle buf length
   let ptrs = getPtrs buf length 16
   planes <- mapM readPlane ptrs
   free buf
   return planes

readPlane :: Ptr a -> IO (BSPPlane)
readPlane ptr = do
   [e1,e2,e3,e4] <- getFloats ptr 4
   return $ BSPPlane {
        pNormal  = (fromRational (toRational e1),
           fromRational (toRational e3),
           fromRational (toRational ((-1)*e2))),
        distance = (fromRational (toRational e4))
   }




-- - - - - - - - - - - - - - - - - - -
-- reads the leaves

readLeaves :: Handle -> [BSPLump] -> VertexArrays -> Ptr GLint -> IO [BSPLeaf]
readLeaves handle lumps vertArrays indices = do
   faces              <- readFaces handle lumps vertArrays  indices
   let faceArray      =  listArray (0,((length faces)-1))  faces
   leafFaces          <- readLeafFaces handle lumps
   let leafFaceArray  =  listArray (0,((length leafFaces)-1)) leafFaces
   brushes            <- readBrushes handle lumps
   let brushArray     =  listArray (0,((length brushes)-1)) brushes
   leafBrushes        <- readLeafBrushes handle lumps
   let leafBrushArray =  listArray (0,((length leafBrushes)-1)) leafBrushes
   (offset,length)    <- getLumpData (lumps !! kLeafs)
   hSeek handle AbsoluteSeek (fromIntegral offset)
   buf <- mallocBytes length
   hGetBuf handle buf length
   let ptrs = getPtrs buf length 48
   nodes <-
      mapM (readLeaf leafFaceArray faceArray leafBrushArray brushArray) ptrs
   free buf
   return nodes


readLeaf ::
   Array Int Int -> Array Int BSPFace ->
      Array Int Int -> Array Int BSPBrush ->Ptr a ->IO (BSPLeaf)
readLeaf leafFaceArray faceArray leafBrushArray brushArray ptr = do
   [e1,e2,e3,e4,e5,e6,e7,e8,e9,e10,e11,e12] <- getInts ptr 12
   let leafIndices  = map (leafFaceArray !) [((e9+e10)-1),((e9+e10)-2)..e9]
   let faceList     = map (faceArray !) leafIndices
   let brushIndices = map (leafBrushArray !) [e11..(e11+e12-1)]
   let brushList    = map (brushArray !) brushIndices
   return $ BSPLeaf {
        cluster          = e1,
        area             = e2,
        leafMin          = (realToFrac e3,
                            realToFrac e5,
                            realToFrac ((-1)*e4)),
        leafMax          = (realToFrac e6,
                            realToFrac e8,
                            realToFrac ((-1)*e7)),
        leafface         = e9,
        numOfLeafFaces   = e10,
        leafBrush        = e11,
        numOfLeafBrushes = e12,
        leafFaces        = faceList,
        leafBrushes      = brushList
   }




-- - - - - - - - - - - - - - - - - - -
-- huge function for reading the faces in our leaves


readFaces :: Handle -> [BSPLump] -> VertexArrays -> Ptr GLint -> IO [BSPFace]
readFaces handle lumps vertArrays indices = do
   lightMaps         <- readLightMaps handle lumps
   let lightMapArray =  listArray (0,((length lightMaps)-1)) lightMaps
   texInfos          <- readTexInfos handle lumps
   texFileNames      <- return (map strName texInfos)
   texObjs           <- getAndCreateTextures texFileNames
   let texObjArray   =  listArray (0,((length texObjs)-1)) texObjs
   (offset,length)   <- (getLumpData (lumps !! kFaces))
   offs              <- getOffsets length offset 104
   faces             <- mapM
     (readFace handle offset lightMapArray texObjArray vertArrays indices) offs
   return  faces


readFace ::
  Handle -> Int -> Array Int TextureObject -> Array Int (Maybe TextureObject)->
     VertexArrays -> Ptr GLint -> Int ->  IO (BSPFace)
readFace handle origin  lightmaps textures
  vertArrays@(a1,b1,c1,d1,e1) indices offset = do
   hSeek handle AbsoluteSeek (fromIntegral offset)
   buf <- mallocBytes 4
   let getCInts   =
          getAndPeeks handle (castPtr buf :: Ptr CInt) (undefined :: CInt)
   let getCFloats =
          getAndPeeks handle (castPtr buf :: Ptr CFloat) (undefined :: CFloat)
   let ints       = liftM toInts (getCInts 4)
   let get4Ints   = liftM get4t ints
   let floats     = liftM toFloats (getCFloats 3)
   let get3Floats = liftM get3t floats
   let twoInts    = liftM toInts (getCInts 2)
   let get2Ints   = liftM get2t twoInts
   (a,b,c,d) <- get4Ints
   (e,f,g,h) <- get4Ints
   (i,j,k,l) <- get4Ints
   lMPos     <- get3Floats
   lMVec1    <- get3Floats
   lMVec2    <- get3Floats
   norms     <- get3Floats
   sz        <- get2Ints
   free buf
   bspPatch <- checkForPatch c d sz vertArrays
   return BSPFace {
    textureObj     = textures ! a,
    effect         = b,
    faceType       = c,
    startVertIndex = d,
    numOfVerts     = e,
    startIndex     = f,
    numOfIndices   = fromIntegral g,
    lightmapObj    = fixLightmap h lightmaps,
    lMapCorner     = (i, j),
    lMapSize       = (k, l),
    lMapPos        = lMPos,
    lMapVecs       = [lMVec1,lMVec2],
    vNormal        = norms,
    size           = sz,
    faceNo         = (offset - origin)`div` 104,
    patch          = bspPatch,
    arrayPtrs      = (plusPtr a1 (12*d),
                      plusPtr b1 (8*d),
                      plusPtr c1 (8*d),
                      plusPtr indices (4*f))
    }




-- - - - - - - - - - - - - - - - - - -
-- reads the leafaces that refer to the faces

readLeafFaces :: Handle -> [BSPLump] -> IO [BSPLeafFace]
readLeafFaces handle lumps = do
   (offset,length) <- (getLumpData (lumps !! kLeafFaces))
   hSeek handle AbsoluteSeek (fromIntegral offset)
   buf <- mallocBytes length
   hGetBuf handle buf length
   leafFaces <- getInts buf (length `div` 4)
   free buf
   return leafFaces




-- - - - - - - - - - - - - - - - - - -
-- reads the brushes

readBrushes :: Handle -> [BSPLump] -> IO [BSPBrush]
readBrushes handle lumps = do
   brushSides         <- readBrushSides handle lumps
   let brushSideArray =  listArray (0,((length brushSides)-1)) brushSides
   texInfos           <- readTexInfos handle lumps
   let texInfoArray   =  listArray (0,((length texInfos)-1)) texInfos
   (offset,length)    <- (getLumpData (lumps !! kBrushes))
   hSeek handle AbsoluteSeek (fromIntegral offset)
   buf                <- mallocBytes (length)
   hGetBuf handle buf (length)
   let ptrs           = getPtrs buf (length) 12
   brushes            <- mapM (readBrush brushSideArray texInfoArray) ptrs
   free buf
   return brushes

readBrush ::  Array Int BSPBrushSide ->
   Array Int BSPTexInfo -> Ptr a ->IO (BSPBrush)
readBrush brushSideArray texInfos ptr = do
   [e1,e2,e3] <- getInts ptr 3
   let bSides = map (brushSideArray !) [e1..(e1+e2-1)]
   return $ BSPBrush {
      brushSide        = e1,
      numOfBrushSides  = e2,
      brushSides       = bSides,
      bTextureID       = e3,
      textureType      = (contents (texInfos ! e3))
   }




-- - - - - - - - - - - - - - - - - - -
-- reads the brush sides in our brushes

readBrushSides :: Handle -> [BSPLump] -> IO [BSPBrushSide]
readBrushSides handle lumps = do
   planes          <- readPlanes handle lumps
   let planeArray  =  listArray (0,((length planes)-1)) planes
   (offset,length) <- (getLumpData (lumps !! kBrushSides))
   hSeek handle AbsoluteSeek (fromIntegral offset)
   buf             <- mallocBytes (length)
   hGetBuf handle buf (length)
   let ptrs        =  getPtrs buf (length) 8
   brushSides      <- mapM (readBrushSide planeArray) ptrs
   free buf
   return brushSides

readBrushSide ::  Array Int BSPPlane -> Ptr a ->IO (BSPBrushSide)
readBrushSide planeArray ptr = do
   [e1,e2] <- getInts ptr 2
   let pln = planeArray ! (fromIntegral e1)
   return $ BSPBrushSide {
      bsPlane     = e1,
      bsPlaneNorm = (pNormal pln),
      bsPlaneDist = (distance pln),
      bsTextureID = e2
   }



-- - - - - - - - - - - - - - - - - - -
-- reads the leaf brushes that refer to the brushes

readLeafBrushes :: Handle -> [BSPLump] -> IO [BSPLeafFace]
readLeafBrushes handle lumps = do
   (offset,length) <- (getLumpData (lumps !! kLeafBrushes))
   hSeek handle AbsoluteSeek (fromIntegral offset)
   buf <- mallocBytes length
   hGetBuf handle buf length
   leafBrushes <- getInts buf (length `div` 4)
   free buf
   return leafBrushes




-- - - - - - - - - - - - - - - - - - -
-- read the PVS visibility information

readVisData :: Handle -> [BSPLump] -> IO (Maybe BSPVisData)
readVisData handle lumps = do
   (offset,length) <- (getLumpData (lumps !! kVisData))
   case length of
     0  -> do return Nothing
     _  -> do
        hSeek handle AbsoluteSeek (fromIntegral offset)
        buf <- mallocBytes length
        hGetBuf handle buf length
        cInts <- peekArray 2 (castPtr buf :: Ptr CInt)
        let [numC, bytesPerC] = toInts cInts
        bitset <-
           peekArray (numC*bytesPerC) (plusPtr (castPtr buf :: Ptr Word8) 8)
        bs <-
           Arr.newListArray (0 ,(numC*bytesPerC*8-1)) (toBools bitset)
        return (Just BSPVisData {
                        numOfClusters   = numC,
                        bytesPerCluster = bytesPerC,
                        bitSets         = bs
               })




-- - - - - - - - - - - - - - - - - - -
-- reads vertex information


readVertices :: Handle -> [BSPLump] -> IO VertexData
readVertices handle lumps = do
   (offset,length) <- getLumpData (lumps !! kVertices)
   offs            <- getOffsets length offset 44
   verts           <- mapM (readVertex handle) offs
   (v,t,l,n,r)     <- seperateArrays verts
   return  (toVertexData (concat v, concat t, concat l, concat n, concat r) )


readVertex :: Handle -> Int -> IO ([CFloat],[CFloat],[CFloat],[CFloat],[Word8])
readVertex handle offset = do
   hSeek handle AbsoluteSeek (fromIntegral offset)
   buf <- mallocBytes 4
   let getCFloats =
          getAndPeeks handle (castPtr buf :: Ptr CFloat) (undefined :: CFloat)
   let getWord8s  =
          getAndPeeks handle (castPtr buf :: Ptr Word8) (undefined :: Word8)
   let floats = (getCFloats 3)
   let get3Floats = liftM get3t floats
   (x,y,z)        <- get3Floats
   texCoords      <- getCFloats 2
   lightMapCoords <- getCFloats 2
   normals        <- getCFloats 3
   rgba           <- getWord8s  4
   free buf
   return ([x,z,(-1)*y],texCoords,lightMapCoords,normals,rgba)

dataToPointers :: VertexData -> IO VertexArrays
dataToPointers (a,b,c,d,e) = do
   a1 <- (newArray a)
   b1 <- (newArray b)
   c1 <- (newArray c)
   d1 <- (newArray d)
   e1 <- (newArray e)
   return (a1,b1,c1,d1,e1)

seperateArrays :: [([CFloat],[CFloat],[CFloat],[CFloat],[Word8])] ->
   IO ([[CFloat]],[[CFloat]],[[CFloat]],[[CFloat]],[[Word8]])
seperateArrays verts = do return (unzip5 verts)

toVertexData :: ([CFloat],[CFloat],[CFloat],[CFloat],[Word8]) -> VertexData
toVertexData (a,b,c,d,e)= (toFloats a,toFloats b,toFloats c,toFloats d,e)




-- - - - - - - - - - - - - - - - - - -
-- reads lightmaps


readLightMaps :: Handle -> [BSPLump] -> IO [TextureObject]
readLightMaps handle lumps = do
   (offset,length) <- (getLumpData (lumps !! kLightmaps))
   offs <- getOffsets length offset 49152
   lightmaps <- mapM (readLightMap handle) offs
   return lightmaps

readLightMap :: Handle -> Int -> IO TextureObject
readLightMap handle offset = do
   hSeek handle AbsoluteSeek (fromIntegral offset)
   buf <- mallocBytes 49152 :: IO (Ptr Word8)
   hGetBuf handle buf 49152
   mapM (adjustRGB buf 5.0) [0..((16384)-1)]
   texObj <-createLightmapTexture buf
   return texObj

createLightmapTexture :: Ptr Word8 -> IO TextureObject
createLightmapTexture ptr = do
   [texName] <- genObjectNames 1
   rowAlignment  Unpack $= 1
   textureBinding Texture2D $= Just texName
   build2DMipmaps
     Texture2D RGB'
        (fromIntegral 128) (fromIntegral 128)
            (PixelData RGB UnsignedByte ptr)
   textureFilter  Texture2D $= ((Linear', Just Nearest), Linear')
   textureFunction $= Modulate
   free ptr
   return texName


-- adjusts the brightness of the lightmap
adjustRGB :: Ptr Word8 -> Float -> Int -> IO ()
adjustRGB lightMap factor offset = do
   ptr <- return (advancePtr lightMap (3*offset))
   [r,g,b] <- (peekArray 3 ptr)
   (r2,tempr) <- scaleRGB (((realToFrac r)*factor)/255) 1
   (g2,tempg) <- scaleRGB (((realToFrac g)*factor)/255) tempr
   (b2,tempb) <- scaleRGB (((realToFrac b)*factor)/255) tempg
   byter2 <- return (fromIntegral (truncate (r2*tempb*255.0)))
   byteg2 <- return (fromIntegral (truncate (g2*tempb*255.0)))
   byteb2 <- return (fromIntegral (truncate (b2*tempb*255.0)))
   pokeArray (advancePtr lightMap (3*offset)) [byter2,byteg2,byteb2]

scaleRGB :: Float -> Float -> IO (Float,Float)
scaleRGB color scale = do 
                     if ((color > 1.0) && ((1.0/color) < scale))
                        then return (color, 1.0/color)
                      else
                         return (color, scale)

fixLightmap ::
    Int -> Array Int TextureObject -> Maybe TextureObject
fixLightmap index array
    | index < 0 = Nothing
    | otherwise = Just (array ! index)




-- - - - - - - - - - - - - - - - - - -
-- reads the texture information


readTexInfos :: Handle -> [BSPLump] -> IO [BSPTexInfo]
readTexInfos handle lumps = do
   (offset,length) <- (getLumpData (lumps !! kTextures))
   offs <- getOffsets length offset 72
   texture <- mapM (readTexInfo handle) offs
   return texture

readTexInfo :: Handle -> Int -> IO (BSPTexInfo)
readTexInfo handle offset = do
   hSeek handle AbsoluteSeek (fromIntegral offset)
   buf <- mallocBytes 64 :: IO (Ptr CChar)
   hGetBuf handle buf 64
   str <- peekCAString buf
   hSeek handle AbsoluteSeek ((fromIntegral offset) + 64)
   let getCInt =
         getAndPeek handle (castPtr buf :: Ptr CInt) (undefined :: CInt)
   flgs <- getCInt
   cons <- getCInt
   free buf
   return BSPTexInfo {
      strName  = str,
      flags  = (fromIntegral flgs),
      contents = (fromIntegral cons)
    }




-- - - - - - - - - - - - - - - - - - -
-- reads the indices to the vertex array


readIndices :: Handle -> [BSPLump] -> IO [GLint]
readIndices handle lumps = do
   (offset,length) <- (getLumpData (lumps !! kIndices))
   hSeek handle AbsoluteSeek (fromIntegral offset)
   buf   <- mallocBytes length
   hGetBuf handle buf length
   indices <- mapM
     (peekElemOff (castPtr buf :: Ptr CInt))
         [ 0 .. ((length `div` 4)-1)] :: IO [CInt]
   free buf
   return (map fromIntegral indices)




-- - - - - - - - - - - - - - - - - - -

getAndPeek :: (Storable a, Typeable a) => Handle -> Ptr a -> a -> IO a
getAndPeek handle buf be = do
   bytesRead <- hGetBuf handle buf (sizeOf be)
   when (bytesRead /= (sizeOf be)) $
      ioError $ mkIOError eofErrorType "hGetBufFully" (Just handle) Nothing
   val <- (peek buf)
   return val

getAndPeeks :: (Storable a, Typeable a) =>
   Handle -> Ptr a -> a -> Int -> IO [a]
getAndPeeks handle buf be i =
   mapM (\_ -> getAndPeek handle buf be) [1..i]

withBinaryFile :: FilePath -> (Handle -> IO a) -> IO a
withBinaryFile filePath = bracket (openBinaryFile filePath ReadMode) hClose

getOffsets :: Int -> Int -> Int -> IO [Int]
getOffsets length off size= do
  return (map ((off+).(size*)) [0.. ((length `div` size)-1)])

toInts :: (Integral a)=>[a] -> [Int]
toInts a = map fromIntegral a

toFloats :: (Real a) => [a] -> [Float]
toFloats a = map realToFrac a

get2t :: [a] -> (a, a)
get2t list = (list !! 0, list !! 1)

get3t :: [a] -> (a, a, a)
get3t list = (list !! 0, list !! 1, list !! 2)

get4t :: [a] -> (a, a, a, a)
get4t list = (list !! 0, list !! 1, list !! 2, list !! 3)

toBools :: [Word8] -> [Bool]
toBools list =
   [ y | x<-list, y <- map (testBit x) [0..7]]

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

cIntSize :: Int
cIntSize = (sizeOf (undefined :: CInt))

cCharSize :: Int
cCharSize = (sizeOf (undefined :: CInt))

getPtrs :: Ptr a -> Int -> Int -> [Ptr a]
getPtrs ptr length size =
   (map ((plusPtr ptr).(size*)) [0.. ((length `div` size)-1)])