RenderSystem.hs

{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, ParallelListComp #-}
module Graphics.LambdaCube.RenderSystem where

import Control.Monad
import Data.Maybe
import Data.Word
import Foreign.Ptr
import qualified Data.Set as Set

import Graphics.LambdaCube.BlendMode
import Graphics.LambdaCube.Common
import Graphics.LambdaCube.GpuProgram
import Graphics.LambdaCube.HardwareBuffer
import Graphics.LambdaCube.HardwareIndexBuffer
import Graphics.LambdaCube.HardwareOcclusionQuery
import Graphics.LambdaCube.HardwareVertexBuffer
import Graphics.LambdaCube.Image
import Graphics.LambdaCube.Light
import Graphics.LambdaCube.Pass
import Graphics.LambdaCube.PixelFormat
import Graphics.LambdaCube.RenderOperation
import Graphics.LambdaCube.RenderSystemCapabilities
import Graphics.LambdaCube.Texture
import Graphics.LambdaCube.TextureUnitState
import Graphics.LambdaCube.Types

data TexCoordCalcMethod
    = TEXCALC_NONE                       -- ^ No calculated texture coordinates
    | TEXCALC_ENVIRONMENT_MAP            -- ^ Environment map based on vertex normals
    | TEXCALC_ENVIRONMENT_MAP_PLANAR     -- ^ Environment map based on vertex positions
    | TEXCALC_ENVIRONMENT_MAP_REFLECTION -- ^ Environment map based on vertex positions
    | TEXCALC_ENVIRONMENT_MAP_NORMAL     -- ^ Environment map based on vertex positions
    | TEXCALC_PROJECTIVE_TEXTURE         -- ^ Projective texture
    deriving Eq

data StencilOperation
    = SOP_KEEP           -- ^ Leave the stencil buffer unchanged
    | SOP_ZERO           -- ^ Set the stencil value to zero
    | SOP_REPLACE        -- ^ Set the stencil value to the reference value
    | SOP_INCREMENT      -- ^ Increase the stencil value by 1, clamping at the maximum value
    | SOP_DECREMENT      -- ^ Decrease the stencil value by 1, clamping at 0
    | SOP_INCREMENT_WRAP -- ^ Increase the stencil value by 1, wrapping back to 0 when incrementing the maximum value
    | SOP_DECREMENT_WRAP -- ^ Decrease the stencil value by 1, wrapping when decrementing 0
    | SOP_INVERT         -- ^ Invert the bits of the stencil buffer
    deriving Eq

class (HardwareVertexBuffer vb, HardwareIndexBuffer ib, HardwareOcclusionQuery q, Texture t, GpuProgram p, LinkedGpuProgram lp) => RenderSystem rs vb ib q t p lp | rs -> vb ib q t p lp where
    prepareRender               :: rs -> IO ()
    finishRender                :: rs -> IO ()
    createVertexBuffer          :: rs -> Int -> Int -> Usage -> Bool -> IO vb
    createIndexBuffer           :: rs -> IndexType -> Int -> Usage -> Bool -> IO ib
    createTexture               :: rs -> String -> TextureType -> Int -> Int -> Int -> TextureMipmap -> PixelFormat -> TextureUsage -> Bool -> Int -> String -> Maybe [Image] -> IO t
    withFrameBuffer             :: rs -> Int -> Int -> Int -> Int -> (Ptr Word8 -> IO ()) -> IO ()
    dirtyHackCopyTexImage       :: rs -> t -> Int -> Int -> Int -> Int -> IO () --FIXME: TEMP HACK!!!!!
    createGpuProgram            :: rs -> GpuProgramType -> String -> IO (Either p String) -- TODO
    createLinkedGpuProgram      :: rs -> [p] -> IO (Either lp String) -- TODO
    getName                     :: rs -> String                                  -- ^ Returns the name of the rendering system.
    createOcclusionQuery        :: rs -> IO q                                    -- ^ Create an object for performing hardware occlusion queries.
    setAmbientLight             :: rs -> Float -> Float -> Float -> IO ()        -- ^ Sets the colour & strength of the ambient (global directionless) light in the world.
    setShadingType              :: rs -> ShadeOptions -> IO ()                   -- ^ Sets the type of light shading required (default = Gouraud).
    setLightingEnabled          :: rs -> Bool -> IO ()
    setWBufferEnabled           :: rs -> Bool -> IO ()
    setWaitForVerticalBlank     :: rs -> Bool -> IO ()
    useLights                   :: rs -> [(Proj4,Light)] -> IO ()
    setWorldMatrix              :: rs -> Proj4 -> IO ()                        -- ^ Sets the world transform matrix.
    setViewMatrix               :: rs -> Proj4 -> IO ()                        -- ^ Sets the view transform matrix
    setProjectionMatrix         :: rs -> Mat4 -> IO ()                        -- ^ Sets the projection transform matrix
    setSurfaceParams            :: rs -> ColourValue -> ColourValue -> ColourValue -> ColourValue -> FloatType -> TrackVertexColourType -> IO ()
    setPointSpritesEnabled      :: rs -> Bool -> IO ()
    setPointParameters          :: rs -> FloatType -> Bool -> FloatType -> FloatType -> FloatType -> FloatType -> FloatType -> IO ()
    setActiveTextureUnit        :: rs -> Int -> IO ()
    setTexture                  :: rs -> Maybe t -> IO ()
    setVertexTexture            :: rs -> Maybe t -> IO ()
    setTextureCoordCalculation  :: rs -> TexCoordCalcMethod{- -> Frustum-} -> IO ()
    setTextureBlendMode         :: rs -> LayerBlendModeEx -> LayerBlendModeEx -> IO ()
    setTextureUnitFiltering     :: rs -> TextureType -> FilterOptions -> FilterOptions -> FilterOptions -> IO ()
    setTextureLayerAnisotropy   :: rs -> TextureType -> Int -> IO ()
    setTextureAddressingMode    :: rs -> TextureType -> UVWAddressingMode -> IO ()
    setTextureBorderColour      :: rs -> TextureType -> ColourValue -> IO ()
    setTextureMipmapBias        :: rs -> FloatType -> IO ()
    setTextureMatrix            :: rs -> Proj4 -> IO ()
    setSceneBlending            :: rs -> SceneBlendFactor -> SceneBlendFactor -> SceneBlendOperation -> IO ()
    setSeparateSceneBlending    :: rs -> SceneBlendFactor -> SceneBlendFactor -> SceneBlendFactor -> SceneBlendFactor -> SceneBlendOperation -> SceneBlendOperation -> IO ()
    setAlphaRejectSettings      :: rs -> CompareFunction -> Int -> Bool -> IO ()
    setViewport                 :: rs -> Int -> Int -> Int -> Int -> IO ()
    setCullingMode              :: rs -> CullingMode -> IO ()
    setDepthBufferParams        :: rs -> Bool -> Bool -> CompareFunction -> IO ()
    setDepthBufferCheckEnabled  :: rs -> Bool -> IO ()
    setDepthBufferWriteEnabled  :: rs -> Bool -> IO ()
    setDepthBufferFunction      :: rs -> CompareFunction -> IO ()
    setColourBufferWriteEnabled :: rs -> Bool -> Bool -> Bool -> Bool -> IO ()
    setDepthBias                :: rs -> FloatType -> FloatType -> IO ()
    setFog                      :: rs -> FogMode -> ColourValue -> FloatType -> FloatType -> FloatType -> IO ()
    setPolygonMode              :: rs -> PolygonMode -> IO ()
    setStencilCheckEnabled      :: rs -> Bool -> IO ()
    setStencilBufferParams      :: rs -> CompareFunction -> Word32 -> Word32 -> StencilOperation -> StencilOperation -> StencilOperation -> Bool -> IO ()
    setNormaliseNormals         :: rs -> Bool -> IO ()
    render                      :: rs -> RenderOperation vb ib -> IO ()
    bindGeometry                :: rs -> RenderOperation vb ib -> [TextureUnitState t] -> IO ()
    unbindGeometry              :: rs -> RenderOperation vb ib -> IO ()
    getCapabilities             :: rs -> RenderSystemCapabilities
    bindLinkedGpuProgram        :: rs -> lp -> IO ()
    unbindLinkedGpuProgram      :: rs -> IO ()
    setScissorTest              :: rs -> Bool -> Int -> Int -> Int -> Int -> IO ()
    clearFrameBuffer            :: rs -> FrameBufferType -> ColourValue -> FloatType -> Word16 -> IO ()
    getHorizontalTexelOffset    :: rs -> IO FloatType
    getVerticalTexelOffset      :: rs -> IO FloatType
    getMinimumDepthInputValue   :: rs -> FloatType
    getMaximumDepthInputValue   :: rs -> FloatType

class (HardwareVertexBuffer vb, HardwareIndexBuffer ib, Texture t, LinkedGpuProgram lp) => Renderable r vb ib t lp | r -> vb ib t lp where
    prepare :: Proj4 -> r -> [RenderEntity vb ib t lp]

data (HardwareVertexBuffer vb, HardwareIndexBuffer ib, Texture t, LinkedGpuProgram lp) => RenderEntity vb ib t lp
    = RenderEntity
    { reOperation   :: RenderOperation vb ib
    , rePassList    :: [Pass t lp]
    , reMatrix      :: Proj4
    , reBoundRadius :: FloatType
    }

setPass :: (RenderSystem rs vb ib q t p lp) => FloatType -> rs -> Pass t lp -> IO ()
setPass time rs pass = do
    let rsc     = getCapabilities rs
        caps    = rscCapabilities rsc
        Pass
            { --psName                     :: String                      -- ^ optional name for the pass

            -- Colour properties, only applicable in fixed-function passes
              psAmbient                     = ambient
            , psDiffuse                     = diffuse
            , psSpecular                    = specular
            , psEmissive                    = emissive
            , psShininess                   = shininess
            , psTracking                    = vertexColourTracking

            -- Blending factors
            , psSourceBlendFactor           = sourceBlendFactor
            , psDestBlendFactor             = destBlendFactor
            , psSourceBlendFactorAlpha      = sourceBlendFactorAlpha
            , psDestBlendFactorAlpha        = destBlendFactorAlpha

            , psSeparateBlend               = separateBlend

            -- Blending operations
            , psBlendOperation              = blendOperation
            , psAlphaBlendOperation         = alphaBlendOperation
            , psSeparateBlendOperation      = separateBlendOperation

            -- Depth buffer settings
            , psDepthCheck                  = depthCheck
            , psDepthWrite                  = depthWrite
            , psDepthFunc                   = depthFunc
            , psDepthBiasConstant           = depthBiasConstant
            , psDepthBiasSlopeScale         = depthBiasSlopeScale
--            , psDepthBiasPerIteration    :: FloatType

            -- Colour buffer settings
            , psColourWrite                 = colourWrite

            -- Alpha reject settings
            , psAlphaRejectFunc             = alphaRejectFunc
            , psAlphaRejectVal              = alphaRejectVal
            , psAlphaToCoverageEnabled      = alphaToCoverageEnabled

--            , psTransparentSorting       :: Bool                        -- ^ Transparent depth sorting
--            , psTransparentSortingForced :: Bool                        -- ^ Transparent depth sorting forced

            -- Culling mode
            , psCullMode                    = cullMode
--            , psManualCullMode           :: ManualCullingMode

            , psLightingEnabled             = lightingEnabled
--            , psMaxSimultaneousLights    :: Int                         -- ^ Max simultaneous lights
--            , psStartLight               :: Int                         -- ^ Starting light index
--            , psLightsPerIteration       :: Maybe Int                   -- ^ Run this pass once per light? Iterate per how many lights?
--            , psOnlyLightType            :: Maybe LightTypes            -- ^ Should it only be run for a certain light type?

            , psShadeOptions                = shadeOptions
            , psPolygonMode	                = polygonMode

            -- Normalisation
--            , psNormaliseNormals         :: Bool
            , psPolygonModeOverrideable     = polygonModeOverrideable

            -- Fog
--            , psFogOverride                 = fogOverride
            , psFogMode                     = fogMode
            , psFogColour                   = fogColour
            , psFogStart                    = fogStart
            , psFogEnd                      = fogEnd
            , psFogDensity                  = fogDensity

            , psTextureUnitStates           = textureUnitStates

--            , psVertexProgramUsage          = vertexProgramUsage
--            , psFragmentProgramUsage        = fragmentProgramUsage
--            , psGeometryProgramUsage        = geometryProgramUsage
            , psLinkedGpuProgram            = linkedGpuProgram

--            , psPassIterationCount       :: Int                         -- ^ number of pass iterations to perform

            , psPointSize                   = pointSize
            , psPointMinSize                = pointMinSize
            , psPointMaxSize                = pointMaxSize
            , psPointSpritesEnabled         = pointSpritesEnabled
            , psPointAttenuationEnabled     = pointAttenuationEnabled
--            , psPointAttenuationCoeffs   :: FloatType3                  -- ^ constant, linear, quadratic coeffs

--            , psLightScissoring          :: Bool                        -- ^ Scissoring for the light?
--            , psLightClipPlanes          :: Bool                        -- ^ User clip planes for light?
--            , psIlluminationStage        :: IlluminationStage           -- ^ Illumination stage?
            } = pass
    let passSurfaceAndLightParams = True
        passFogParams = True

    case linkedGpuProgram of
        Nothing   -> unbindLinkedGpuProgram rs
        Just lp   -> bindLinkedGpuProgram rs lp

    when passSurfaceAndLightParams $ do
        -- Set surface reflectance properties, only valid if lighting is enabled
        when lightingEnabled $
             setSurfaceParams rs ambient diffuse specular emissive shininess vertexColourTracking
        -- Dynamic lighting enabled?
        setLightingEnabled rs lightingEnabled

    when passFogParams $ do
        -- New fog params can either be from scene or from material
        -- TODO: implement override
        --setFog rs newFogMode newFogColour newFogDensity newFogStart newFogEnd
        setFog rs fogMode fogColour fogDensity fogStart fogEnd
    -- TODO

    -- The rest of the settings are the same no matter whether we use programs or not

    -- Set scene blending
    case separateBlend of
        True  -> setSeparateSceneBlending rs sourceBlendFactor destBlendFactor
                 sourceBlendFactorAlpha destBlendFactorAlpha blendOperation
                 (if separateBlendOperation then blendOperation else alphaBlendOperation)
        False -> case psSeparateBlendOperation pass of
            True  -> setSeparateSceneBlending rs sourceBlendFactor destBlendFactor
                     sourceBlendFactor destBlendFactor blendOperation alphaBlendOperation
            False -> setSceneBlending rs sourceBlendFactor destBlendFactor blendOperation

    -- Set point parameters
    let (pac,pal,paq) = psPointAttenuationCoeffs pass -- TODO: refactor
    setPointParameters rs pointSize pointAttenuationEnabled pac pal paq pointMinSize pointMaxSize

    when (Set.member RSC_POINT_SPRITES caps) $
        setPointSpritesEnabled rs pointSpritesEnabled

    -- Texture unit settings

    -- TODO
    sequence_ [setTextureUnitSettings time rs i tus | i <- [0..] | tus <- textureUnitStates]

    -- Disable remaining texture units
    forM_ [length textureUnitStates..rscNumTextureUnits (getCapabilities rs) - 1] $ \tu -> do
        -- TODO: dont disable disabled texunits
        setActiveTextureUnit rs tu
        setTexture rs Nothing

    -- Set up non-texture related material settings
    -- Depth buffer settings
    setDepthBufferFunction rs depthFunc
    setDepthBufferCheckEnabled rs depthCheck
    setDepthBufferWriteEnabled rs depthWrite
    setDepthBias rs depthBiasConstant depthBiasSlopeScale

    -- Alpha-reject settings
    setAlphaRejectSettings rs alphaRejectFunc alphaRejectVal alphaToCoverageEnabled

    -- Set colour write mode
    -- Right now we only use on/off, not per-channel
    setColourBufferWriteEnabled rs colourWrite colourWrite colourWrite colourWrite
    -- TODO: calc cull mode according illumination stage
    setCullingMode rs cullMode
    -- Shading
    setShadingType rs shadeOptions

    -- Polygon mode
    unless polygonModeOverrideable $
        setPolygonMode rs polygonMode

setTextureUnitSettings :: (RenderSystem rs vb ib q t p lp) => FloatType -> rs -> Int -> TextureUnitState t -> IO ()
setTextureUnitSettings time rs texUnit tl = do
    let rsc     = getCapabilities rs
        caps    = rscCapabilities rsc
        TextureUnitState
            { tusAnimDuration           = animDuration
--            , tusCubic                   :: Bool                -- ^ is this a series of 6 2D textures to make up a cube?

            , tusTextureType            = texType
--            , tusDesiredFormat           :: PixelFormat
--            , tusTextureSrcMipmaps       :: Int                 -- ^ Request number of mipmaps

--            , tusTextureCoordSetIndex    :: Int
            , tusAddressMode            = uvw
            , tusBorderColour           = borderColour

            , tusColourBlendMode        = colourBlendMode
--            , tusColourBlendFallbackSrc  :: SceneBlendFactor
--            , tusColourBlendFallbackDest :: SceneBlendFactor

            , tusAlphaBlendMode         = alphaBlendMode
        --    , tusTextureLoadFailed       :: Bool
--            , tusIsAlpha                 :: Bool
--            , tusHwGamma                 :: Bool

            , tusMinFilter              = minFilter
            , tusMagFilter              = magFilter
            , tusMipFilter              = mipFilter

            , tusMaxAniso               = maxAniso
            , tusMipmapBias             = mipmapBias

            , tusBindingType            = bindingType
--            , tusContentType             :: ContentType      -- ^ Content type of texture (normal loaded texture, auto-texture)

--            , tusFrameNames              :: [String]
            , tusFrames                 = frames
--            , tusName                    :: String          -- ^ optional name for the TUS
--            , tusTextureAlias            :: String          -- ^ optional alias for texture frames
            , tusEffects                = effects
            }   = tl
        texl    = fromMaybe (error "fromJust 12") frames

    -- Activate TextureUnit
    setActiveTextureUnit rs texUnit
    -- Vertex texture binding?
    unless (null texl) $ do
        let tex = case animDuration of
                Nothing   -> head texl
                Just 0    -> head texl
                Just d    -> texl !! (floor $ (fromIntegral $ length texl) * (snd $ pf $ time / d))
                  where
                    pf :: FloatType -> (Int, FloatType)
                    pf = properFraction
        case Set.member RSC_VERTEX_TEXTURE_FETCH caps && not (rscVertexTextureUnitsShared rsc) of
            True  -> case bindingType of
              BT_VERTEX -> do
                -- Bind vertex texture
                setVertexTexture rs $ Just tex
                -- bind nothing to fragment unit (hardware isn't shared but fragment
                -- unit can't be using the same index
                setTexture rs Nothing
              _         -> do
                -- vice versa
                setVertexTexture rs Nothing
                setTexture rs $ Just tex
            False -> do
              -- Shared vertex / fragment textures or no vertex texture support
              -- Bind texture (may be blank)
              setTexture rs $ Just tex

    -- Set texture layer filtering
    setTextureUnitFiltering rs texType minFilter magFilter mipFilter

    -- Set texture layer filtering
    when (Set.member RSC_ANISOTROPY caps) $
        setTextureLayerAnisotropy rs texType maxAniso

    -- Set mipmap biasing
    when (Set.member RSC_MIPMAP_LOD_BIAS caps) $
        setTextureMipmapBias rs mipmapBias

    -- Set blend modes
    -- Check to see if blending is supported
    when (Set.member RSC_BLENDING caps) $ do
        setTextureBlendMode rs colourBlendMode alphaBlendMode
        --HINT: Obsolete below, due to stateful behaviour
        -- Note, colour before alpha is important
        --setTextureBlendMode rs colourBlendMode
        --setTextureBlendMode rs alphaBlendMode

    -- Texture addressing mode
    setTextureAddressingMode rs texType uvw
    -- Set texture border colour only if required
    when (amU uvw == TAM_BORDER || amV uvw == TAM_BORDER || amW uvw == TAM_BORDER) $
        setTextureBorderColour rs texType borderColour

    -- Set texture effects
    -- TODO
    setTextureCoordCalculation rs TEXCALC_NONE
    forM_ effects $ \e -> case teType e of
        ET_ENVIRONMENT_MAP -> setTextureCoordCalculation rs TEXCALC_ENVIRONMENT_MAP
        _                  -> return ()