GPipe-Collada 0.1.1 → 0.1.2
raw patch · 6 files changed
+1073/−1096 lines, 6 filesdep ~GPipedep ~Vecdep ~Vec-Transformsetup-changed
Dependency ranges changed: GPipe, Vec, Vec-Transform, array, base, containers
Files
- GPipe-Collada.cabal +37/−39
- Setup.lhs +6/−6
- src/Data/Vec/AABB.hs +85/−85
- src/Graphics/GPipe/Collada.hs +216/−215
- src/Graphics/GPipe/Collada/Parse.hs +583/−605
- src/Graphics/GPipe/Collada/Utils.hs +146/−146
GPipe-Collada.cabal view
@@ -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 ++
Setup.lhs view
@@ -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+
src/Data/Vec/AABB.hs view
@@ -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)+
src/Graphics/GPipe/Collada.hs view
@@ -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
src/Graphics/GPipe/Collada/Parse.hs view
@@ -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+ +
src/Graphics/GPipe/Collada/Utils.hs view
@@ -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+