module Graphics.LambdaCube.SceneGraph where
import Control.Applicative
import Data.List (foldl')
import Graphics.LambdaCube.Common
import Graphics.LambdaCube.Entity
import Graphics.LambdaCube.GpuProgram
import Graphics.LambdaCube.HardwareIndexBuffer
import Graphics.LambdaCube.HardwareVertexBuffer
import Graphics.LambdaCube.Light
import Graphics.LambdaCube.RenderQueue
import Graphics.LambdaCube.RenderSystem
import Graphics.LambdaCube.Texture
import Graphics.LambdaCube.Tree
import Graphics.LambdaCube.Types
import Graphics.LambdaCube.World
type MkSceneObjectAction r vb ib q t p lp e = LCM (World r vb ib q t p lp) e (SceneObject vb ib t lp)
type MkNodeAction r vb ib q t p lp e = LCM (World r vb ib q t p lp) e ((String, String), SceneNode vb ib t lp)
camera :: RenderSystem r vb ib q t p lp => Camera -> MkSceneObjectAction r vb ib q t p lp e
camera = return . SO_Camera
simpleCamera :: RenderSystem r vb ib q t p lp => String -> MkSceneObjectAction r vb ib q t p lp e
simpleCamera name = return $ SO_Camera Camera
{ cmName = name
, cmFov = 45
, cmNear = 0.1
, cmFar = 5000
, cmAspectRatio = Nothing
, cmPolygonMode = PM_SOLID
}
wireCamera :: RenderSystem r vb ib q t p lp => String -> MkSceneObjectAction r vb ib q t p lp e
wireCamera name = return $ SO_Camera Camera
{ cmName = name
, cmFov = 45
, cmNear = 0.1
, cmFar = 5000
, cmAspectRatio = Nothing
, cmPolygonMode = PM_WIREFRAME
}
light :: RenderSystem r vb ib q t p lp => Light -> MkSceneObjectAction r vb ib q t p lp e
light = return . SO_Light
defaultLight :: RenderSystem r vb ib q t p lp => MkSceneObjectAction r vb ib q t p lp e
defaultLight = light $ Light
{ lgType = LT_POINT
, lgDiffuse = (1,1,1,1)
, lgDirection = Vec3 0 0 1
, lgSpecular = (0,0,0,0)
, lgSpotOuter = pi / 180 * 40
, lgSpotFalloff = 1
, lgRange = 100000
, lgAttenuationConst = 1
, lgAttenuationLinear = 0
, lgAttenuationQuad = 0
}
mesh :: (RenderSystem rs vb ib q t p lp, Enum rqp)
=> Maybe rqp
-> Maybe [String]
-> String
-> MkSceneObjectAction rs vb ib q t p lp e
mesh renderQueueID materials name = do
e <- createEntity name name (maybe (fromEnum RQP_Main) fromEnum renderQueueID)
case materials of
Nothing -> return (SO_Entity e)
Just mats -> SO_Entity <$> setEntityMaterial mats e
node :: RenderSystem r vb ib q t p lp
=> String
-> String
-> Proj4
-> [MkSceneObjectAction r vb ib q t p lp e]
-> MkNodeAction r vb ib q t p lp e
node parent name t objActs = do
o <- sequence objActs
return ((parent,name),SceneNode name o t)
addScene :: RenderSystem r vb ib q t p lp => [MkNodeAction r vb ib q t p lp e] -> LCM (World r vb ib q t p lp) e ()
addScene nodes = do
ns <- sequence nodes
graph <- scGraph . wrScene <$> peekLCM
let graph' = foldl' regNode graph ns
regNode g ((parent,name),node) = case addNode parent name node g of
Nothing -> error $ "Unknown parent node: " ++ parent
Just g' -> g'
updateWorld $ mapScene $ \s -> s { scGraph = graph' }
updateTransforms :: RenderSystem r vb ib q t p lp => [(String, Proj4)] -> LCM (World r vb ib q t p lp) e ()
updateTransforms l = updateWorld $ mapScene $ \s -> s { scGraph = foldl' update (scGraph s) l }
where
update g (name,mat) = updateNode (\sn -> sn { snTransform = mat }) name g
updateObjects :: RenderSystem rs vb ib q t p lp => [(String, [MkSceneObjectAction rs vb ib q t p lp e])] -> LCM (World rs vb ib q t p lp) e ()
updateObjects = mapM_ updateSceneNode
where
updateSceneNode (name,objActs) = do
o <- sequence objActs
updateWorld $ mapScene $ \s ->
s { scGraph = updateNode (\sn -> sn {snObject = o}) name (scGraph s) }
flattenScene :: (HardwareVertexBuffer vb, HardwareIndexBuffer ib, Texture t, LinkedGpuProgram lp) => Scene vb ib t lp -> FlattenScene vb ib t lp
flattenScene scene = FlattenScene
{ fsCamera = cs
, fsRenderable = rs
, fsLight = ls
}
where
pr = renderableDefaultPriority
(cs,rs,ls) = foldr sep ([],[],[])
[(m,o) | (m,os) <- flattenTree trans getObj idmtx (scGraph scene)
, o <- os
]
where
trans t sn = snTransform sn .*. t
getObj t sn = (trans t sn, snObject sn)
sep (m,SO_Camera c) (cs,rs,ls) = ((m,c):cs,rs,ls)
sep (m,SO_Entity e) (cs,rs,ls) = (cs,(m,prepare m e,enRenderQueue e,pr):rs,ls)
sep (m,SO_Light l) (cs,rs,ls) = (cs,rs,(m,l):ls)
renderWorld :: RenderSystem r vb ib q t p lp
=> FloatType
-> String
-> LCM (World r vb ib q t p lp) e ()
renderWorld time target = do
flatScene <- flattenScene . wrScene <$> peekLCM
renderFlatScene time target flatScene