module Graphics.LambdaCube.RenderQueue where
import Control.Monad
import Data.IntMap (IntMap)
import Data.List
import Data.Maybe
import Data.Ord
import Graphics.LambdaCube.BlendMode
import Graphics.LambdaCube.GpuProgram
import Graphics.LambdaCube.HardwareIndexBuffer
import Graphics.LambdaCube.HardwareVertexBuffer
import Graphics.LambdaCube.Light
import Graphics.LambdaCube.Pass
import Graphics.LambdaCube.RenderOperation
import Graphics.LambdaCube.RenderSystem
import Graphics.LambdaCube.Texture
import Graphics.LambdaCube.Types
import Graphics.LambdaCube.Utility
import Graphics.LambdaCube.VertexIndexData
data RenderQueuePriority
= RQP_Background
| RQP_EarlySky
| RQP_EarlyWorld
| RQP_Main
| RQP_LateWorld
| RQP_LateSky
| RQP_Overlay
deriving Enum
defaultRQP :: Maybe RenderQueuePriority
defaultRQP = Nothing
renderableDefaultPriority :: Int
renderableDefaultPriority = 100
data RenderGroupOptions
= RenderGroupOptions
{ rqoShadowsEnabled :: Bool
}
defaultRenderGroupOptions :: RenderGroupOptions
defaultRenderGroupOptions = RenderGroupOptions
{ rqoShadowsEnabled = True
}
data (HardwareVertexBuffer vb, HardwareIndexBuffer ib, Texture t, LinkedGpuProgram lp) => RenderablePass vb ib t lp
= RenderablePass
{ rpOperation :: RenderOperation vb ib
, rpPass :: Pass t lp
, rpMatrix :: Proj4
, rpLights :: [(Proj4,Light)]
}
data RenderStatistics
= RenderStatistics
{ rsFaceCount :: Int
, rsVertexCount :: Int
, rsBatchCount :: Int
}
deriving Show
emptyRenderStatistics :: RenderStatistics
emptyRenderStatistics = RenderStatistics
{ rsFaceCount = 0
, rsVertexCount = 0
, rsBatchCount = 0
}
renderPassGroup :: (RenderSystem rs vb ib q t p lp) => FloatType -> rs -> RenderStatistics -> [RenderablePass vb ib t lp] -> IO RenderStatistics
renderPassGroup time rs rstat r = do
let pass = rpPass $ head r
depthBiasConstant = psDepthBiasConstant pass
depthBiasPerIter = psDepthBiasPerIteration pass
depthBiasSlopeScale = psDepthBiasSlopeScale pass
iterationCnt = psPassIterationCount pass
geomCmp = comparing rpOperation
renderGeomGrp pass rst r = do
let rop = rpOperation $ head r
geomCnt = length r
bindGeometry rs rop $ psTextureUnitStates pass
mapM_ (renderGeom pass) r
unbindGeometry rs rop
let val = if isNothing $ roIndexData rop then vdVertexCount $ roVertexData rop else idIndexCount $ fromJust $ roIndexData rop
val' = case roOperationType rop of
OT_TRIANGLE_LIST -> val `div` 3
OT_TRIANGLE_STRIP -> val 2
OT_TRIANGLE_FAN -> val 2
_ -> 0
fc = geomCnt * iterationCnt * val' + rsFaceCount rst
vc = geomCnt * (vdVertexCount $ roVertexData rop) + rsVertexCount rst
bc = geomCnt * iterationCnt + rsBatchCount rst
fc `seq` vc `seq` bc `seq` return RenderStatistics
{ rsFaceCount = fc
, rsVertexCount = vc
, rsBatchCount = bc
}
renderGeom pass r = do
let lights = rpLights r
dropEmpty [] = False
dropEmpty _ = True
lightGrp = filter dropEmpty $ case psLightsPerIteration pass of
Nothing -> [lights]
Just n -> f n lights
f _ [] = []
f n l = h:(f n t)
where
(h,t) = splitAt n l
setWorldMatrix rs $ rpMatrix r
forM_ lightGrp $ \l -> do
useLights rs l
forM_ [1..iterationCnt] $ \pc -> do
when (pc > 1 && depthBiasPerIter /= 0) $ setDepthBias rs (depthBiasConstant + (fromIntegral pc1) * depthBiasPerIter) depthBiasSlopeScale
render rs $ rpOperation r
setPass time rs pass
foldM' (renderGeomGrp pass) rstat $ groupSetBy geomCmp r
renderCollection :: (RenderSystem rs vb ib q t p lp) => FloatType -> rs -> IntMap RenderGroupOptions ->
[(Proj4,Light)] -> RenderStatistics -> [(Proj4, [RenderEntity vb ib t lp], Int, Int)] -> IO RenderStatistics
renderCollection time rs _roptMap lights rstat rl = do
let passCmp = comparing rpPass
--groupPass
passGroupRenderMethod rst a = foldM' (renderPassGroup time rs) rst $ groupSetBy passCmp a
rents = concatMap (\(_,r,_,_) -> r) rl
isTransparent p = case separateBlend of
True -> alpha && color
False -> case separateBlendOperation of
True -> alpha && color
False -> color
where
alpha = sourceFactorAlpha == SBF_ONE && destFactorAlpha == SBF_ZERO
color = sourceFactor == SBF_ONE && destFactor == SBF_ZERO
Pass
{ psSeparateBlend = separateBlend
, psSeparateBlendOperation = separateBlendOperation
, psSourceBlendFactor = sourceFactor
, psDestBlendFactor = destFactor
, psSourceBlendFactorAlpha = sourceFactorAlpha
, psDestBlendFactorAlpha = destFactorAlpha
} = p
hasTransparent l = foldl' (\a b -> a || isTransparent b) False l
(solids,transparents) = partition (\a -> hasTransparent $ rePassList a) rents
rstat1 <- passGroupRenderMethod rstat [RenderablePass ro p m lights | RenderEntity ro pl m _ <- solids, p <- pl]
rstat2 <- passGroupRenderMethod rstat1 [RenderablePass ro p m lights | RenderEntity ro pl m _ <- transparents, p <- pl]
return rstat2
renderQueue :: (RenderSystem rs vb ib q t p lp) => FloatType -> rs -> IntMap RenderGroupOptions -> RenderStatistics ->
[(Proj4,Light)] -> [(Proj4, [RenderEntity vb ib t lp], Int, Int)] -> IO RenderStatistics
renderQueue time rs roptMap rstat lights renderables = do
let grpPriorGroupCmp (_,_,ga,_) (_,_,gb,_) = compare ga gb
sortedGroups = groupSetBy grpPriorGroupCmp renderables
rstatres <- foldM' (renderCollection time rs roptMap lights) rstat sortedGroups
return rstatres