frag-1.1: src/BSP.hs
{-# LANGUAGE BangPatterns #-}
{- 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 Control.Exception ( bracket )
import Control.Monad ( liftM, when )
import System.IO hiding (withBinaryFile)
import System.IO.Error ( mkIOError, eofErrorType )
import Foreign
import Foreign.C.Types
import Foreign.C.String
import Data.List
import Data.Typeable
import Graphics.UI.GLUT
import BitSet
import Textures
import Data.Array
import qualified Data.Array.MArray as Arr (readArray, newListArray)
import qualified Data.Array.IO as IOArr hiding (readArray, newListArray)
import Frustum
import Matrix
import Curves
import Data.Maybe
-------------------------------------------------------------------------------
-- lump directory indices
-- 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 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 faces for the level
kFaces :: Int
kFaces = 13
-- Stores the lightmaps for the level
kLightmaps :: Int
kLightmaps = 14
-- 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 BSPLeafFace = Int
data BSPPlane = BSPPlane {
pNormal :: (Double,Double,Double),
distance :: Double
} deriving Show
-------------------------------------------------------------------------------
--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
mp <- readIORef mapRef
leaf <- findLeaf (x,y,z) (tree mp)
renderBSP' leaf mp
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 dstnc = (px*x)+(py*y)+(pz*z)-d
case (dstnc >= 0) of
True -> do
leaf <- findLeaf (x,y,z) left
return leaf
False -> do
leaf <- findLeaf (x,y,z) right
return leaf
findLeaf (_,_,_) (Leaf leaf) = 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 mp = do
sze <- sizeBS $ bitset mp
newbs <- emptyBS sze
frstm <- getFrustum
mapM_ (renderLeaves frstm newbs visFunc mp) (leaves mp)
renderBSPCleanUp
where visFunc = (isClusterVisible (visData mp) (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 frstm bitSet func mp leaf = do
clusterVisible <- func (cluster leaf)
case (clusterVisible) of
True -> case ((boxInFrustum frstm (leafMin leaf) (leafMax leaf))) of
True -> renderFaces bitSet mp (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)
isClusterVisible _ _ _ = return False
renderFaces :: BitSet -> BSPMap -> [BSPFace] -> IO()
renderFaces _ _ [] = return ()
renderFaces bitSet mp (face:faces) = do
isSet <- (isSetBS bitSet (faceNo face))
case (isSet, (faceType face)) of
(False, 1) -> do
setBS bitSet (faceNo face)
renderPolygonFace face (vertexData mp) (vindices mp)
renderFaces bitSet mp faces
(False, 2) -> do
setBS bitSet (faceNo face)
renderPatches face
renderFaces bitSet mp faces
(False, 3) -> do
setBS bitSet (faceNo face)
renderMeshFace face (vertexData mp) (vindices mp)
renderFaces bitSet mp faces
(_ , _) -> do
renderFaces bitSet mp faces
-------------------------------------------------------------------------------
-- surface rendering
-- renders a polygon surface
renderPolygonFace :: BSPFace -> VertexArrays -> Ptr GLint -> IO ()
renderPolygonFace face (_,_,_,_,_) _ = 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,_,_) 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
readHeader handle
lumps <- mapM (readLump handle)
[ 0 .. (kMaxLumps -1)] :: IO [BSPLump]
(a,b,c,d,e) <- readVertices handle lumps
indcs <- readIndices handle lumps
newbitset <- createBitset lumps
newVertexArrays <- dataToPointers (a,b,c,d,e)
indexPtr <- newArray indcs
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 lvs ind = do
case (ind >= 0) of
True -> do
let currentNode = (nodes ! ind)
leftNode <- constructTree nodes lvs (front currentNode)
rightNode <- constructTree nodes lvs (back currentNode)
return (Branch currentNode leftNode rightNode)
False -> do
let currentLeaf = (lvs ! ((-1)*(ind+1)))
return (Leaf currentLeaf)
createBitset :: [BSPLump] -> IO BitSet
createBitset lumps = do
(_,lngth) <- (getLumpData (lumps !! kFaces))
newbitset <- emptyBS (lngth `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 = 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
(offst,lngth) <- (getLumpData (lumps !! kNodes))
offs <- getOffsets lngth offst 36
nodes <- mapM (readNode handle planeArray) offs
return nodes
readNode :: Handle -> Array Int BSPPlane -> Int -> IO (BSPNode)
readNode handle planeArray offst = do
hSeek handle AbsoluteSeek (fromIntegral offst)
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
(offst,lngth) <- (getLumpData (lumps !! kPlanes))
hSeek handle AbsoluteSeek (fromIntegral offst)
buf <- mallocBytes lngth
hGetBuf handle buf lngth
let ptrs = getPtrs buf lngth 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 indcs = do
faces <- readFaces handle lumps vertArrays indcs
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
(offst,lngth) <- getLumpData (lumps !! kLeafs)
hSeek handle AbsoluteSeek (fromIntegral offst)
buf <- mallocBytes lngth
hGetBuf handle buf lngth
let ptrs = getPtrs buf lngth 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 indcs = 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
(offst,lngth) <- (getLumpData (lumps !! kFaces))
offs <- getOffsets lngth offst 104
faces <- mapM
(readFace handle offst lightMapArray texObjArray vertArrays indcs) 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,_,_) indcs offst = do
hSeek handle AbsoluteSeek (fromIntegral offst)
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 = (offst - origin)`div` 104,
patch = bspPatch,
arrayPtrs = (plusPtr a1 (12*d),
plusPtr b1 (8*d),
plusPtr c1 (8*d),
plusPtr indcs (4*f))
}
-- - - - - - - - - - - - - - - - - - -
-- reads the leafaces that refer to the faces
readLeafFaces :: Handle -> [BSPLump] -> IO [BSPLeafFace]
readLeafFaces handle lumps = do
(offst,lngth) <- (getLumpData (lumps !! kLeafFaces))
hSeek handle AbsoluteSeek (fromIntegral offst)
buf <- mallocBytes lngth
hGetBuf handle buf lngth
leaffaces <- getInts buf (lngth `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
(offst,lngth) <- (getLumpData (lumps !! kBrushes))
hSeek handle AbsoluteSeek (fromIntegral offst)
buf <- mallocBytes (lngth)
hGetBuf handle buf (lngth)
let ptrs = getPtrs buf (lngth) 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
(offst,lngth) <- (getLumpData (lumps !! kBrushSides))
hSeek handle AbsoluteSeek (fromIntegral offst)
buf <- mallocBytes (lngth)
hGetBuf handle buf (lngth)
let ptrs = getPtrs buf (lngth) 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
(offst,lngth) <- (getLumpData (lumps !! kLeafBrushes))
hSeek handle AbsoluteSeek (fromIntegral offst)
buf <- mallocBytes lngth
hGetBuf handle buf lngth
leafbrushes <- getInts buf (lngth `div` 4)
free buf
return leafbrushes
-- - - - - - - - - - - - - - - - - - -
-- read the PVS visibility information
readVisData :: Handle -> [BSPLump] -> IO (Maybe BSPVisData)
readVisData handle lumps = do
(offst,lngth) <- (getLumpData (lumps !! kVisData))
case lngth of
0 -> return Nothing
_ -> do
hSeek handle AbsoluteSeek (fromIntegral offst)
buf <- mallocBytes lngth
hGetBuf handle buf lngth
cInts <- peekArray 2 (castPtr buf :: Ptr CInt)
let [numC, bytesPerC] = toInts cInts
bitst <- peekArray (numC*bytesPerC) $ plusPtr (castPtr buf :: Ptr Word8) 8
bs <-
Arr.newListArray (0 ,(numC*bytesPerC*8-1)) (toBools bitst)
return (Just BSPVisData {
numOfClusters = numC,
bytesPerCluster = bytesPerC,
bitSets = bs
})
-- - - - - - - - - - - - - - - - - - -
-- reads vertex information
readVertices :: Handle -> [BSPLump] -> IO VertexData
readVertices handle lumps = do
(offst,lngth) <- getLumpData (lumps !! kVertices)
offs <- getOffsets lngth offst 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 offst = do
hSeek handle AbsoluteSeek (fromIntegral offst)
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
rgbaVal <- getWord8s 4
free buf
return ([x,z,(-1)*y],texCoords,lightMapCoords,normals,rgbaVal)
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 = 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
(offst,lngth) <- (getLumpData (lumps !! kLightmaps))
offs <- getOffsets lngth offst 49152
mapM (readLightMap handle) offs
readLightMap :: Handle -> Int -> IO TextureObject
readLightMap handle offst = do
hSeek handle AbsoluteSeek (fromIntegral offst)
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 :: Int)) (fromIntegral (128 :: Int))
(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 offst = do
ptr <- return (advancePtr lightMap (3*offst))
[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) :: Int)
byteg2 <- return $ fromIntegral $ (truncate (g2 * tempb * 255.0) :: Int)
byteb2 <- return $ fromIntegral $ (truncate (b2 * tempb * 255.0) :: Int)
pokeArray (advancePtr lightMap (3*offst)) [byter2,byteg2,byteb2]
scaleRGB :: Float -> Float -> IO (Float,Float)
scaleRGB clr scl = do
if ((clr > 1.0) && ((1.0/clr) < scl))
then return (clr, 1.0/clr)
else
return (clr, scl)
fixLightmap ::
Int -> Array Int TextureObject -> Maybe TextureObject
fixLightmap ind arr
| ind < 0 = Nothing
| otherwise = Just (arr ! ind)
-- - - - - - - - - - - - - - - - - - -
-- reads the texture information
readTexInfos :: Handle -> [BSPLump] -> IO [BSPTexInfo]
readTexInfos handle lumps = do
(offst,lngth) <- (getLumpData (lumps !! kTextures))
offs <- getOffsets lngth offst 72
mapM (readTexInfo handle) offs
readTexInfo :: Handle -> Int -> IO (BSPTexInfo)
readTexInfo handle offst = do
hSeek handle AbsoluteSeek (fromIntegral offst)
buf <- mallocBytes 64 :: IO (Ptr CChar)
hGetBuf handle buf 64
str <- peekCAString buf
hSeek handle AbsoluteSeek ((fromIntegral offst) + 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
(offst,lngth) <- (getLumpData (lumps !! kIndices))
hSeek handle AbsoluteSeek (fromIntegral offst)
buf <- mallocBytes lngth
hGetBuf handle buf lngth
indces <- mapM
(peekElemOff (castPtr buf :: Ptr CInt))
[ 0 .. ((lngth `div` 4)-1)] :: IO [CInt]
free buf
return $ map fromIntegral indces
-- - - - - - - - - - - - - - - - - - -
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 lngth off sze = return $ map ((off+) . (sze*)) [0.. ((lngth `div` sze)-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))
getPtrs :: Ptr a -> Int -> Int -> [Ptr a]
getPtrs ptr lngth sze = map ((plusPtr ptr) . (sze *)) [0.. ((lngth `div` sze) - 1)]