diff --git a/GPipe-Collada.cabal b/GPipe-Collada.cabal --- a/GPipe-Collada.cabal +++ b/GPipe-Collada.cabal @@ -1,40 +1,38 @@ -name: GPipe-Collada -version: 0.1.1 -cabal-version: >=1.2.3 -build-type: Simple -license: BSD3 -copyright: Tobias Bexelius -maintainer: Tobias Bexelius - -stability: Experimental -homepage: http://www.haskell.org/haskellwiki/GPipe -package-url: http://hackage.haskell.org/package/GPipe-Collada -bug-reports: mailto:tobias_bexelius@hotmail.com -synopsis: Load GPipe meshes from Collada files -description: This package provides data types for a Collada scene graph including geometries, cameras and lights that may be loaded from - Collada (dae) files. Geometries are represented by GPipe PrimitiveStreams. A utility module is included that include traverse helpers - and render functions. - -category: Graphics -author: Tobias Bexelius - -Library - build-depends: GPipe >= 1.2.1, - base >= 3 && < 5, - HaXml >= 1.20 && < 1.21, - containers >= 0.3 && < 0.4, - mtl -any, - Vec == 0.9.7, - Vec-Transform == 1.0.4, - array >= 0.3 && < 0.4 - exposed-modules: Data.Vec.AABB - Graphics.GPipe.Collada - Graphics.GPipe.Collada.Parse +name: GPipe-Collada +version: 0.1.2 +cabal-version: >= 1.8 +build-type: Simple +license: BSD3 +copyright: Tobias Bexelius +maintainer: Tobias Bexelius + +stability: Experimental +homepage: http://www.haskell.org/haskellwiki/GPipe +package-url: http://hackage.haskell.org/package/GPipe-Collada +bug-reports: mailto:tobias_bexelius@hotmail.com +synopsis: Load GPipe meshes from Collada files +description: This package provides data types for a Collada scene graph including geometries, cameras and lights that may be loaded from + Collada (dae) files. Geometries are represented by GPipe PrimitiveStreams. A utility module is included that include traverse helpers + and render functions. + +category: Graphics +author: Tobias Bexelius + +Library + build-depends: + GPipe >= 1.3.1, + base >= 4 && <5, + HaXml >= 1.20 && < 1.21, + containers >= 0.4 && < 0.5, + Vec == 0.9.8, + Vec-Transform == 1.0.5, + array >= 0.3, + mtl + hs-source-dirs: src + exposed-modules: + Data.Vec.AABB, + Graphics.GPipe.Collada, + Graphics.GPipe.Collada.Parse, Graphics.GPipe.Collada.Utils - extensions: GeneralizedNewtypeDeriving - StandaloneDeriving - FlexibleInstances - MultiParamTypeClasses - ScopedTypeVariables - DeriveDataTypeable - hs-source-dirs: src + + diff --git a/Setup.lhs b/Setup.lhs --- a/Setup.lhs +++ b/Setup.lhs @@ -1,6 +1,6 @@ -#!/usr/bin/runhaskell -> module Main where -> import Distribution.Simple -> main :: IO () -> main = defaultMain - +#!/usr/bin/runhaskell +> module Main where +> import Distribution.Simple +> main :: IO () +> main = defaultMain + diff --git a/src/Data/Vec/AABB.hs b/src/Data/Vec/AABB.hs --- a/src/Data/Vec/AABB.hs +++ b/src/Data/Vec/AABB.hs @@ -1,86 +1,86 @@ ------------------------------------------------------------------------------ --- --- Module : Data.Vec.AABB --- Copyright : Tobias Bexelius --- License : BSD3 --- --- Maintainer : Tobias Bexelius --- Stability : Experimental --- Portability : Portable --- +----------------------------------------------------------------------------- +-- +-- Module : Data.Vec.AABB +-- Copyright : Tobias Bexelius +-- License : BSD3 +-- +-- Maintainer : Tobias Bexelius +-- Stability : Experimental +-- Portability : Portable +-- -- | --- This module provides an axis aligned bounding box based on 'Data.Vec's. ------------------------------------------------------------------------------ -module Data.Vec.AABB -( - AABB(..), - aabbTransform, - testAABBprojection, - Intersection(..) -) - -where -import Data.Monoid -import qualified Data.Vec.Base as Vec -import Data.Vec.Base ((:.)(..), Mat44, Mat33, Vec3) -import Data.Vec.Nat -import Data.Vec.LinAlg -import Data.Vec.LinAlg.Transform3D - --- | An axis aligned bounding box. -data AABB = AABB { - aabbMin :: Vec3 Float, - aabbMax :: Vec3 Float - } - deriving (Show, Eq) - -instance Monoid AABB where - mempty = let inf = read "Infinity" :: Float in AABB (Vec.vec inf) (Vec.vec (-inf)) - mappend (AABB minA maxA) (AABB minB maxB) = AABB (Vec.zipWith min minA minB) (Vec.zipWith max maxA maxB) - -data Intersection = Inside | Intersecting | Outside deriving (Eq, Show, Ord, Enum, Bounded) - --- | Try if an 'AABB' is inside a projection frustum. The AABB must be defined in the same vector space as the matrix, e.g. use the model-view-projection matrix for model-local aabb's. -testAABBprojection :: Mat44 Float -> AABB -> Intersection -testAABBprojection m = - let planes = [-(row n3 m + row n0 m), - -(row n3 m - row n0 m), - -(row n3 m + row n1 m), - -(row n3 m - row n1 m), - -(row n3 m + row n2 m), - -(row n3 m - row n2 m)] - getMin min max = min - getMax min max = max - vMinF = Vec.map (\ni -> if ni >= 0 then getMin else getMax) - vMaxF = Vec.map (\ni -> if ni >= 0 then getMax else getMin) - checkPlane (AABB bmin bmax) Outside _ = Outside - checkPlane (AABB bmin bmax) state plane = - let n = Vec.take n3 plane - d = Vec.last plane - vMin = Vec.zipWith ($) (Vec.zipWith ($) (vMinF n) bmin) bmax - vMax = Vec.zipWith ($) (Vec.zipWith ($) (vMaxF n) bmin) bmax - in if (n `dot` vMin) + d > 0 - then Outside - else if (n `dot` vMax) + d >= 0 - then Intersecting - else Inside - in \aabb -> foldl (checkPlane aabb) Inside planes - --- | Transforms an 'AABB* using a 4x4 matrix. Note that this may grow the AABB and is not associative with matrix multiplication, i.e. --- --- > (m2 `multmm` m1) `aabbTransform` aabb --- --- is usually not the same as --- --- > m2 `aabbTransform` (m1 `aabbTransform` aabb) --- --- (The former is preferred as it minimizes the growing of the AABB). -aabbTransform :: Mat44 Float -> AABB -> AABB -aabbTransform m (AABB bmin bmax) = - let center = (bmax + bmin) / 2 - extent = bmax - center - mAbs33 = Vec.map (Vec.map abs . Vec.take n3) $ Vec.take n3 m - tcenter = project $ m `multmv` homPoint center - textent = mAbs33 `multmv` extent - in AABB (tcenter - textent) (tcenter + textent) - +-- This module provides an axis aligned bounding box based on 'Data.Vec's. +----------------------------------------------------------------------------- +module Data.Vec.AABB +( + AABB(..), + aabbTransform, + testAABBprojection, + Intersection(..) +) + +where +import Data.Monoid +import qualified Data.Vec.Base as Vec +import Data.Vec.Base ((:.)(..), Mat44, Mat33, Vec3) +import Data.Vec.Nat +import Data.Vec.LinAlg +import Data.Vec.LinAlg.Transform3D + +-- | An axis aligned bounding box. +data AABB = AABB { + aabbMin :: Vec3 Float, + aabbMax :: Vec3 Float + } + deriving (Show, Eq) + +instance Monoid AABB where + mempty = let inf = read "Infinity" :: Float in AABB (Vec.vec inf) (Vec.vec (-inf)) + mappend (AABB minA maxA) (AABB minB maxB) = AABB (Vec.zipWith min minA minB) (Vec.zipWith max maxA maxB) + +data Intersection = Inside | Intersecting | Outside deriving (Eq, Show, Ord, Enum, Bounded) + +-- | Try if an 'AABB' is inside a projection frustum. The AABB must be defined in the same vector space as the matrix, e.g. use the model-view-projection matrix for model-local aabb's. +testAABBprojection :: Mat44 Float -> AABB -> Intersection +testAABBprojection m = + let planes = [-(row n3 m + row n0 m), + -(row n3 m - row n0 m), + -(row n3 m + row n1 m), + -(row n3 m - row n1 m), + -(row n3 m + row n2 m), + -(row n3 m - row n2 m)] + getMin min max = min + getMax min max = max + vMinF = Vec.map (\ni -> if ni >= 0 then getMin else getMax) + vMaxF = Vec.map (\ni -> if ni >= 0 then getMax else getMin) + checkPlane (AABB bmin bmax) Outside _ = Outside + checkPlane (AABB bmin bmax) state plane = + let n = Vec.take n3 plane + d = Vec.last plane + vMin = Vec.zipWith ($) (Vec.zipWith ($) (vMinF n) bmin) bmax + vMax = Vec.zipWith ($) (Vec.zipWith ($) (vMaxF n) bmin) bmax + in if (n `dot` vMin) + d > 0 + then Outside + else if (n `dot` vMax) + d >= 0 + then Intersecting + else Inside + in \aabb -> foldl (checkPlane aabb) Inside planes + +-- | Transforms an 'AABB* using a 4x4 matrix. Note that this may grow the AABB and is not associative with matrix multiplication, i.e. +-- +-- > (m2 `multmm` m1) `aabbTransform` aabb +-- +-- is usually not the same as +-- +-- > m2 `aabbTransform` (m1 `aabbTransform` aabb) +-- +-- (The former is preferred as it minimizes the growing of the AABB). +aabbTransform :: Mat44 Float -> AABB -> AABB +aabbTransform m (AABB bmin bmax) = + let center = (bmax + bmin) / 2 + extent = bmax - center + mAbs33 = Vec.map (Vec.map abs . Vec.take n3) $ Vec.take n3 m + tcenter = project $ m `multmv` homPoint center + textent = mAbs33 `multmv` extent + in AABB (tcenter - textent) (tcenter + textent) + diff --git a/src/Graphics/GPipe/Collada.hs b/src/Graphics/GPipe/Collada.hs --- a/src/Graphics/GPipe/Collada.hs +++ b/src/Graphics/GPipe/Collada.hs @@ -1,216 +1,217 @@ ------------------------------------------------------------------------------ --- --- Module : Graphics.GPipe.Collada --- Copyright : Tobias Bexelius --- License : BSD3 --- --- Maintainer : Tobias Bexelius --- Stability : Experimental --- Portability : Portable --- +{-# LANGUAGE StandaloneDeriving, DeriveDataTypeable #-} +----------------------------------------------------------------------------- +-- +-- Module : Graphics.GPipe.Collada +-- Copyright : Tobias Bexelius +-- License : BSD3 +-- +-- Maintainer : Tobias Bexelius +-- Stability : Experimental +-- Portability : Portable +-- -- | --- This module contains the data types of the Collada scene graph. --- --- Orphan TypeableX instances are also provided for 'Vertex' and "Data.Vec" vectors (:.) . ------------------------------------------------------------------------------ -module Graphics.GPipe.Collada -( - Scene, - - Node(..), - nodeMat, - nodeAABB, - - Transform(..), - transformMat, - transformsMat, - - Camera(..), - cameraMat, - - ViewSize(..), - Z(..), - - Light(..), - Attenuation(..), - - Geometry(..), - Mesh(..), - ID, - SID, - Semantic, - AABB(..) -) -where - -import Data.Tree -import Data.Map (Map) -import Data.Maybe -import Data.Monoid -import Graphics.GPipe.Stream.Primitive -import Graphics.GPipe.Format -import qualified Data.Vec as Vec -import Data.Vec (Vec2, Vec3, Mat44, Mat33, (:.)(..), ) -import Data.Vec.LinAlg -import Data.Vec.AABB -import Data.Vec.LinAlg.Transform3D - -import Data.Typeable -import Data.Dynamic - -type Scene = Tree (SID, Node) - -data Node = Node { - nodeId :: Maybe ID, - nodeLayers :: [String], - nodeTransformations :: [(SID, Transform)], - nodeCameras :: [(SID, Camera)], - nodeLights :: [(SID, Light)], - nodeGeometries :: [(SID, Geometry)] - } - deriving (Show) - -data Transform = LookAt { - lookAtEye:: Vec3 Float, - lookAtInterest :: Vec3 Float, - lookAtUp :: Vec3 Float - } - | Matrix (Mat44 Float) - | Rotate (Vec3 Float) Float - | Scale (Vec3 Float) - | Skew { - skewAngle :: Float, - skewRotation :: Vec3 Float, - skewTranslation :: Vec3 Float - } - | Translate (Vec3 Float) - deriving (Show, Eq) - -data Camera = Perspective { - perspectiveID :: ID, - perspectiveFov :: ViewSize, - perspectiveZ :: Z - } - | Orthographic { - orthographicID :: ID, - orthographicViewSize :: ViewSize, - orthographicZ :: Z - } - deriving (Show, Eq) - -data ViewSize = ViewSizeX Float - | ViewSizeY Float - | ViewSizeXY (Vec2 Float) - deriving (Show, Eq) - -data Z = Z { - zNear :: Float, - zFar :: Float - } - deriving (Show, Eq) - -data Light = Ambient { - ambientID :: ID, - ambientColor :: Color RGBFormat Float - } - | Directional { - directionalID :: ID, - directionalColor :: Color RGBFormat Float - } - | Point { - pointID :: ID, - pointColor :: Color RGBFormat Float, - pointAttenuation :: Attenuation - } - | Spot { - spotID :: ID, - spotColor :: Color RGBFormat Float, - spotAttenuation :: Attenuation, - spotFallOffAngle :: Float, - spotFallOffExponent :: Float - } - deriving (Show, Eq) - -data Attenuation = Attenuation { - attenuationConstant :: Float, - attenuationLinear :: Float, - attenuationQuadratic :: Float - } - deriving (Show, Eq) - -data Geometry = Mesh { - meshID :: ID, - meshPrimitives :: [Mesh] - } - deriving (Show) - -data Mesh = TriangleMesh { - meshMaterial :: String, - meshDescription :: Map Semantic TypeRep, - meshPrimitiveStream :: PrimitiveStream Triangle (Map Semantic Dynamic), - meshAABB :: AABB - } - -instance Show Mesh where - show (TriangleMesh a b _ d) = "TriangleMesh {meshMaterial = " ++ show a ++ ", meshDescription = " ++ show b ++ ", meshPrimitiveStream = PrimitiveStream Triangle (Map String Dynamic), meshAABB = " ++ show d ++"}" - -type ID = String -type SID = Maybe String -type Semantic = String - -deriving instance Typeable1 Vertex -deriving instance Typeable2 (:.) - ---------------------------------------------------- - -toRadians :: Floating a => a -> a -toRadians d = d * pi / 180 - --- | Gets the projection matrix of a 'Camera' element. -cameraMat :: Float -> Camera -> Mat44 Float -cameraMat asp (Perspective _ (ViewSizeX x) (Z near far)) = perspective near far (toRadians x / asp) asp -cameraMat asp (Perspective _ (ViewSizeY y) (Z near far)) = perspective near far (toRadians y) asp -cameraMat _ (Perspective _ (ViewSizeXY (x:.y:.())) (Z near far)) = perspective near far (toRadians y) (x/y) -cameraMat asp (Orthographic _ (ViewSizeX x) (Z near far)) = orthogonal near far (x :. (x/asp) :. ()) -cameraMat asp (Orthographic _ (ViewSizeY y) (Z near far)) = orthogonal near far ((y*asp) :. y :. ()) -cameraMat _ (Orthographic _ (ViewSizeXY s) (Z near far)) = orthogonal near far s - --- | Gets the transformation matrix of a 'Transform' element. -transformMat :: Transform -> Mat44 Float -transformMat (LookAt e i u) = rotationLookAt u e i -transformMat (Matrix m) = m -transformMat (Rotate v a) = rotationVec v (toRadians a) -transformMat (Scale v) = scaling v -transformMat (Skew a r t) = skew (toRadians a) r t -transformMat (Translate v) = translation v - --- | Gets the total transformation matrix of a list of 'Transform' element. -transformsMat :: [Transform] -> Mat44 Float -transformsMat = foldl multmm identity . map transformMat - ----------------------------------- --- adopted from http://www.koders.com/cpp/fidA08C276050F880D11C2E49280DD9997478DC5BA1.aspx -skew :: Float -> Vec3 Float -> Vec3 Float -> Mat44 Float -skew angle a b = Vec.map homVec m `Vec.snoc` (homPoint 0) - where - n2 = normalize b - a1 = Vec.map (* (a `dot` n2)) n2 - a2 = a-a1 - n1 = normalize a2 - an1 = a `dot` n1 - an2 = a `dot` n2 - rx = an1 * cos angle - an2 * sin angle - ry = an1 * sin angle + an2 * cos angle - alpha = if abs an1 < 0.000001 then 0 else ry/rx-an2/an1 - m = outerProd n1 (Vec.map (* alpha) n2) + identity - - outerProd :: Vec3 Float -> Vec3 Float -> Mat33 Float - outerProd a b = Vec.map (* b) $ Vec.map (Vec.vec) a - --- | The complete transform matrix of all 'Transform' elements in a node. -nodeMat :: Node -> Mat44 Float -nodeMat = transformsMat . map snd . nodeTransformations - --- | The smallest 'AABB' that contains all 'Geometry' elements in a node. Note: This is not transformed using the nodes 'Transform' elements. -nodeAABB :: Node -> AABB -nodeAABB = mconcat . map (mconcat . map meshAABB . meshPrimitives . snd) . nodeGeometries +-- This module contains the data types of the Collada scene graph. +-- +-- Orphan TypeableX instances are also provided for 'Vertex' and "Data.Vec" vectors (:.) . +----------------------------------------------------------------------------- +module Graphics.GPipe.Collada +( + Scene, + + Node(..), + nodeMat, + nodeAABB, + + Transform(..), + transformMat, + transformsMat, + + Camera(..), + cameraMat, + + ViewSize(..), + Z(..), + + Light(..), + Attenuation(..), + + Geometry(..), + Mesh(..), + ID, + SID, + Semantic, + AABB(..) +) +where + +import Data.Tree +import Data.Map (Map) +import Data.Maybe +import Data.Monoid +import Graphics.GPipe.Stream.Primitive +import Graphics.GPipe.Format +import qualified Data.Vec as Vec +import Data.Vec (Vec2, Vec3, Mat44, Mat33, (:.)(..), ) +import Data.Vec.LinAlg +import Data.Vec.AABB +import Data.Vec.LinAlg.Transform3D + +import Data.Typeable +import Data.Dynamic + +type Scene = Tree (SID, Node) + +data Node = Node { + nodeId :: Maybe ID, + nodeLayers :: [String], + nodeTransformations :: [(SID, Transform)], + nodeCameras :: [(SID, Camera)], + nodeLights :: [(SID, Light)], + nodeGeometries :: [(SID, Geometry)] + } + deriving (Show) + +data Transform = LookAt { + lookAtEye:: Vec3 Float, + lookAtInterest :: Vec3 Float, + lookAtUp :: Vec3 Float + } + | Matrix (Mat44 Float) + | Rotate (Vec3 Float) Float + | Scale (Vec3 Float) + | Skew { + skewAngle :: Float, + skewRotation :: Vec3 Float, + skewTranslation :: Vec3 Float + } + | Translate (Vec3 Float) + deriving (Show, Eq) + +data Camera = Perspective { + perspectiveID :: ID, + perspectiveFov :: ViewSize, + perspectiveZ :: Z + } + | Orthographic { + orthographicID :: ID, + orthographicViewSize :: ViewSize, + orthographicZ :: Z + } + deriving (Show, Eq) + +data ViewSize = ViewSizeX Float + | ViewSizeY Float + | ViewSizeXY (Vec2 Float) + deriving (Show, Eq) + +data Z = Z { + zNear :: Float, + zFar :: Float + } + deriving (Show, Eq) + +data Light = Ambient { + ambientID :: ID, + ambientColor :: Color RGBFormat Float + } + | Directional { + directionalID :: ID, + directionalColor :: Color RGBFormat Float + } + | Point { + pointID :: ID, + pointColor :: Color RGBFormat Float, + pointAttenuation :: Attenuation + } + | Spot { + spotID :: ID, + spotColor :: Color RGBFormat Float, + spotAttenuation :: Attenuation, + spotFallOffAngle :: Float, + spotFallOffExponent :: Float + } + deriving (Show, Eq) + +data Attenuation = Attenuation { + attenuationConstant :: Float, + attenuationLinear :: Float, + attenuationQuadratic :: Float + } + deriving (Show, Eq) + +data Geometry = Mesh { + meshID :: ID, + meshPrimitives :: [Mesh] + } + deriving (Show) + +data Mesh = TriangleMesh { + meshMaterial :: String, + meshDescription :: Map Semantic TypeRep, + meshPrimitiveStream :: PrimitiveStream Triangle (Map Semantic Dynamic), + meshAABB :: AABB + } + +instance Show Mesh where + show (TriangleMesh a b _ d) = "TriangleMesh {meshMaterial = " ++ show a ++ ", meshDescription = " ++ show b ++ ", meshPrimitiveStream = PrimitiveStream Triangle (Map String Dynamic), meshAABB = " ++ show d ++"}" + +type ID = String +type SID = Maybe String +type Semantic = String + +deriving instance Typeable1 Vertex +deriving instance Typeable2 (:.) + +--------------------------------------------------- + +toRadians :: Floating a => a -> a +toRadians d = d * pi / 180 + +-- | Gets the projection matrix of a 'Camera' element. +cameraMat :: Float -> Camera -> Mat44 Float +cameraMat asp (Perspective _ (ViewSizeX x) (Z near far)) = perspective near far (toRadians x / asp) asp +cameraMat asp (Perspective _ (ViewSizeY y) (Z near far)) = perspective near far (toRadians y) asp +cameraMat _ (Perspective _ (ViewSizeXY (x:.y:.())) (Z near far)) = perspective near far (toRadians y) (x/y) +cameraMat asp (Orthographic _ (ViewSizeX x) (Z near far)) = orthogonal near far (x :. (x/asp) :. ()) +cameraMat asp (Orthographic _ (ViewSizeY y) (Z near far)) = orthogonal near far ((y*asp) :. y :. ()) +cameraMat _ (Orthographic _ (ViewSizeXY s) (Z near far)) = orthogonal near far s + +-- | Gets the transformation matrix of a 'Transform' element. +transformMat :: Transform -> Mat44 Float +transformMat (LookAt e i u) = rotationLookAt u e i +transformMat (Matrix m) = m +transformMat (Rotate v a) = rotationVec v (toRadians a) +transformMat (Scale v) = scaling v +transformMat (Skew a r t) = skew (toRadians a) r t +transformMat (Translate v) = translation v + +-- | Gets the total transformation matrix of a list of 'Transform' element. +transformsMat :: [Transform] -> Mat44 Float +transformsMat = foldl multmm identity . map transformMat + +---------------------------------- +-- adopted from http://www.koders.com/cpp/fidA08C276050F880D11C2E49280DD9997478DC5BA1.aspx +skew :: Float -> Vec3 Float -> Vec3 Float -> Mat44 Float +skew angle a b = Vec.map homVec m `Vec.snoc` homPoint 0 + where + n2 = normalize b + a1 = Vec.map (* (a `dot` n2)) n2 + a2 = a-a1 + n1 = normalize a2 + an1 = a `dot` n1 + an2 = a `dot` n2 + rx = an1 * cos angle - an2 * sin angle + ry = an1 * sin angle + an2 * cos angle + alpha = if abs an1 < 0.000001 then 0 else ry/rx-an2/an1 + m = outerProd n1 (Vec.map (* alpha) n2) + identity + + outerProd :: Vec3 Float -> Vec3 Float -> Mat33 Float + outerProd a b = Vec.map (* b) $ Vec.map Vec.vec a + +-- | The complete transform matrix of all 'Transform' elements in a node. +nodeMat :: Node -> Mat44 Float +nodeMat = transformsMat . map snd . nodeTransformations + +-- | The smallest 'AABB' that contains all 'Geometry' elements in a node. Note: This is not transformed using the nodes 'Transform' elements. +nodeAABB :: Node -> AABB +nodeAABB = mconcat . map (mconcat . map meshAABB . meshPrimitives . snd) . nodeGeometries diff --git a/src/Graphics/GPipe/Collada/Parse.hs b/src/Graphics/GPipe/Collada/Parse.hs --- a/src/Graphics/GPipe/Collada/Parse.hs +++ b/src/Graphics/GPipe/Collada/Parse.hs @@ -1,605 +1,583 @@ ------------------------------------------------------------------------------ --- --- Module : Graphics.GPipe.Collada.Parse --- Copyright : Tobias Bexelius --- License : BSD3 --- --- Maintainer : Tobias Bexelius --- Stability : Experimental --- Portability : Portable --- --- | --- This module provides the means to load Collada scene graphs from Collada (dae) files. --- --- The parser supports Collada 1.5 core elements, including cameras lights and triangle meshes. Other elements such as animations, controllers or materials are ignored. Other meshes than --- triangles, trifans and tristrips are ignored. Only float_arrays are supported and others will be ignored. The parser only support local links and will ignore external ones. --- The parser supports parsing infinitely recursive structures into constant memory. ------------------------------------------------------------------------------ -module Graphics.GPipe.Collada.Parse -( - readCollada, - readColladaFile -) -where - -import Graphics.GPipe.Collada -import Graphics.GPipe.Stream.Primitive -import Graphics.GPipe.Format - -import Text.XML.HaXml hiding (Document, when, Reference, (!)) -import qualified Text.XML.HaXml as XML -import Text.XML.HaXml.Parse -import Text.XML.HaXml.Posn - -import Data.Tree (Tree(), Forest) -import qualified Data.Tree as Tree -import Data.Maybe -import Data.Monoid -import Data.Array -import Data.Function -import Data.List hiding (union) -import Data.Map (Map) -import qualified Data.Map as Map -import Control.Arrow (first, second) - -import Data.Vec.Base ((:.)(..)) -import qualified Data.Vec.Base as Vec -import Data.Vec.Nat -import Control.Monad.Error -import Control.Monad.Writer.Strict - -import Data.Typeable -import Data.Dynamic - --- | Parse a string containing a collada document and return 'Either' an error message or the parsed Collada 'Scene'. -readCollada :: String -> Either String Scene -readCollada = readCollada' "Collada file" - --- | Open a Collada file and parse its contents and return a Collada 'Scene'. Errors are thrown as 'userError's. -readColladaFile :: FilePath -> IO Scene -readColladaFile f = do s <- readFile f - case readCollada' f s of - Left e -> throwError $ strMsg e - Right v -> return v - ----------------------------------------------------------------- --- Parser type: - -newtype RefMap = RefMap (Map ID (RefMap -> Reference)) - -data Reference = RefNode Scene - | RefArray (Maybe ([Float], Int)) - | RefSource (Maybe ([[Float]], Int)) - | RefVertices (Map String ([[Float]], Int)) - | RefVisualScene Scene - | RefCamera Camera - | RefLight Light - | RefGeometry Geometry - -type Parser = WriterT [(ID, RefMap -> Reference)] (WriterT [RefMap -> Either String ()] (Either String)) - -runParser :: Parser (Maybe ID) -> Either String Reference -runParser m = do ((mid, refs), checks) <- runWriterT $ runWriterT m - case mid of - Nothing -> return $ RefVisualScene $ Tree.Node (nosid $ Node Nothing [] [] [] [] []) [] - Just id -> do - let refmap = RefMap $ Map.fromList refs - mapM_ ($ refmap) checks - return $ fromJust $ getRef id refmap - - -addRefF id ref = tell [(id, ref)] -getRef id a@(RefMap m) = fmap ($a) $ Map.lookup id m - -assert f = lift $ tell [f] - ----------------------------------------------------------------- --- Utility: - -sid s a = (Just s, a) -nosid a = (Nothing, a) - -localUrl ('#':id) = Just id -localUrl _ = Nothing - -missingLinkErr el id c = el ++ " element with id '" ++ id ++ "' not found when processing " ++ errorPos c - -errorPos c@(CElem (Elem n _ _) p) = n ++ " element in " ++ show p ++ "." - -withError err m = m `mplus` throwError err - -makeSID "" = nosid -makeSID s = sid s - -changeTreeSID "" (Tree.Node (_, node) xs) = Tree.Node (nosid node) xs -changeTreeSID s (Tree.Node (_, node) xs) = Tree.Node (sid s node) xs - -getAttribute s = fst . head . attributed s keep -getReqAttribute :: String -> Content Posn -> Parser String -getReqAttribute s c = case getAttribute s c of - "" -> throwError $ "Missing attribute " ++ s ++ " in " ++ errorPos c - a -> return a - -getStringContent = intercalate " " . mapMaybe fst . textlabelled children - -getReqSingleElement el c = case c -=> keep /> tag el of - [] -> throwError $ "Missing " ++ el ++ " element in " ++ errorPos c - [e] -> return e - _ -> throwError $ "Multiple " ++ el ++ " elements in " ++ errorPos c - -getFromReqAttribute attr c = do a <- getReqAttribute attr c - fromString ("Malformed " ++ attr ++ " attribute in " ++ errorPos c) a - -getFromAttributeDef attr def c = do let a = getAttribute attr c - if null a - then return def - else fromString ("Malformed " ++ attr ++ " attribute in " ++ errorPos c) a - -getFromSingleElementDef el def c = case c -=> keep /> tag el of - [] -> return def - [e] -> getFromContents e - _ -> throwError $ "Multiple " ++ el ++ " elements in " ++ errorPos c - -getFromListContents c = fromList ("Malformed contents of " ++ errorPos c) $ getStringContent c -getFromContents c = fromString ("Malformed contents of " ++ errorPos c) $ getStringContent c - -getFromListLengthContents n c = do xs <- getFromListContents c - if (length xs == n) - then return xs - else if (length xs < n) - then throwError $ "Too few elements in " ++ errorPos c - else throwError $ "Too many elements in " ++ errorPos c - -fromList err = mapM (fromString err) . words -fromString err = parse . reads - where parse [(a,"")] = return a - parse _ = throwError err - -infixl 2 ==>, -=> -xs ==> f = concatMap f xs -x -=> f = f x - ----------------------------------------------------------------- ----------------------------------------------------------------- ----------------------------------------------------------------- --- Parser actions: - -readCollada' f s = do p <- xmlParse' f s - xs <- withError "Expecting COLLADA top-element" $ do XML.Document _ _ (Elem "COLLADA" _ xs) _ <- return p - return xs - RefVisualScene vs <- runParser $ parseDoc xs - return vs - - - -parseDoc xs = do let sources = xs ==> deep (tagWith (flip elem ["animation","mesh","morph","skin","spline","convex_mesh","brep","nurbs","nurbs_surface"])) /> tag "source" - mapM_ parseArray $ sources ==> tagged (keep /> tagWith ("_array" `isSuffixOf`) `with` attr "id") - mapM_ parseSource $ sources - mapM_ parseCamera $ xs ==> tag "library_cameras" /> tag "camera" `with` attr "id" - mapM_ parseGeometry $ xs ==> tag "library_geometries" /> tag "geometry" - mapM_ parseLight $ xs ==> tag "library_lights" /> tag "light" `with` attr "id" - mapM_ parseNode $ xs ==> tag "library_nodes" /> tag "node" - mapM_ parseVisualScene $ xs ==> tag "library_visual_scenes" /> tag "visual_scene" - (url,c) <- case xs ==> attributed "url" (tag "scene" /> tag "instance_visual_scene") of - [] -> throwError $ "Missing scene element with instance_visual_scene element found in COLLADA top element." - [x] -> return x - _ -> throwError $ "Multiple instance_visual_scene elements in scene element found in COLLADA top element." - case localUrl url of - Nothing -> return Nothing - Just lurl -> do assert $ \refmap -> withError (missingLinkErr "visual_scene" lurl c) $ do Just (RefVisualScene _) <- return $ getRef lurl refmap - return () - return $ Just lurl - ---------------------------------------------------------------- - - -parseArray (s, arr) = do arrRef <- case s of - "float_array" -> do - count <- getFromReqAttribute "count" arr - xs <- getFromListContents arr - let len = length xs - when (len /= count) - $ throwError $ "Length of array not the same as the value of count attribute in " ++ errorPos arr - return $ Just (xs :: [Float], len) - _ -> return Nothing - addRefF (getAttribute "id" arr) (const (RefArray arrRef)) - ---------------------------------------------------------------- - -parseSource s = do id <- getReqAttribute "id" s - sRef <- case s -=> keep /> tag "technique_common" of - [] -> return (const (RefSource Nothing)) - tc:_ -> do acc <- getReqSingleElement "accessor" tc - parseAccessor acc - addRefF id sRef - -parseAccessor acc = do arrUrl <- getReqAttribute "source" acc - case localUrl arrUrl of - Nothing -> return (const (RefSource Nothing)) - Just id -> do - count <- getFromReqAttribute "count" acc - offset <- getFromAttributeDef "offset" 0 acc - stride <- getFromAttributeDef "stride" 1 acc - useParamList <- mapM parseParam $ acc -=> keep /> elm - let paramLength = length useParamList - when (paramLength > stride) - $ throwError $ "stride attribute too low in " ++ errorPos acc - let requiredLength = offset + stride * (count-1) + paramLength - assert $ \refmap -> do m <- withError (missingLinkErr "*_array" id acc) $ do Just (RefArray m) <- return $ getRef id refmap - return m - case m of Just (_,len) | requiredLength > len -> throwError $ "Source size too small for " ++ errorPos acc - _ -> return () - return $ \refmap -> RefSource $ case getRef id refmap of - Just (RefArray (Just (source, len))) -> Just (assembleSource (drop offset source) count stride useParamList, count) - _ -> Nothing - where parseParam c | null $ tag "param" c = throwError $ "Unexpected " ++ errorPos c - | otherwise = return $ not $ null $ getAttribute "name" c - assembleSource source 0 _ _ = [] - assembleSource source count stride useParamList = case splitAt stride source of (vertex, rest) -> map snd (filter fst (zip useParamList vertex)) : assembleSource rest (count - 1) stride useParamList - - ---------------------------------------------------------------- - -parseNode c | not $ null $ tag "node" c = do - let id = getAttribute "id" c - mid = if id == "" then Nothing else Just id - sid = makeSID $ getAttribute "sid" c - layer = words $ getAttribute "layer" c - transformations <- fmap catMaybes $ mapM parseTransformations $ children c - cameraFs <- fmap catMaybes $ mapM parseCameraInstances $ c -=> keep /> tag "instance_camera" - lightFs <- fmap catMaybes $ mapM parseLightInstances $ c -=> keep /> tag "instance_light" - geometryFs <- fmap catMaybes $ mapM parseGeometryInstances $ c -=> keep /> tag "instance_geometry" - subNodeFs <- fmap catMaybes $ mapM parseNode $ c -=> keep /> (tag "node" `union` tag "instance_node") - let treeF refmap = Tree.Node (sid (Node mid layer transformations (map ($refmap) cameraFs) (map ($refmap) lightFs) (map ($refmap) geometryFs))) (map ($refmap) subNodeFs) - case id of (_:_) -> addRefF id $ RefNode . treeF - return $ Just treeF - | otherwise {- "instance_node" -} = do - url <- getReqAttribute "url" c - let sid = changeTreeSID $ getAttribute "sid" c - case localUrl url of - Just id -> do assert $ \refmap -> withError (missingLinkErr "instance_node" id c) $ do Just (RefNode _) <- return $ getRef id refmap - return () - return $ Just $ \refmap -> case getRef id refmap of Just (RefNode tree) -> sid $ tree - _ -> return Nothing - -parseCameraInstances c = do url <- getReqAttribute "url" c - let sid = makeSID $ getAttribute "sid" c - case localUrl url of - Nothing -> return $ Nothing - Just id -> do assert $ \ refmap -> withError (missingLinkErr "instance_camera" id c) $ do Just (RefCamera _) <- return $ getRef id refmap - return () - return $ Just $ \ refmap -> case getRef id refmap of Just (RefCamera content) -> sid content -parseLightInstances c = do url <- getReqAttribute "url" c - let sid = makeSID $ getAttribute "sid" c - case localUrl url of - Nothing -> return $ Nothing - Just id -> do assert $ \ refmap -> withError (missingLinkErr "instance_light" id c) $ do Just (RefLight _) <- return $ getRef id refmap - return () - return $ Just $ \ refmap -> case getRef id refmap of Just (RefLight content) -> sid content -parseGeometryInstances c = do url <- getReqAttribute "url" c - let sid = makeSID $ getAttribute "sid" c - case localUrl url of - Nothing -> return $ Nothing - Just id -> do assert $ \ refmap -> withError (missingLinkErr "instance_camera" id c) $ do Just (RefGeometry _) <- return $ getRef id refmap - return () - return $ Just $ \ refmap -> case getRef id refmap of Just (RefGeometry content) -> sid content ---------------------------------------------------------------- -parseTransformations c = do let sid = makeSID $ getAttribute "sid" c - case fst $ head $ tagged keep c of - "lookat" -> do xs <- getFromListLengthContents 9 c - let (eye,rest) = splitAt 3 xs - (int, up) = splitAt 3 rest - return $ Just $ sid $ LookAt (Vec.fromList eye) (Vec.fromList int) (Vec.fromList up) - "matrix" -> do mat <- getFromListLengthContents 16 c - return $ Just $ sid $ Matrix $ Vec.matFromList mat - "rotate" -> do xs <- getFromListLengthContents 4 c - let (rot,[a]) = splitAt 3 xs - return $ Just $ sid $ Rotate (Vec.fromList rot) a - "scale" -> do v <- getFromListLengthContents 3 c - return $ Just $ sid $ Scale $ Vec.fromList v - "skew" -> do xs <- getFromListLengthContents 7 c - let ([a],rest) = splitAt 1 xs - (rot, trans) = splitAt 3 rest - return $ Just $ sid $ Skew a (Vec.fromList rot) (Vec.fromList trans) - "translate" -> do v <- getFromListLengthContents 3 c - return $ Just $ sid $ Translate $ Vec.fromList v - _ -> return $ Nothing ---------------------------------------------------------------- - -parseVisualScene c = do let id = getAttribute "id" c - subNodeFs <- fmap catMaybes $ mapM parseNode $ c -=> keep /> tag "node" - unless (null id) $ - addRefF id $ \refmap -> RefVisualScene $ Tree.Node (nosid $ Node (Just id) [] [] [] [] []) $ map ($ refmap) subNodeFs - ---------------------------------------------------------------- - -parseCamera c = do let id = getAttribute "id" c - optics <- getReqSingleElement "optics" c - tech <- getReqSingleElement "technique_common" optics - camera <- case (tech -=> keep /> tag "perspective", tech -=> keep /> tag "ortographic") of - ([persp], []) -> do fov <- parseViewSize (persp -=> keep /> tag "xfov") (persp -=> keep /> tag "yfov") (persp -=> keep /> tag "aspect_ratio") - ("Missing valid combination of xfov, yfov and aspect_ratio elements in " ++ errorPos persp) - z <- parseZ persp - return $ Perspective id fov z - ([], [orth]) -> do mag <- parseViewSize (orth -=> keep /> tag "xmag") (orth -=> keep /> tag "ymag") (orth -=> keep /> tag "aspect_ratio") - ("Missing valid combination of xmag, ymag and aspect_ratio elements in " ++ errorPos orth) - z <- parseZ orth - return $ Orthographic id mag z - _ -> throwError $ "Excpected one perspective or ortographic element at " ++ errorPos tech - addRefF id $ const $ RefCamera camera - where - parseViewSize [x] [] [] _ = do x' <- getFromContents x - return $ ViewSizeX x' - parseViewSize [] [y] [] _ = do y' <- getFromContents y - return $ ViewSizeY y' - parseViewSize [x] [y] [] _ = do x' <- getFromContents x - y' <- getFromContents y - return $ ViewSizeXY (x':.y':.()) - parseViewSize [x] [] [a] _ = do x' <- getFromContents x - a' <- getFromContents a - let y' = x' / a' - return $ ViewSizeXY (x':.y':.()) - parseViewSize [] [y] [a] _ = do y' <- getFromContents y - a' <- getFromContents a - let x' = y' * a' - return $ ViewSizeXY (x':.y':.()) - parseViewSize _ _ _ err = throwError err - parseZ c = do near <- getReqSingleElement "znear" c - znear <- getFromContents near - far <- getReqSingleElement "zfar" c - zfar <- getFromContents far - return $ Z znear zfar - -parseGeometry c = do verticess <- mapM (getReqSingleElement "vertices") $ c -=> keep /> cat [tag "convex_mesh", tag "brep"] - mapM_ parseVertices verticess - mesh <- getReqSingleElement "mesh" c - parseMesh (getAttribute "id" c) mesh - -parseLight c = do let id = getAttribute "id" c - tech <- getReqSingleElement "technique_common" c - light <- case (tech -=> keep /> tag "ambient", tech -=> keep /> tag "directional", tech -=> keep /> tag "point", tech -=> keep /> tag "spot") of - ([a],[],[],[]) -> do color <- parseSubColor a - return $ Ambient id color - ([],[a],[],[]) -> do color <- parseSubColor a - return $ Directional id color - ([],[],[a],[]) -> do color <- parseSubColor a - att <- parseSubAttenuation a - return $ Point id color att - ([],[],[],[a]) -> do color <- parseSubColor a - att <- parseSubAttenuation a - ang <- getFromSingleElementDef "falloff_angle" 180 c - exp <- getFromSingleElementDef "falloff_exponent" 0 c - return $ Spot id color att ang exp - _ -> throwError $ "Excpected one ambient, directional, point or spot element at " ++ errorPos tech - addRefF id $ const $ RefLight light - where - parseSubColor c = do color <- getReqSingleElement "color" c - colors <- getFromListLengthContents 3 color - return $ RGB $ Vec.fromList colors - parseSubAttenuation c = do con <- getFromSingleElementDef "constant_attenuation" 1 c - lin <- getFromSingleElementDef "linear_attenuation" 0 c - qua <- getFromSingleElementDef "quadratic_attenuation" 0 c - return $ Attenuation con lin qua - ---------------------------------------------------------------- --- Mesh parsing: - -parseMesh id c = do v <- getReqSingleElement "vertices" c - vertices <- parseVertices v - if null id - then return () - else do - dynPrimListFs <- fmap concat $ mapM (parsePrimitives vertices) $ children c - addRefF id $ \refmap -> let dynPrimLists = map (second ($refmap)) dynPrimListFs - in RefGeometry $ Mesh id (makeDynPrimStream dynPrimLists) - - -parseVertices verts = do insF <- fmap (map snd) $ mapM (parseInput False) $ verts -=> keep /> tag "input" - let vertsF = \refmap -> Map.unions $ map ($refmap) insF - case getAttribute "id" verts of - "" -> return () - id -> addRefF id $ RefVertices . vertsF - return vertsF - -parseInput :: Bool -> Content Posn -> Parser (Int, RefMap -> Map String ([[Float]], Int)) -parseInput shared i = do source <- getReqAttribute "source" i - offset <- if shared - then getFromReqAttribute "offset" i - else return undefined - case localUrl source of - Nothing -> return (offset, const Map.empty) - Just id -> do - semantic <- getReqAttribute "semantic" i - let set = if shared then getAttribute "set" i else "" - assert $ \refmap -> case (shared, semantic, getRef id refmap) of - (true, "VERTEX", Just (RefVertices _)) -> return () - (true, "VERTEX", _) -> throwError $ missingLinkErr "vertices" id i - (_, _, Just (RefSource _)) -> return () - _ -> throwError $ missingLinkErr "source" id i - let f = \ refmap -> case (shared, semantic, getRef id refmap) of - (true, "VERTEX", Just (RefVertices m)) -> Map.mapKeysMonotonic (++set) m - (_, _, Just (RefSource Nothing)) -> Map.empty - (_, _, Just (RefSource (Just source))) -> Map.singleton (semantic++set) source - return (offset, f) - - -parsePrimitives vertices p = case mprimtype of - Nothing -> return mempty - Just primtype -> do - inputFs' <- fmap (Map.fromListWith combine) $ mapM (parseInput True) $ p -=> keep /> tag "input" - let inputFs = if Map.null inputFs' - then Map.singleton 0 vertices - else inputFs' - count <- getFromReqAttribute "count" p - if count == 0 - then return [] - else do ps' <- case (primtype, ps) of - (TriangleList, _:_:_) -> throwError $ "Multiple p elements in " ++ errorPos p - (TriangleList, [_]) -> return ps - (TriangleList, []) -> throwError $ "Missing p element in " ++ errorPos p - (_, _:_) | length ps < count -> throwError $ "Too few p elements in " ++ errorPos p - _ -> return $ take count ps - mapM (parseP primtype inputFs count) ps' - where mprimtype = case fst $ head $ tagged keep p of - "triangles" -> Just TriangleList - "trifans" -> Just TriangleFan - "tristrips" -> Just TriangleStrip - _ -> Nothing - ps = p -=> keep /> tag "p" - combine :: (RefMap -> Map String ([[Float]], Int)) -> (RefMap -> Map String ([[Float]], Int)) -> (RefMap -> Map String ([[Float]], Int)) - combine f g = \refmap -> f refmap `Map.union` g refmap - -parseP :: Triangle -> Map Int (RefMap -> Map String ([[Float]], Int)) -> Int -> Content Posn -> Parser ((String, Triangle, Maybe [Int]), RefMap -> Map String [[Float]]) -parseP primtype inputs count p = do let pStride = 1 + fst (Map.findMax inputs) - material = getAttribute "material" p - pLists <- fmap (splitIn pStride) $ do - pl <- getFromListContents p - if (primtype == TriangleList) - then do when (length pl < count * 3 * pStride) $ throwError $ "Too few indices in " ++ errorPos p - return $ take (count * 3 * pStride) pl - else return pl - case map (first (pLists !!)) $ Map.toList inputs of - [(indices,mF)] -> return ((material, primtype, Just indices), Map.map fst . mF) - xs -> return ((material, primtype, Nothing), combine $ map pickIndices xs) - where pickIndices (indices, mF) = \refmap -> Map.map pickIndices' (mF refmap) - where pickIndices' (xs, len) = let arr = listArray (0,len) xs in map (arr!) indices - combine mFs = \refmap -> Map.unions $ map ($refmap) mFs - splitIn n = reverse . transpose . splitIn' [] n -- [[offset 0], [offset 1], [offset 2]] - where - splitIn' acc 0 xs = acc:splitIn' [] n xs - splitIn' acc _ [] = [] - splitIn' acc m (x:xs) = splitIn' (x:acc) (m-1) xs - - ------------------------------------------------------ --- Dynamic Vertex - -makeDynPrimStream = map makePrimGroup . groupBy ((==) `on` fst) . map splitParts -splitParts ((material, primtype, mindices), m) = let mlist = Map.toAscList m - ins = transpose $ map snd mlist - names = map fst mlist - sizes = map length $ head ins - input = map concat ins - aabb = makeAABB $ Map.lookup "POSITION" m - in ((material, names, sizes), (aabb,((primtype, mindices), input))) - - -makeAABB Nothing = AABB (Vec.vec (-inf)) (Vec.vec (inf)) -makeAABB (Just xs) = mconcat $ map pointToAABB xs - where pointToAABB (x:y:z:_) = let p = x:.y:.z:.() in AABB p p - pointToAABB (x:y:_) = AABB (x:.y:.(-inf):.()) (x:.y:.(inf):.()) - pointToAABB (x:_) = AABB (x:.(-inf):.(-inf):.()) (x:.(inf):.(inf):.()) - pointToAABB (_) = AABB (Vec.vec (-inf)) (Vec.vec inf) - -inf :: Float -inf = read "Infinity" - -makeTypeRep n = dynTypeRep $ makeDyn n undefined -takeBy (size:sizes) xs = case splitAt size xs of (a,b) -> a : takeBy sizes b -takeBy [] _ = [] - -makePrimGroup xs@(((material, names, sizes), _):_) = TriangleMesh material desc pstream aabb - where - xs' = map (second snd) xs - aabb = mconcat $ map (fst . snd) xs - desc = Map.fromAscList $ zip names $ map makeTypeRep sizes - pstream = fmap (Map.fromAscList . zip names . map (uncurry makeDyn) . zip sizes . takeBy sizes) $ makeListStream (sum sizes) xs' - -type S2 a = Succ (Succ a) -type S4 a = S2 (S2 a) -type S10 a = S2 (S4 (S4 a)) - -s10 :: forall a. Nat a => a -> S10 a -s10 _ = undefined :: S10 a - -toStreamUsingLength n = fmap (Vec.toList . withLength n) . mconcat . map (toPrimStream . second (second (map Vec.fromList))) -withLength n v = v `asTypeOf` Vec.mkVec n (undefined :: Vertex Float) -toPrimStream (_, ((primtype, Just indices), input)) = toIndexedGPUStream primtype input indices -toPrimStream (_, ((primtype, _), input)) = toGPUStream primtype input - -makeDyn n = case n of - 0 -> const $ toDyn () - 1 -> toDyn . head - 2 -> toDyn . withLength n2 . Vec.fromList - 3 -> toDyn . withLength n3 . Vec.fromList - 4 -> toDyn . withLength n4 . Vec.fromList - 5 -> toDyn . withLength n5 . Vec.fromList - 6 -> toDyn . withLength n6 . Vec.fromList - 7 -> toDyn . withLength n7 . Vec.fromList - 8 -> toDyn . withLength n8 . Vec.fromList - 9 -> toDyn . withLength n9 . Vec.fromList - 10 -> toDyn . withLength n10 . Vec.fromList - 11 -> toDyn . withLength n11 . Vec.fromList - 12 -> toDyn . withLength n12 . Vec.fromList - 13 -> toDyn . withLength n13 . Vec.fromList - 14 -> toDyn . withLength n14 . Vec.fromList - 15 -> toDyn . withLength n15 . Vec.fromList - 16 -> toDyn . withLength n16 . Vec.fromList - -makeListStream n = case n of - 0 -> fmap (\() -> []) . mconcat . map (toPrimStream . second (second (map (const ())))) - 1 -> fmap (:[]) . mconcat . map (toPrimStream . second (second (map head))) - 2 -> toStreamUsingLength n2 - 3 -> toStreamUsingLength n3 - 4 -> toStreamUsingLength n4 - 5 -> toStreamUsingLength n5 - 6 -> toStreamUsingLength n6 - 7 -> toStreamUsingLength n7 - 8 -> toStreamUsingLength n8 - 9 -> toStreamUsingLength n9 - 10 -> toStreamUsingLength n10 - 11 -> toStreamUsingLength n11 - 12 -> toStreamUsingLength n12 - 13 -> toStreamUsingLength n13 - 14 -> toStreamUsingLength n14 - 15 -> toStreamUsingLength n15 - 16 -> toStreamUsingLength n16 - 17 -> toStreamUsingLength n17 - 18 -> toStreamUsingLength n18 - 19 -> toStreamUsingLength n19 - 20 -> toStreamUsingLength $ s10 n10 - 21 -> toStreamUsingLength $ s10 n11 - 22 -> toStreamUsingLength $ s10 n12 - 23 -> toStreamUsingLength $ s10 n13 - 24 -> toStreamUsingLength $ s10 n14 - 25 -> toStreamUsingLength $ s10 n15 - 26 -> toStreamUsingLength $ s10 n16 - 27 -> toStreamUsingLength $ s10 n17 - 28 -> toStreamUsingLength $ s10 n18 - 29 -> toStreamUsingLength $ s10 n19 - 30 -> toStreamUsingLength $ s10 $ s10 n10 - 31 -> toStreamUsingLength $ s10 $ s10 n11 - 32 -> toStreamUsingLength $ s10 $ s10 n12 - 33 -> toStreamUsingLength $ s10 $ s10 n13 - 34 -> toStreamUsingLength $ s10 $ s10 n14 - 35 -> toStreamUsingLength $ s10 $ s10 n15 - 36 -> toStreamUsingLength $ s10 $ s10 n16 - 37 -> toStreamUsingLength $ s10 $ s10 n17 - 38 -> toStreamUsingLength $ s10 $ s10 n18 - 39 -> toStreamUsingLength $ s10 $ s10 n19 - 40 -> toStreamUsingLength $ s10 $ s10 $ s10 n10 - 41 -> toStreamUsingLength $ s10 $ s10 $ s10 n11 - 42 -> toStreamUsingLength $ s10 $ s10 $ s10 n12 - 43 -> toStreamUsingLength $ s10 $ s10 $ s10 n13 - 44 -> toStreamUsingLength $ s10 $ s10 $ s10 n14 - 45 -> toStreamUsingLength $ s10 $ s10 $ s10 n15 - 46 -> toStreamUsingLength $ s10 $ s10 $ s10 n16 - 47 -> toStreamUsingLength $ s10 $ s10 $ s10 n17 - 48 -> toStreamUsingLength $ s10 $ s10 $ s10 n18 - 49 -> toStreamUsingLength $ s10 $ s10 $ s10 n19 - 50 -> toStreamUsingLength $ s10 $ s10 $ s10 $ s10 n10 - 51 -> toStreamUsingLength $ s10 $ s10 $ s10 $ s10 n11 - 52 -> toStreamUsingLength $ s10 $ s10 $ s10 $ s10 n12 - 53 -> toStreamUsingLength $ s10 $ s10 $ s10 $ s10 n13 - 54 -> toStreamUsingLength $ s10 $ s10 $ s10 $ s10 n14 - 55 -> toStreamUsingLength $ s10 $ s10 $ s10 $ s10 n15 - 56 -> toStreamUsingLength $ s10 $ s10 $ s10 $ s10 n16 - 57 -> toStreamUsingLength $ s10 $ s10 $ s10 $ s10 n17 - 58 -> toStreamUsingLength $ s10 $ s10 $ s10 $ s10 n18 - 59 -> toStreamUsingLength $ s10 $ s10 $ s10 $ s10 n19 - 60 -> toStreamUsingLength $ s10 $ s10 $ s10 $ s10 $ s10 n10 - 61 -> toStreamUsingLength $ s10 $ s10 $ s10 $ s10 $ s10 n11 - 62 -> toStreamUsingLength $ s10 $ s10 $ s10 $ s10 $ s10 n12 - 63 -> toStreamUsingLength $ s10 $ s10 $ s10 $ s10 $ s10 n13 - 64 -> toStreamUsingLength $ s10 $ s10 $ s10 $ s10 $ s10 n14 - +{-# LANGUAGE RankNTypes #-} +{-# OPTIONS_GHC -fcontext-stack=35 #-} +----------------------------------------------------------------------------- +-- +-- Module : Graphics.GPipe.Collada.Parse +-- Copyright : Tobias Bexelius +-- License : BSD3 +-- +-- Maintainer : Tobias Bexelius +-- Stability : Experimental +-- Portability : Portable +-- +-- | +-- This module provides the means to load Collada scene graphs from Collada (dae) files. +-- +-- The parser supports Collada 1.5 core elements, including cameras lights and triangle meshes. Other elements such as animations, controllers or materials are ignored. Other meshes than +-- triangles, trifans and tristrips are ignored. Only float_arrays are supported and others will be ignored. The parser only support local links and will ignore external ones. +-- The parser supports parsing infinitely recursive structures into constant memory. +----------------------------------------------------------------------------- +module Graphics.GPipe.Collada.Parse +( + readCollada, + readColladaFile +) +where + +import Graphics.GPipe.Collada +import Graphics.GPipe.Stream.Primitive +import Graphics.GPipe.Format + +import Text.XML.HaXml hiding (Document, when, Reference, (!)) +import qualified Text.XML.HaXml as XML +import Text.XML.HaXml.Parse +import Text.XML.HaXml.Posn + +import Data.Tree (Tree(), Forest) +import qualified Data.Tree as Tree +import Data.Maybe +import Data.Monoid +import Data.Array +import Data.Function +import Data.List hiding (union) +import Data.Map (Map) +import qualified Data.Map as Map +import Control.Arrow (first, second) + +import Data.Vec.Base ((:.)(..)) +import qualified Data.Vec.Base as Vec +import Data.Vec.Nat +import Control.Monad.Error +import Control.Monad.Writer.Strict + +import Data.Typeable +import Data.Dynamic +import qualified Control.Monad as Control.Monad (unless) + +-- | Parse a string containing a collada document and return 'Either' an error message or the parsed Collada 'Scene'. +readCollada :: String -> Either String Scene +readCollada = readCollada' "Collada file" + +-- | Open a Collada file and parse its contents and return a Collada 'Scene'. Errors are thrown as 'userError's. +readColladaFile :: FilePath -> IO Scene +readColladaFile f = do s <- readFile f + case readCollada' f s of + Left e -> throwError $ strMsg e + Right v -> return v + +---------------------------------------------------------------- +-- Parser type: + +newtype RefMap = RefMap (Map ID (RefMap -> Reference)) + +data Reference = RefNode Scene + | RefArray (Maybe ([Float], Int)) + | RefSource (Maybe ([[Float]], Int)) + | RefVertices (Map String ([[Float]], Int)) + | RefVisualScene Scene + | RefCamera Camera + | RefLight Light + | RefGeometry Geometry + +type Parser = WriterT [(ID, RefMap -> Reference)] (WriterT [RefMap -> Either String ()] (Either String)) + +runParser :: Parser (Maybe ID) -> Either String Reference +runParser m = do ((mid, refs), checks) <- runWriterT $ runWriterT m + case mid of + Nothing -> return $ RefVisualScene $ Tree.Node (nosid $ Node Nothing [] [] [] [] []) [] + Just id -> do + let refmap = RefMap $ Map.fromList refs + mapM_ ($ refmap) checks + return $ fromJust $ getRef id refmap + + +addRefF id ref = tell [(id, ref)] +getRef id a@(RefMap m) = fmap ($a) $ Map.lookup id m + +assert f = lift $ tell [f] + +---------------------------------------------------------------- +-- Utility: + +sid s a = (Just s, a) +nosid a = (Nothing, a) + +localUrl ('#':id) = Just id +localUrl _ = Nothing + +missingLinkErr el id c = el ++ " element with id '" ++ id ++ "' not found when processing " ++ errorPos c + +errorPos c@(CElem (Elem n _ _) p) = n ++ " element in " ++ show p ++ "." + +withError err m = m `mplus` throwError err + +makeSID "" = nosid +makeSID s = sid s + +changeTreeSID "" (Tree.Node (_, node) xs) = Tree.Node (nosid node) xs +changeTreeSID s (Tree.Node (_, node) xs) = Tree.Node (sid s node) xs + +getAttribute s = fst . head . attributed s keep +getReqAttribute :: String -> Content Posn -> Parser String +getReqAttribute s c = case getAttribute s c of + "" -> throwError $ "Missing attribute " ++ s ++ " in " ++ errorPos c + a -> return a + +getStringContent = unwords . mapMaybe fst . textlabelled children + +getReqSingleElement el c = case c -=> keep /> tag el of + [] -> throwError $ "Missing " ++ el ++ " element in " ++ errorPos c + [e] -> return e + _ -> throwError $ "Multiple " ++ el ++ " elements in " ++ errorPos c + +getFromReqAttribute attr c = do a <- getReqAttribute attr c + fromString ("Malformed " ++ attr ++ " attribute in " ++ errorPos c) a + +getFromAttributeDef attr def c = do let a = getAttribute attr c + if null a + then return def + else fromString ("Malformed " ++ attr ++ " attribute in " ++ errorPos c) a + +getFromSingleElementDef el def c = case c -=> keep /> tag el of + [] -> return def + [e] -> getFromContents e + _ -> throwError $ "Multiple " ++ el ++ " elements in " ++ errorPos c + +getFromListContents c = fromList ("Malformed contents of " ++ errorPos c) $ getStringContent c +getFromContents c = fromString ("Malformed contents of " ++ errorPos c) $ getStringContent c + +getFromListLengthContents n c = do xs <- getFromListContents c + if length xs == n then return xs else + if (length xs < n) then + throwError $ "Too few elements in " ++ errorPos c else + throwError $ "Too many elements in " ++ errorPos c + +fromList err = mapM (fromString err) . words +fromString err = parse . reads + where parse [(a,"")] = return a + parse _ = throwError err + +infixl 2 ==>, -=> +xs ==> f = concatMap f xs +x -=> f = f x + +---------------------------------------------------------------- +---------------------------------------------------------------- +---------------------------------------------------------------- +-- Parser actions: + +readCollada' f s = do p <- xmlParse' f s + xs <- withError "Expecting COLLADA top-element" $ do XML.Document _ _ (Elem "COLLADA" _ xs) _ <- return p + return xs + RefVisualScene vs <- runParser $ parseDoc xs + return vs + + + +parseDoc xs = do let sources = xs ==> deep (tagWith (`elem` ["animation", "mesh", "morph", "skin", "spline", "convex_mesh", "brep", "nurbs", "nurbs_surface"])) /> tag "source" + mapM_ parseArray $ sources ==> tagged (keep /> tagWith ("_array" `isSuffixOf`) `with` attr "id") + mapM_ parseSource sources + mapM_ parseCamera $ xs ==> tag "library_cameras" /> tag "camera" `with` attr "id" + mapM_ parseGeometry $ xs ==> tag "library_geometries" /> tag "geometry" + mapM_ parseLight $ xs ==> tag "library_lights" /> tag "light" `with` attr "id" + mapM_ parseNode $ xs ==> tag "library_nodes" /> tag "node" + mapM_ parseVisualScene $ xs ==> tag "library_visual_scenes" /> tag "visual_scene" + (url,c) <- case xs ==> attributed "url" (tag "scene" /> tag "instance_visual_scene") of + [] -> throwError "Missing scene element with instance_visual_scene element found in COLLADA top element." + [x] -> return x + _ -> throwError "Multiple instance_visual_scene elements in scene element found in COLLADA top element." + case localUrl url of + Nothing -> return Nothing + Just lurl -> do assert $ \refmap -> withError (missingLinkErr "visual_scene" lurl c) $ do Just (RefVisualScene _) <- return $ getRef lurl refmap + return () + return $ Just lurl + +--------------------------------------------------------------- + + +parseArray (s, arr) = do arrRef <- case s of + "float_array" -> do + count <- getFromReqAttribute "count" arr + xs <- getFromListContents arr + let len = length xs + when (len /= count) + $ throwError $ "Length of array not the same as the value of count attribute in " ++ errorPos arr + return $ Just (xs :: [Float], len) + _ -> return Nothing + addRefF (getAttribute "id" arr) (const (RefArray arrRef)) + +--------------------------------------------------------------- + +parseSource s = do id <- getReqAttribute "id" s + sRef <- case s -=> keep /> tag "technique_common" of + [] -> return (const (RefSource Nothing)) + tc:_ -> do acc <- getReqSingleElement "accessor" tc + parseAccessor acc + addRefF id sRef + +parseAccessor acc = do arrUrl <- getReqAttribute "source" acc + case localUrl arrUrl of + Nothing -> return (const (RefSource Nothing)) + Just id -> do + count <- getFromReqAttribute "count" acc + offset <- getFromAttributeDef "offset" 0 acc + stride <- getFromAttributeDef "stride" 1 acc + useParamList <- mapM parseParam $ acc -=> keep /> elm + let paramLength = length useParamList + when (paramLength > stride) + $ throwError $ "stride attribute too low in " ++ errorPos acc + let requiredLength = offset + stride * (count-1) + paramLength + assert $ \refmap -> do m <- withError (missingLinkErr "*_array" id acc) $ do Just (RefArray m) <- return $ getRef id refmap + return m + case m of Just (_,len) | requiredLength > len -> throwError $ "Source size too small for " ++ errorPos acc + _ -> return () + return $ \refmap -> RefSource $ case getRef id refmap of + Just (RefArray (Just (source, len))) -> Just (assembleSource (drop offset source) count stride useParamList, count) + _ -> Nothing + where parseParam c | null $ tag "param" c = throwError $ "Unexpected " ++ errorPos c + | otherwise = return $ not $ null $ getAttribute "name" c + assembleSource source 0 _ _ = [] + assembleSource source count stride useParamList = case splitAt stride source of (vertex, rest) -> map snd (filter fst (zip useParamList vertex)) : assembleSource rest (count - 1) stride useParamList + + +--------------------------------------------------------------- + +parseNode c | not $ null $ tag "node" c = do + let id = getAttribute "id" c + mid = if id == "" then Nothing else Just id + sid = makeSID $ getAttribute "sid" c + layer = words $ getAttribute "layer" c + transformations <- fmap catMaybes $ mapM parseTransformations $ children c + cameraFs <- fmap catMaybes $ mapM parseCameraInstances $ c -=> keep /> tag "instance_camera" + lightFs <- fmap catMaybes $ mapM parseLightInstances $ c -=> keep /> tag "instance_light" + geometryFs <- fmap catMaybes $ mapM parseGeometryInstances $ c -=> keep /> tag "instance_geometry" + subNodeFs <- fmap catMaybes $ mapM parseNode $ c -=> keep /> (tag "node" `union` tag "instance_node") + let treeF refmap = Tree.Node (sid (Node mid layer transformations (map ($refmap) cameraFs) (map ($refmap) lightFs) (map ($refmap) geometryFs))) (map ($refmap) subNodeFs) + case id of (_:_) -> addRefF id $ RefNode . treeF + return $ Just treeF + | otherwise {- "instance_node" -} = do + url <- getReqAttribute "url" c + let sid = changeTreeSID $ getAttribute "sid" c + case localUrl url of + Just id -> do assert $ \refmap -> withError (missingLinkErr "instance_node" id c) $ do Just (RefNode _) <- return $ getRef id refmap + return () + return $ Just $ \refmap -> case getRef id refmap of Just (RefNode tree) -> sid tree + _ -> return Nothing + +parseCameraInstances c = do url <- getReqAttribute "url" c + let sid = makeSID $ getAttribute "sid" c + case localUrl url of + Nothing -> return Nothing + Just id -> do assert $ \ refmap -> withError (missingLinkErr "instance_camera" id c) $ do Just (RefCamera _) <- return $ getRef id refmap + return () + return $ Just $ \ refmap -> case getRef id refmap of Just (RefCamera content) -> sid content +parseLightInstances c = do url <- getReqAttribute "url" c + let sid = makeSID $ getAttribute "sid" c + case localUrl url of + Nothing -> return Nothing + Just id -> do assert $ \ refmap -> withError (missingLinkErr "instance_light" id c) $ do Just (RefLight _) <- return $ getRef id refmap + return () + return $ Just $ \ refmap -> case getRef id refmap of Just (RefLight content) -> sid content +parseGeometryInstances c = do url <- getReqAttribute "url" c + let sid = makeSID $ getAttribute "sid" c + case localUrl url of + Nothing -> return Nothing + Just id -> do assert $ \ refmap -> withError (missingLinkErr "instance_camera" id c) $ do Just (RefGeometry _) <- return $ getRef id refmap + return () + return $ Just $ \ refmap -> case getRef id refmap of Just (RefGeometry content) -> sid content +--------------------------------------------------------------- +parseTransformations c = do let sid = makeSID $ getAttribute "sid" c + case fst $ head $ tagged keep c of + "lookat" -> do xs <- getFromListLengthContents 9 c + let (eye,rest) = splitAt 3 xs + (int, up) = splitAt 3 rest + return $ Just $ sid $ LookAt (Vec.fromList eye) (Vec.fromList int) (Vec.fromList up) + "matrix" -> do mat <- getFromListLengthContents 16 c + return $ Just $ sid $ Matrix $ Vec.matFromList mat + "rotate" -> do xs <- getFromListLengthContents 4 c + let (rot,[a]) = splitAt 3 xs + return $ Just $ sid $ Rotate (Vec.fromList rot) a + "scale" -> do v <- getFromListLengthContents 3 c + return $ Just $ sid $ Scale $ Vec.fromList v + "skew" -> do xs <- getFromListLengthContents 7 c + let ([a],rest) = splitAt 1 xs + (rot, trans) = splitAt 3 rest + return $ Just $ sid $ Skew a (Vec.fromList rot) (Vec.fromList trans) + "translate" -> do v <- getFromListLengthContents 3 c + return $ Just $ sid $ Translate $ Vec.fromList v + _ -> return Nothing +--------------------------------------------------------------- + +parseVisualScene c = do let id = getAttribute "id" c + subNodeFs <- fmap catMaybes $ mapM parseNode $ c -=> keep /> tag "node" + unless (null id) $ + addRefF id $ \refmap -> RefVisualScene $ Tree.Node (nosid $ Node (Just id) [] [] [] [] []) $ map ($ refmap) subNodeFs + +--------------------------------------------------------------- + +parseCamera c = do let id = getAttribute "id" c + optics <- getReqSingleElement "optics" c + tech <- getReqSingleElement "technique_common" optics + camera <- case (tech -=> keep /> tag "perspective", tech -=> keep /> tag "ortographic") of + ([persp], []) -> do fov <- parseViewSize (persp -=> keep /> tag "xfov") (persp -=> keep /> tag "yfov") (persp -=> keep /> tag "aspect_ratio") + ("Missing valid combination of xfov, yfov and aspect_ratio elements in " ++ errorPos persp) + z <- parseZ persp + return $ Perspective id fov z + ([], [orth]) -> do mag <- parseViewSize (orth -=> keep /> tag "xmag") (orth -=> keep /> tag "ymag") (orth -=> keep /> tag "aspect_ratio") + ("Missing valid combination of xmag, ymag and aspect_ratio elements in " ++ errorPos orth) + z <- parseZ orth + return $ Orthographic id mag z + _ -> throwError $ "Excpected one perspective or ortographic element at " ++ errorPos tech + addRefF id $ const $ RefCamera camera + where + parseViewSize [x] [] [] _ = do x' <- getFromContents x + return $ ViewSizeX x' + parseViewSize [] [y] [] _ = do y' <- getFromContents y + return $ ViewSizeY y' + parseViewSize [x] [y] [] _ = do x' <- getFromContents x + y' <- getFromContents y + return $ ViewSizeXY (x':.y':.()) + parseViewSize [x] [] [a] _ = do x' <- getFromContents x + a' <- getFromContents a + let y' = x' / a' + return $ ViewSizeXY (x':.y':.()) + parseViewSize [] [y] [a] _ = do y' <- getFromContents y + a' <- getFromContents a + let x' = y' * a' + return $ ViewSizeXY (x':.y':.()) + parseViewSize _ _ _ err = throwError err + parseZ c = do near <- getReqSingleElement "znear" c + znear <- getFromContents near + far <- getReqSingleElement "zfar" c + zfar <- getFromContents far + return $ Z znear zfar + +parseGeometry c = do verticess <- mapM (getReqSingleElement "vertices") $ c -=> keep /> cat [tag "convex_mesh", tag "brep"] + mapM_ parseVertices verticess + mesh <- getReqSingleElement "mesh" c + parseMesh (getAttribute "id" c) mesh + +parseLight c = do let id = getAttribute "id" c + tech <- getReqSingleElement "technique_common" c + light <- case (tech -=> keep /> tag "ambient", tech -=> keep /> tag "directional", tech -=> keep /> tag "point", tech -=> keep /> tag "spot") of + ([a],[],[],[]) -> do color <- parseSubColor a + return $ Ambient id color + ([],[a],[],[]) -> do color <- parseSubColor a + return $ Directional id color + ([],[],[a],[]) -> do color <- parseSubColor a + att <- parseSubAttenuation a + return $ Point id color att + ([],[],[],[a]) -> do color <- parseSubColor a + att <- parseSubAttenuation a + ang <- getFromSingleElementDef "falloff_angle" 180 c + exp <- getFromSingleElementDef "falloff_exponent" 0 c + return $ Spot id color att ang exp + _ -> throwError $ "Excpected one ambient, directional, point or spot element at " ++ errorPos tech + addRefF id $ const $ RefLight light + where + parseSubColor c = do color <- getReqSingleElement "color" c + colors <- getFromListLengthContents 3 color + return $ RGB $ Vec.fromList colors + parseSubAttenuation c = do con <- getFromSingleElementDef "constant_attenuation" 1 c + lin <- getFromSingleElementDef "linear_attenuation" 0 c + qua <- getFromSingleElementDef "quadratic_attenuation" 0 c + return $ Attenuation con lin qua + +--------------------------------------------------------------- +-- Mesh parsing: + +parseMesh id c = do v <- getReqSingleElement "vertices" c + vertices <- parseVertices v + Control.Monad.unless (null id) $ + do dynPrimListFs <- fmap concat $ + mapM (parsePrimitives vertices) $ children c + addRefF id $ + \ refmap -> + let dynPrimLists = map (second ($refmap)) dynPrimListFs in + RefGeometry $ Mesh id (makeDynPrimStream dynPrimLists) + + +parseVertices verts = do insF <- fmap (map snd) $ mapM (parseInput False) $ verts -=> keep /> tag "input" + let vertsF refmap = Map.unions $ map ($refmap) insF + case getAttribute "id" verts of + "" -> return () + id -> addRefF id $ RefVertices . vertsF + return vertsF + +parseInput :: Bool -> Content Posn -> Parser (Int, RefMap -> Map String ([[Float]], Int)) +parseInput shared i = do source <- getReqAttribute "source" i + offset <- if shared + then getFromReqAttribute "offset" i + else return undefined + case localUrl source of + Nothing -> return (offset, const Map.empty) + Just id -> do + semantic <- getReqAttribute "semantic" i + let set = if shared then getAttribute "set" i else "" + assert $ \refmap -> case (shared, semantic, getRef id refmap) of + (true, "VERTEX", Just (RefVertices _)) -> return () + (true, "VERTEX", _) -> throwError $ missingLinkErr "vertices" id i + (_, _, Just (RefSource _)) -> return () + _ -> throwError $ missingLinkErr "source" id i + let f refmap + = case (shared, semantic, getRef id refmap) of + (true, "VERTEX", Just (RefVertices m)) -> Map.mapKeysMonotonic + (++ set) + m + (_, _, Just (RefSource Nothing)) -> Map.empty + (_, _, Just (RefSource (Just source))) -> Map.singleton + (semantic ++ set) + source + return (offset, f) + + +parsePrimitives vertices p = case mprimtype of + Nothing -> return mempty + Just primtype -> do + inputFs' <- fmap (Map.fromListWith combine) $ mapM (parseInput True) $ p -=> keep /> tag "input" + let inputFs = if Map.null inputFs' + then Map.singleton 0 vertices + else inputFs' + count <- getFromReqAttribute "count" p + if count == 0 + then return [] + else do ps' <- case (primtype, ps) of + (TriangleList, _:_:_) -> throwError $ "Multiple p elements in " ++ errorPos p + (TriangleList, [_]) -> return ps + (TriangleList, []) -> throwError $ "Missing p element in " ++ errorPos p + (_, _:_) | length ps < count -> throwError $ "Too few p elements in " ++ errorPos p + _ -> return $ take count ps + mapM (parseP primtype inputFs count) ps' + where mprimtype = case fst $ head $ tagged keep p of + "triangles" -> Just TriangleList + "trifans" -> Just TriangleFan + "tristrips" -> Just TriangleStrip + _ -> Nothing + ps = p -=> keep /> tag "p" + combine :: (RefMap -> Map String ([[Float]], Int)) -> (RefMap -> Map String ([[Float]], Int)) -> RefMap -> Map String ([[Float]], Int) + combine f g refmap = f refmap `Map.union` g refmap + +parseP :: Triangle -> Map Int (RefMap -> Map String ([[Float]], Int)) -> Int -> Content Posn -> Parser ((String, Triangle, Maybe [Int]), RefMap -> Map String [[Float]]) +parseP primtype inputs count p = do let pStride = 1 + fst (Map.findMax inputs) + material = getAttribute "material" p + pLists <- fmap (splitIn pStride) $ do + pl <- getFromListContents p + if primtype == TriangleList then + do when (length pl < count * 3 * pStride) $ + throwError $ "Too few indices in " ++ errorPos p + return $ take (count * 3 * pStride) pl + else return pl + case map (first (pLists !!)) $ Map.toList inputs of + [(indices,mF)] -> return ((material, primtype, Just indices), Map.map fst . mF) + xs -> return ((material, primtype, Nothing), combine $ map pickIndices xs) + where pickIndices (indices, mF) = Map.map pickIndices' . mF + where pickIndices' (xs, len) = let arr = listArray (0,len) xs in map (arr!) indices + combine mFs refmap = Map.unions $ map ($refmap) mFs + splitIn n = reverse . transpose . splitIn' [] n -- [[offset 0], [offset 1], [offset 2]] + where + splitIn' acc 0 xs = acc:splitIn' [] n xs + splitIn' acc _ [] = [] + splitIn' acc m (x:xs) = splitIn' (x:acc) (m-1) xs + + +----------------------------------------------------- +-- Dynamic Vertex + +makeDynPrimStream = map makePrimGroup . groupBy ((==) `on` fst) . map splitParts +splitParts ((material, primtype, mindices), m) = let mlist = Map.toAscList m + ins = transpose $ map snd mlist + names = map fst mlist + sizes = map length $ head ins + input = map concat ins + aabb = makeAABB $ Map.lookup "POSITION" m + in ((material, names, sizes), (aabb,((primtype, mindices), input))) + + +makeAABB Nothing = AABB (Vec.vec (-inf)) (Vec.vec inf) +makeAABB (Just xs) = mconcat $ map pointToAABB xs + where pointToAABB (x:y:z:_) = let p = x:.y:.z:.() in AABB p p + pointToAABB (x:y:_) = AABB (x:.y:.(-inf):.()) (x:.y:.inf:.()) + pointToAABB (x:_) = AABB (x:.(-inf):.(-inf):.()) (x:.inf:.inf:.()) + pointToAABB (_) = AABB (Vec.vec (-inf)) (Vec.vec inf) + +inf :: Float +inf = read "Infinity" + +makeTypeRep n = dynTypeRep $ makeDyn n undefined +takeBy (size:sizes) xs = case splitAt size xs of (a,b) -> a : takeBy sizes b +takeBy [] _ = [] + +makePrimGroup xs@(((material, names, sizes), _):_) = TriangleMesh material desc pstream aabb + where + xs' = map (second snd) xs + aabb = mconcat $ map (fst . snd) xs + desc = Map.fromAscList $ zip names $ map makeTypeRep sizes + pstream = fmap (Map.fromAscList . zip names . zipWith makeDyn sizes . takeBy sizes) $ makeListStream (sum sizes) xs' + +type S2 a = Succ (Succ a) +type S4 a = S2 (S2 a) +type S10 a = S2 (S4 (S4 a)) + +s10 :: forall a. Nat a => a -> S10 a +s10 _ = undefined :: S10 a + +toStreamUsingLength n = fmap (Vec.toList . withLength n) . mconcat . map (toPrimStream . second (second (map Vec.fromList))) +withLength n v = v `asTypeOf` Vec.mkVec n (undefined :: Vertex Float) +toPrimStream (_, ((primtype, Just indices), input)) = toIndexedGPUStream primtype input indices +toPrimStream (_, ((primtype, _), input)) = toGPUStream primtype input + +makeDyn n = case n of + 0 -> const $ toDyn () + 1 -> toDyn . head + 2 -> toDyn . withLength n2 . Vec.fromList + 3 -> toDyn . withLength n3 . Vec.fromList + 4 -> toDyn . withLength n4 . Vec.fromList + 5 -> toDyn . withLength n5 . Vec.fromList + 6 -> toDyn . withLength n6 . Vec.fromList + 7 -> toDyn . withLength n7 . Vec.fromList + 8 -> toDyn . withLength n8 . Vec.fromList + 9 -> toDyn . withLength n9 . Vec.fromList + 10 -> toDyn . withLength n10 . Vec.fromList + 11 -> toDyn . withLength n11 . Vec.fromList + 12 -> toDyn . withLength n12 . Vec.fromList + 13 -> toDyn . withLength n13 . Vec.fromList + 14 -> toDyn . withLength n14 . Vec.fromList + 15 -> toDyn . withLength n15 . Vec.fromList + 16 -> toDyn . withLength n16 . Vec.fromList + +makeListStream n = case n of + 0 -> fmap (\() -> []) . mconcat . map (toPrimStream . second (second (map (const ())))) + 1 -> fmap (:[]) . mconcat . map (toPrimStream . second (second (map head))) + 2 -> toStreamUsingLength n2 + 3 -> toStreamUsingLength n3 + 4 -> toStreamUsingLength n4 + 5 -> toStreamUsingLength n5 + 6 -> toStreamUsingLength n6 + 7 -> toStreamUsingLength n7 + 8 -> toStreamUsingLength n8 + 9 -> toStreamUsingLength n9 + 10 -> toStreamUsingLength n10 + 11 -> toStreamUsingLength n11 + 12 -> toStreamUsingLength n12 + 13 -> toStreamUsingLength n13 + 14 -> toStreamUsingLength n14 + 15 -> toStreamUsingLength n15 + 16 -> toStreamUsingLength n16 +-- 17 -> toStreamUsingLength n17 +-- 18 -> toStreamUsingLength n18 +-- 19 -> toStreamUsingLength n19 +-- 20 -> toStreamUsingLength $ s10 n10 +-- 21 -> toStreamUsingLength $ s10 n11 +-- 22 -> toStreamUsingLength $ s10 n12 +-- 23 -> toStreamUsingLength $ s10 n13 +-- 24 -> toStreamUsingLength $ s10 n14 +-- 25 -> toStreamUsingLength $ s10 n15 +-- 26 -> toStreamUsingLength $ s10 n16 +-- 27 -> toStreamUsingLength $ s10 n17 +-- 28 -> toStreamUsingLength $ s10 n18 +-- 29 -> toStreamUsingLength $ s10 n19 +-- 30 -> toStreamUsingLength $ s10 $ s10 n10 +-- 31 -> toStreamUsingLength $ s10 $ s10 n11 +-- 32 -> toStreamUsingLength $ s10 $ s10 n12 + + diff --git a/src/Graphics/GPipe/Collada/Utils.hs b/src/Graphics/GPipe/Collada/Utils.hs --- a/src/Graphics/GPipe/Collada/Utils.hs +++ b/src/Graphics/GPipe/Collada/Utils.hs @@ -1,147 +1,147 @@ ------------------------------------------------------------------------------ --- --- Module : Graphics.GPipe.Collada.Utils --- Copyright : Tobias Bexelius --- License : BSD3 --- --- Maintainer : Tobias Bexelius --- Stability : Experimental --- Portability : Portable --- +----------------------------------------------------------------------------- +-- +-- Module : Graphics.GPipe.Collada.Utils +-- Copyright : Tobias Bexelius +-- License : BSD3 +-- +-- Maintainer : Tobias Bexelius +-- Stability : Experimental +-- Portability : Portable +-- -- | --- This module contains the data types of the Collada scene graph. ------------------------------------------------------------------------------ -module Graphics.GPipe.Collada.Utils -( - -- * General Tree utilities - topDown, - bottomUp, - prune, - - -- * Scene utilities - SIDPath, - topDownSIDPath, - topDownTransform, - - -- * SID utilities - alterSID, - lookupSID, - - -- * Geometry utilities - hasDynVertex, - dynVertex, - - -- * Debug utilities - viewScene -) -where - -import Debug.Trace -import Graphics.GPipe.Collada -import Graphics.GPipe -import Data.Tree (Tree(), Forest) -import qualified Data.Tree as Tree -import Data.Maybe -import qualified Data.Vec.Base as Vec -import Data.Vec.Base ((:.)(..), Mat44, Mat33, Vec3) -import Data.Vec.LinAlg as Vec -import Data.Vec.LinAlg.Transform3D -import Data.Vec.Nat -import Control.Arrow (first) -import Data.Monoid -import Data.Dynamic -import qualified Data.Map as Map -import Data.Map (Map) -import qualified Data.Foldable as F -import Control.Monad -import Data.Vec.AABB - --- | Traverse a Tree top down, much like 'mapAccumL'. The function recieves an accumulator from its parent and generates one that is passed down to its children. --- Useful for accumulating transformations, etc. -topDown :: (acc -> x -> (acc, y)) -> acc -> Tree x -> Tree y -topDown f a (Tree.Node x xs) = case f a x of (acc', y) -> Tree.Node y $ map (topDown f acc') xs - --- | Traverse a Tree bottom up, much like 'mapAccumR'. The function recieves the accumulators of all its children and generates one that is passed up to its parent. --- Useful for accumulating AABBs, etc. -bottomUp :: ([acc] -> x -> (acc, y)) -> Tree x -> (acc, Tree y) -bottomUp f (Tree.Node x xs) = case unzip $ map (bottomUp f) xs of (accs, ys) -> case f accs x of (acc', y) -> (acc', Tree.Node y ys) - --- | Remove branches of a tree where the function evaluates to 'True'. Useful for selecting LODs, etc. -prune :: (a -> Bool) -> Tree a -> Maybe (Tree a) -prune f (Tree.Node x xs) = if f x then Nothing else Just $ Tree.Node x $ mapMaybe (prune f) xs - - ---------------------------------- --- | A path where the first string in the list is the closest ID and the rest is all SIDs found in order. -type SIDPath = [String] - --- | Traverse a tree top down accumulating the 'SIDPath' for each node. The projection function enables this to be used on trees that are not 'Scene's. --- The accumulated 'SIDPath' for a node will include the node's 'SID' at the end, but not its 'ID'. The 'ID' will however be the first 'String' in the --- 'SIDPath's of the children, and the nodes 'SID' won't be included in this case. -topDownSIDPath :: (x -> (SID, Maybe ID)) -> Tree x -> Tree (SIDPath,x) -topDownSIDPath f = topDown g [] - where g p x = case f x of - (msid, mid) -> let p' = p ++ maybeToList msid - in (maybe p' (:[]) mid, (p', x)) - --- | Traverse a tree top down accumulating the absolute transform for each node. The projection function enables this to be used on trees that are not 'Scene's. --- Use 'nodeMat' to get the @Mat44 Float@ from a node. The accumulated matrix for each node will contain the node's own transforms. -topDownTransform :: (x -> Mat44 Float) -> Tree x -> Tree (Mat44 Float,x) -topDownTransform f = topDown g identity - where g t x = let t' = t `multmm` (f x) in (t', (t', x)) - --- | For each 'SID'-attributed element in a list, apply the provided function. The elements where the function evaluates to 'Nothing' are removed. -alterSID :: (String -> a -> Maybe a) -> [(SID,a)] -> [(SID,a)] -alterSID f = mapMaybe (alterSID' f) - where - alterSID' f (msid@(Just sid), x) = fmap ((,) msid) $ f sid x - alterSID' _ a = Just a - --- | Find the first element in the list that is attributed with the provided SID. -lookupSID :: String -> [(SID,a)] -> Maybe a -lookupSID = lookup . Just - --- | Evaluates to 'True' where the 'Map' contains the semantic with the same type as the last argument (which is not evaluated and prefferably is a monotyped 'undefined'). -hasDynVertex :: Typeable a => Map Semantic TypeRep -> Semantic -> a -> Bool -hasDynVertex m s a = maybe False (== typeOf a) $ Map.lookup s m - --- | Extract the value of a specific semantic from the 'Map'. If the semantic is not found or the type is wrong, it evaluates to 'Nothing'. -dynVertex :: Typeable a => Map Semantic Dynamic -> Semantic -> Maybe a -dynVertex m s = Map.lookup s m >>= fromDynamic - ------------------------------------------ - --- | Render the scene using a simple shading technique through the first camera found, or through a defult camera if the scene doesn't contain any cameras. The scene's lights aren't --- used in the rendering. The source of this function can also serve as an example of how a Collada 'Scene' can be processed. -viewScene :: Scene -> Vec2 Int -> FrameBuffer RGBFormat DepthFormat () -viewScene tree (w:.h:.()) = framebuffer - where - aspect = fromIntegral w / fromIntegral h - - -- Retrieve cameras and geometries tagged with transforms - (cameras,geometries) = F.foldMap tagContent $ topDownTransform nodeMat $ fmap snd tree - tagContent (t,n) = let tagT = zip (repeat t) in (tagT $ nodeCameras n, tagT $ nodeGeometries n) - - -- Get the camera and inverted view matrix - (invView,cam) = head (cameras ++ [(translation (0:.0:.100:.()) , (Nothing, Perspective "" (ViewSizeY 35) (Z 1 10000)))]) - - -- The transform matrices - view = fromJust $ invert invView - proj = cameraMat aspect $ snd cam - viewProj = proj `multmm` view - - framebuffer = paint fragmentStream $ newFrameBufferColorDepth (RGB 0) 1 - paint = paintColorRastDepth Lequal True NoBlending (RGB $ Vec.vec True) - fragmentStream = fmap (RGB . Vec.vec) $ rasterizeFront primitiveStream - primitiveStream = mconcat $ concatMap filterGeometry geometries - filterGeometry (modelMat, (_,Mesh _ mesh)) = mapMaybe (filterMesh (viewProj `multmm` modelMat) (view `multmm` modelMat) modelMat) mesh - filterMesh modelViewProj modelView modelMat (TriangleMesh _ desc pstream aabb) = do - guard $ hasDynVertex desc "POSITION" (undefined :: Vec3 (Vertex Float)) -- Filter out geometries without 3D-positions - guard $ hasDynVertex desc "NORMAL" (undefined :: Vec3 (Vertex Float)) -- Filter out geometries without 3D-normals - guard $ testAABBprojection modelViewProj aabb /= Outside -- Frustum cull geometries - let normMat = Vec.transpose $ fromJust $ invert $ Vec.map (Vec.take n3) $ Vec.take n3 modelView - return $ fmap (\v -> let p = homPoint $ fromJust $ dynVertex v "POSITION" - nx:.ny:.nz:.() = (toGPU normMat :: Mat33 (Vertex Float)) `multmv` fromJust (dynVertex v "NORMAL") - in ((toGPU modelViewProj :: Mat44 (Vertex Float)) `multmv` p, max nz 0) - ) pstream - +-- This module contains the data types of the Collada scene graph. +----------------------------------------------------------------------------- +module Graphics.GPipe.Collada.Utils +( + -- * General Tree utilities + topDown, + bottomUp, + prune, + + -- * Scene utilities + SIDPath, + topDownSIDPath, + topDownTransform, + + -- * SID utilities + alterSID, + lookupSID, + + -- * Geometry utilities + hasDynVertex, + dynVertex, + + -- * Debug utilities + viewScene +) +where + +import Debug.Trace +import Graphics.GPipe.Collada +import Graphics.GPipe +import Data.Tree (Tree(), Forest) +import qualified Data.Tree as Tree +import Data.Maybe +import qualified Data.Vec.Base as Vec +import Data.Vec.Base ((:.)(..), Mat44, Mat33, Vec3) +import Data.Vec.LinAlg as Vec +import Data.Vec.LinAlg.Transform3D +import Data.Vec.Nat +import Control.Arrow (first) +import Data.Monoid +import Data.Dynamic +import qualified Data.Map as Map +import Data.Map (Map) +import qualified Data.Foldable as F +import Control.Monad +import Data.Vec.AABB + +-- | Traverse a Tree top down, much like 'mapAccumL'. The function recieves an accumulator from its parent and generates one that is passed down to its children. +-- Useful for accumulating transformations, etc. +topDown :: (acc -> x -> (acc, y)) -> acc -> Tree x -> Tree y +topDown f a (Tree.Node x xs) = case f a x of (acc', y) -> Tree.Node y $ map (topDown f acc') xs + +-- | Traverse a Tree bottom up, much like 'mapAccumR'. The function recieves the accumulators of all its children and generates one that is passed up to its parent. +-- Useful for accumulating AABBs, etc. +bottomUp :: ([acc] -> x -> (acc, y)) -> Tree x -> (acc, Tree y) +bottomUp f (Tree.Node x xs) = case unzip $ map (bottomUp f) xs of (accs, ys) -> case f accs x of (acc', y) -> (acc', Tree.Node y ys) + +-- | Remove branches of a tree where the function evaluates to 'True'. Useful for selecting LODs, etc. +prune :: (a -> Bool) -> Tree a -> Maybe (Tree a) +prune f (Tree.Node x xs) = if f x then Nothing else Just $ Tree.Node x $ mapMaybe (prune f) xs + + +--------------------------------- +-- | A path where the first string in the list is the closest ID and the rest is all SIDs found in order. +type SIDPath = [String] + +-- | Traverse a tree top down accumulating the 'SIDPath' for each node. The projection function enables this to be used on trees that are not 'Scene's. +-- The accumulated 'SIDPath' for a node will include the node's 'SID' at the end, but not its 'ID'. The 'ID' will however be the first 'String' in the +-- 'SIDPath's of the children, and the nodes 'SID' won't be included in this case. +topDownSIDPath :: (x -> (SID, Maybe ID)) -> Tree x -> Tree (SIDPath,x) +topDownSIDPath f = topDown g [] + where g p x = case f x of + (msid, mid) -> let p' = p ++ maybeToList msid + in (maybe p' (:[]) mid, (p', x)) + +-- | Traverse a tree top down accumulating the absolute transform for each node. The projection function enables this to be used on trees that are not 'Scene's. +-- Use 'nodeMat' to get the @Mat44 Float@ from a node. The accumulated matrix for each node will contain the node's own transforms. +topDownTransform :: (x -> Mat44 Float) -> Tree x -> Tree (Mat44 Float,x) +topDownTransform f = topDown g identity + where g t x = let t' = t `multmm` f x in (t', (t', x)) + +-- | For each 'SID'-attributed element in a list, apply the provided function. The elements where the function evaluates to 'Nothing' are removed. +alterSID :: (String -> a -> Maybe a) -> [(SID,a)] -> [(SID,a)] +alterSID f = mapMaybe (alterSID' f) + where + alterSID' f (msid@(Just sid), x) = fmap ((,) msid) $ f sid x + alterSID' _ a = Just a + +-- | Find the first element in the list that is attributed with the provided SID. +lookupSID :: String -> [(SID,a)] -> Maybe a +lookupSID = lookup . Just + +-- | Evaluates to 'True' where the 'Map' contains the semantic with the same type as the last argument (which is not evaluated and prefferably is a monotyped 'undefined'). +hasDynVertex :: Typeable a => Map Semantic TypeRep -> Semantic -> a -> Bool +hasDynVertex m s a = maybe False (== typeOf a) $ Map.lookup s m + +-- | Extract the value of a specific semantic from the 'Map'. If the semantic is not found or the type is wrong, it evaluates to 'Nothing'. +dynVertex :: Typeable a => Map Semantic Dynamic -> Semantic -> Maybe a +dynVertex m s = Map.lookup s m >>= fromDynamic + +----------------------------------------- + +-- | Render the scene using a simple shading technique through the first camera found, or through a defult camera if the scene doesn't contain any cameras. The scene's lights aren't +-- used in the rendering. The source of this function can also serve as an example of how a Collada 'Scene' can be processed. +viewScene :: Scene -> Vec2 Int -> FrameBuffer RGBFormat DepthFormat () +viewScene tree (w:.h:.()) = framebuffer + where + aspect = fromIntegral w / fromIntegral h + + -- Retrieve cameras and geometries tagged with transforms + (cameras,geometries) = F.foldMap tagContent $ topDownTransform nodeMat $ fmap snd tree + tagContent (t,n) = let tagT = zip (repeat t) in (tagT $ nodeCameras n, tagT $ nodeGeometries n) + + -- Get the camera and inverted view matrix + (invView,cam) = head (cameras ++ [(translation (0:.0:.100:.()) , (Nothing, Perspective "" (ViewSizeY 35) (Z 1 10000)))]) + + -- The transform matrices + view = fromJust $ invert invView + proj = cameraMat aspect $ snd cam + viewProj = proj `multmm` view + + framebuffer = paint fragmentStream $ newFrameBufferColorDepth (RGB 0) 1 + paint = paintColorRastDepth Lequal True NoBlending (RGB $ Vec.vec True) + fragmentStream = fmap (RGB . Vec.vec) $ rasterizeFront primitiveStream + primitiveStream = mconcat $ concatMap filterGeometry geometries + filterGeometry (modelMat, (_,Mesh _ mesh)) = mapMaybe (filterMesh (viewProj `multmm` modelMat) (view `multmm` modelMat) modelMat) mesh + filterMesh modelViewProj modelView modelMat (TriangleMesh _ desc pstream aabb) = do + guard $ hasDynVertex desc "POSITION" (undefined :: Vec3 (Vertex Float)) -- Filter out geometries without 3D-positions + guard $ hasDynVertex desc "NORMAL" (undefined :: Vec3 (Vertex Float)) -- Filter out geometries without 3D-normals + guard $ testAABBprojection modelViewProj aabb /= Outside -- Frustum cull geometries + let normMat = Vec.transpose $ fromJust $ invert $ Vec.map (Vec.take n3) $ Vec.take n3 modelView + return $ fmap (\v -> let p = homPoint $ fromJust $ dynVertex v "POSITION" + nx:.ny:.nz:.() = (toGPU normMat :: Mat33 (Vertex Float)) `multmv` fromJust (dynVertex v "NORMAL") + in ((toGPU modelViewProj :: Mat44 (Vertex Float)) `multmv` p, max nz 0) + ) pstream +