RenderQueue.hs

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

-- | Standard render queue priorities.  Note that any enumeration type
-- can be used to specify render priorities (i.e. top-level drawing
-- order), this is just a simple convenience type.
data RenderQueuePriority
    = RQP_Background
    | RQP_EarlySky
    | RQP_EarlyWorld
    | RQP_Main
    | RQP_LateWorld
    | RQP_LateSky
    | RQP_Overlay
    deriving Enum

-- | The default render queue priority.
defaultRQP :: Maybe RenderQueuePriority
defaultRQP = Nothing

renderableDefaultPriority :: Int
renderableDefaultPriority = 100

data RenderGroupOptions
    = RenderGroupOptions
    { rqoShadowsEnabled :: Bool
    }

defaultRenderGroupOptions :: RenderGroupOptions
defaultRenderGroupOptions = RenderGroupOptions
    { rqoShadowsEnabled = True
    }

-- | Struct associating a single Pass with a single Renderable.
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
--            print $ "  geomGrp len: " ++ (show $ length r)
            --TODO: setup object related shader parameters
            bindGeometry rs rop $ psTextureUnitStates pass
            mapM_ (renderGeom pass) r
            unbindGeometry rs rop

            -- calculate statistics
            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
            --TODO: do pass and per light iterations
            --       light list with attributes
            -- filter relevant lights
            let lights      = {-drop (psStartLight pass) $ take (psMaxSimultaneousLights pass) $ filter filtL $ -}rpLights r
                --filtL (_,l) = case psOnlyLightType pass of
                --    Nothing   -> True
                --    Just t    -> t == (lgType l)
                dropEmpty [] = False
                dropEmpty _ = True
                -- create light groups according requirement (per n light)
                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
            -- render n times each light group
            --putStrLn $ " iterationCnt: " ++ show iterationCnt ++ " len lightGrp: " ++ show lightGrp
            setWorldMatrix rs $ rpMatrix r
            forM_ lightGrp $ \l -> do
                --TODO setup lights
                --print $ ("light cnt:",length l)
                useLights rs l
                --TODO: setup per light iteration shader parameters
                forM_ [1..iterationCnt] $ \pc -> do
                    -- TODO: update iteration dependent parameteres:
                        --TODO: setup pass iteration number shader parameter
                    -- Update derived depth bias
                    when (pc > 1 && depthBiasPerIter /= 0) $ setDepthBias rs (depthBiasConstant + (fromIntegral pc-1) * depthBiasPerIter) depthBiasSlopeScale
                    render rs $ rpOperation r

    setPass time rs pass
--    print $ "passGrp len: " ++ (show $ length r) ++ " " ++ show [ tusFrameNames tu | tu <- psTextureUnitStates pass ]
    --TODO: setup global pass related shader parameters
    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

        -- group by pass and geometry
        passGroupRenderMethod rst a = foldM' (renderPassGroup time rs) rst $ groupSetBy passCmp a

        -- sort by distance
        --distanceSortRenderMethod = undefined

        -- simple render
        --simpleRenderMethod = undefined


        rents   = concatMap (\(_,r,_,_) -> r) rl
        --(_,_,grpID,_) = head rl
        --ropt = fromMaybe defaultRenderGroupOptions $ IntMap.lookup grpID roptMap

        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

    --putStr $ "group prio:" ++ show grpID ++ " items: " ++ show (length rl) ++ " "
    --putStr $ "solids: " ++ show (length solids) ++ " "
    --putStrLn $ "transparents: " ++ show (length transparents)

    -- Do solids
    rstat1 <- passGroupRenderMethod rstat [RenderablePass ro p m lights | RenderEntity ro pl m _ <- solids, p <- pl]

    -- TEMP solution, transparents together
    rstat2 <- passGroupRenderMethod rstat1 [RenderablePass ro p m lights | RenderEntity ro pl m _ <- transparents, p <- pl]

    -- Do unsorted transparents
    --simpleRenderMethod $ rpgTransparentsUnsorted rpg

    -- Do transparents (always descending)
    --distanceSortRenderMethod $ rpgTransparents rpg
    return rstat2

-- Fast
--renderQueue :: (RenderSystem rs, Renderable r) => rs -> IntMap RenderGroupOptions -> [(Matrix4,r,Int,Int)] -> IO ()
-- TODO: maybe we should try parallelize this code
-- HINT: Ogre uses radix sort
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 grpPriorSortCmp al bl = case ga `compare` gb of
            { LT    -> LT
            ; EQ    -> pa `compare` pb
            ; GT    -> GT
            }
          where
            (_,_,ga,pa) = head al
            (_,_,gb,pb) = head bl
    -}
    let grpPriorGroupCmp (_,_,ga,_) (_,_,gb,_) = compare ga gb
        sortedGroups = groupSetBy grpPriorGroupCmp renderables
--        sortedGroups = sortBy (\((_,_,a,_):_) ((_,_,b,_):_) -> a `compare` b) groups
--    foldM' (renderCollection rs roptMap) rstat $ groupBy grpPriorGroupCmp $ sortBy grpPriorSortCmp rl
    --putStrLn $ "renderqueue renderables: " ++ show (length renderables)
    --putStrLn $ "renderqueue sorted: " ++ show (length sortedGroups)
    rstatres <- foldM' (renderCollection time rs roptMap lights) rstat sortedGroups
    --putStrLn " * renderScene end"
    return rstatres