module Graphics.GPipe.Collada.Utils
(
topDown,
bottomUp,
prune,
SIDPath,
topDownSIDPath,
topDownTransform,
alterSID,
lookupSID,
hasDynVertex,
dynVertex,
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
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
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)
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
type SIDPath = [String]
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))
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))
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
lookupSID :: String -> [(SID,a)] -> Maybe a
lookupSID = lookup . Just
hasDynVertex :: Typeable a => Map Semantic TypeRep -> Semantic -> a -> Bool
hasDynVertex m s a = maybe False (== typeOf a) $ Map.lookup s m
dynVertex :: Typeable a => Map Semantic Dynamic -> Semantic -> Maybe a
dynVertex m s = Map.lookup s m >>= fromDynamic
viewScene :: Scene -> Vec2 Int -> FrameBuffer RGBFormat DepthFormat ()
viewScene tree (w:.h:.()) = framebuffer
where
aspect = fromIntegral w / fromIntegral h
(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)
(invView,cam) = head (cameras ++ [(translation (0:.0:.100:.()) , (Nothing, Perspective "" (ViewSizeY 35) (Z 1 10000)))])
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))
guard $ hasDynVertex desc "NORMAL" (undefined :: Vec3 (Vertex Float))
guard $ testAABBprojection modelViewProj aabb /= Outside
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