module Graphics.LambdaCube.Loader.MeshXML where import Data.Maybe import Data.List import Data.Word import qualified Data.IntMap as IntMap import Foreign.Ptr import Foreign.C.Types import Foreign.Marshal.Array import Text.XML.Light import System.Log.Logger import Graphics.LambdaCube.Mesh import Graphics.LambdaCube.HardwareBuffer import Graphics.LambdaCube.HardwareVertexBuffer import Graphics.LambdaCube.HardwareIndexBuffer import Graphics.LambdaCube.RenderSystem import Graphics.LambdaCube.RenderOperation import Graphics.LambdaCube.VertexIndexData {- data MeshReader = MeshReader { mrInfo :: String , mrFileExtension :: String , mrReadFunction :: ByteString -> IO Mesh } meshReader = MeshReader { mrInfo = "Ogre XML mesh reader" , mrFileExtension = "xml" , mrReadFunction = parseMesh } -} -- Load Mesh XML readBool :: String -> Bool -> Element -> Bool readBool n v e = maybe v (=="true") $ findAttr (unqual n) e readInt :: String -> Int -> Element -> Int readInt n v e = maybe v read $ findAttr (unqual n) e readStr :: String -> String -> Element -> String readStr n v e = fromMaybe v $ findAttr (unqual n) e {- data VertexElement = VertexElement { veSource :: Int -- ^ The source vertex buffer, as bound to an index using VertexBufferBinding , veOffset :: Int -- ^ The offset in the buffer that this element starts at , veType :: VertexElementType -- ^ The type of element , veSemantic :: VertexElementSemantic -- ^ The meaning of the element , veIndex :: Int -- ^ Index of the item, only applicable for some elements like texture coords } -} readDecl :: (Element,Int) -> [VertexElement] readDecl (x,n) = [v { veIndex = i } | (v,i) <- zip declList $ reverse indexList] where hasPositions = readBool "positions" False x hasNormals = readBool "normals" False x hasDiffuse = readBool "colours_diffuse" False x hasSpecular = readBool "colours_specular" False x hasBinormals = readBool "binormals" False x hasTangents = readBool "tangents" False x dimTangents = readInt "tangent_dimensions" 3 x numTexCoords = readInt "texture_coords" 0 x dimTexCoords = [readInt ("texture_coord_dimensions_" ++ show (i-1)) 2 x | i <- [1..numTexCoords]] mColourElementType = VET_COLOUR_ABGR f a b = if a then [b] else [] l = [ f hasPositions (VET_FLOAT3, VES_POSITION) , f hasNormals (VET_FLOAT3, VES_NORMAL) , f hasTangents (if dimTangents == 4 then VET_FLOAT4 else VET_FLOAT3, VES_TANGENT) , f hasBinormals (VET_FLOAT3, VES_BINORMAL) , f hasDiffuse (mColourElementType, VES_DIFFUSE) , f hasSpecular (mColourElementType, VES_SPECULAR) ] ++ [[(multiplyTypeCount VET_FLOAT1 dims,VES_TEXTURE_COORDINATES)] | dims <- dimTexCoords] l' = concat l offs = scanl (\a (b,_) -> a + getTypeSize b) 0 l' declList = [VertexElement n o t s 0 | (o,(t,s)) <- zip offs l'] indexList = snd $ foldl fi (IntMap.empty,[]) declList fi (m,vl) e = case IntMap.lookup semIdx m of { Nothing -> (IntMap.insert semIdx 0 m,0:vl) ; Just i -> (IntMap.insert semIdx (i+1) m,(i+1):vl) } where semIdx = fromEnum $ veSemantic e --readGeometry :: RenderSystem rs => rs -> Element -> IO VertexData readGeometry rs x = do let vcount = read $ fromMaybe (error "fromJust 0") $ findAttr (unqual "vertexcount") x vbs = findElements (unqual "vertexbuffer") x elems = [readDecl v | v <- zip vbs [0..]] sizes = [foldl (\a b -> a + (getTypeSize $ veType b)) 0 e | e <- elems] -- create VertexDeclaration decl = VertexDeclaration $ concat elems -- create VertexBufferBinding usage = HBU_STATIC -- TODO debugM "readGeometry" $ "gemetry declaration: " ++ show elems bufs <- mapM (\s -> createVertexBuffer rs s vcount usage True) sizes let binding = VertexBufferBinding $ IntMap.fromList $ zip [0..] bufs fillBuffer (d,vx,b) = do -- 1. lock buffer ptr <- lock b 0 (getSizeInBytes b) HBL_NORMAL let fillVertex (i,vx) = do -- iterate over elements and read data from xml subelement let fillAttribute e = do let p = plusPtr ptr (i * (getVertexSize b) + veOffset e) setCFloatAttr :: String -> [String] -> IO () setCFloatAttr en ea = pokeArray p $ getCFloat ((findElements (unqual en) vx ) !! veIndex e) ea setColourAttr :: String -> IO () setColourAttr en = pokeArray p $ getColour ((findElements (unqual en) vx ) !! veIndex e) getCFloat :: Element -> [String] -> [CFloat] getCFloat xn ll = map ef ll where ef nm = read $ fromMaybe (error "fromJust 1") $ findAttr (unqual nm) xn getColour :: Element -> [Word8] getColour xn = if length values == 4 then values else 1:values where values = map read $ words $ fromMaybe (error "fromJust 2") $ findAttr (unqual "value") xn case veSemantic e of { VES_POSITION -> setCFloatAttr "position" ["x","y","z"] ; VES_BLEND_WEIGHTS -> error "invalid semantic" ; VES_BLEND_INDICES -> error "invalid semantic" ; VES_NORMAL -> setCFloatAttr "normal" ["x","y","z"] ; VES_DIFFUSE -> setColourAttr "colour_diffuse" ; VES_SPECULAR -> setColourAttr "colour_specular" ; VES_TEXTURE_COORDINATES -> setCFloatAttr "texcoord" $ take (getTypeCount $ veType e) ["u","v","w","x"] ; VES_BINORMAL -> setCFloatAttr "binormal" ["x","y","z"] ; VES_TANGENT -> setCFloatAttr "tangent" $ if veType e == VET_FLOAT4 then ["x","y","z","w"] else ["x","y","z"] } -- end fillAttribute mapM_ fillAttribute d -- end fillVertex -- 2. fill n-th vertex attributes according declaration mapM_ fillVertex $ zip [0..] $ findElements (unqual "vertex") vx -- 3. unlock buffer unlock b -- end fillBuffer -- fill buffers with data mapM_ fillBuffer $ zip3 elems vbs bufs -- create VertexData return $ VertexData decl binding 0 vcount --readSubMesh :: RenderSystem rs => rs -> Element -> IO SubMesh readSubMesh rs x = do let Just material = findAttr (unqual "material") x useShared = readBool "usesharedvertices" True x use32BitIndex = readBool "use32bitindexes" False x (hasFaces,oper) = readOpType $ readStr "operationtype" "triangle_list" x readOpType o = case o of { "triangle_list" -> (True, OT_TRIANGLE_LIST) ; "triangle_strip" -> (True, OT_TRIANGLE_STRIP) ; "triangle_fan" -> (True, OT_TRIANGLE_FAN) ; "line_strip" -> (False, OT_LINE_STRIP) ; "line_list" -> (False, OT_LINE_LIST) ; "point_list" -> (False, OT_POINT_LIST) } midata <- if not hasFaces then return Nothing else do let Just faces = findElement (unqual "faces") x faceCount = readInt "count" 0 faces faceList = findElements (unqual "face") faces indexCount = if oper == OT_TRIANGLE_LIST then 3 * faceCount else 2 + faceCount usage = HBU_STATIC -- TODO attrList = take (if oper == OT_TRIANGLE_LIST then 3 else 1) ["v1", "v2", "v3"] indexList gf = concat $ [gf (head faceList) ["v1", "v2", "v3"]] ++ [gf f attrList | f <- tail faceList] getWord16 :: Element -> [String] -> [Word16] getWord16 xn ll = map ef ll where ef nm = read $ fromMaybe (error "fromJust 3") $ findAttr (unqual nm) xn getWord32 :: Element -> [String] -> [Word32] getWord32 xn ll = map ef ll where ef nm = read $ fromMaybe (error "fromJust 4") $ findAttr (unqual nm) xn -- create IndexData ib <- createIndexBuffer rs (if use32BitIndex then IT_32BIT else IT_16BIT) indexCount usage True -- 1. lock buffer ptr <- lock ib 0 (getSizeInBytes ib) HBL_NORMAL -- 2. fill buffer case use32BitIndex of { True -> pokeArray (castPtr ptr) $ indexList getWord32 ; False -> pokeArray (castPtr ptr) $ indexList getWord16 } -- 3. unlock buffer unlock ib return $ Just IndexData { idIndexBuffer = ib , idIndexStart = 0 , idIndexCount = indexCount } -- read geometry if necessary mvdata <- if useShared then return Nothing else do vd <- readGeometry rs $ fromMaybe (error "fromJust 5") $ findElement (unqual "geometry") x return $ Just vd return $ SubMesh { smOperationType = oper , smVertexData = mvdata , smIndexData = midata , smExtremityPoints = undefined -- TODO , smMaterialName = material } {- -} --readMesh :: RenderSystem rs => rs -> Element -> IO Mesh readMesh rs x = do let Just sml = findElement (unqual "submeshes") x submeshes <- mapM (readSubMesh rs) $ findElements (unqual "submesh") sml sharedVDs <- mapM (readGeometry rs) $ findElements (unqual "sharedgeometry") x return $ Mesh { msSubMeshList = submeshes , msSharedVertexData = listToMaybe sharedVDs , msSubMeshNameMap = undefined -- TODO , msBoundRadius = undefined -- TODO , msSkeletonName = undefined -- TODO , msVertexBufferUsage = undefined -- TODO , msIndexBufferUsage = undefined -- TODO , msVertexBufferShadowBuffer = undefined -- TODO , msIndexBufferShadowBuffer = undefined -- TODO } {- -- load LOD data e a n = read $ fromMaybe (error "fromJust 0") $ findAttr (unqual n) a lods = [ (getLod m) | m <- findElements (unqual "levelofdetail") x ] -- getLod a = [ (e m "value" ,getLodLevel m) | m <- findElements (unqual "lodgenerated") a ] -- getLodLevel a = [ (e m "submeshindex", e m "numfaces", getLodFaces m) | m <- findElements (unqual "lodfacelist") a ] -- getLodFaces a = [ (getFace m) | m <- findElements (unqual "face") a ] -} --parseMesh :: RenderSystem rs => rs -> String -> IO Mesh parseMesh rs doc = do let Just x = parseXMLDoc doc readMesh rs $ fromMaybe (error "fromJust 6") $ findElement (unqual "mesh") x --loadMesh :: RenderSystem rs => rs -> String -> IO Mesh loadMesh rs fileName = do doc <- readFile fileName parseMesh rs doc