GPipe-Collada (empty) → 0.1.0
raw patch · 6 files changed
+1099/−0 lines, 6 filesdep +GPipedep +HaXmldep +Vecsetup-changed
Dependencies added: GPipe, HaXml, Vec, Vec-Transform, array, base, containers, mtl
Files
- GPipe-Collada.cabal +39/−0
- Setup.lhs +6/−0
- src/Data/Vec/AABB.hs +86/−0
- src/Graphics/GPipe/Collada.hs +216/−0
- src/Graphics/GPipe/Collada/Parse.hs +605/−0
- src/Graphics/GPipe/Collada/Utils.hs +147/−0
+ GPipe-Collada.cabal view
@@ -0,0 +1,39 @@+name: GPipe-Collada+version: 0.1.0+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+ Graphics.GPipe.Collada.Utils+ extensions: GeneralizedNewtypeDeriving + StandaloneDeriving + FlexibleInstances + MultiParamTypeClasses + ScopedTypeVariables+ hs-source-dirs: src
+ Setup.lhs view
@@ -0,0 +1,6 @@+#!/usr/bin/runhaskell +> module Main where +> import Distribution.Simple +> main :: IO () +> main = defaultMain +
+ src/Data/Vec/AABB.hs view
@@ -0,0 +1,86 @@+----------------------------------------------------------------------------- +-- +-- 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) +
+ src/Graphics/GPipe/Collada.hs view
@@ -0,0 +1,216 @@+----------------------------------------------------------------------------- +-- +-- 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
+ src/Graphics/GPipe/Collada/Parse.hs view
@@ -0,0 +1,605 @@+----------------------------------------------------------------------------- +-- +-- 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 +
+ src/Graphics/GPipe/Collada/Utils.hs view
@@ -0,0 +1,147 @@+----------------------------------------------------------------------------- +-- +-- 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 +