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
| TEXCALC_ENVIRONMENT_MAP
| TEXCALC_ENVIRONMENT_MAP_PLANAR
| TEXCALC_ENVIRONMENT_MAP_REFLECTION
| TEXCALC_ENVIRONMENT_MAP_NORMAL
| TEXCALC_PROJECTIVE_TEXTURE
deriving Eq
data StencilOperation
= SOP_KEEP
| SOP_ZERO
| SOP_REPLACE
| SOP_INCREMENT
| SOP_DECREMENT
| SOP_INCREMENT_WRAP
| SOP_DECREMENT_WRAP
| SOP_INVERT
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 ()
createGpuProgram :: rs -> GpuProgramType -> String -> IO (Either p String)
createLinkedGpuProgram :: rs -> [p] -> IO (Either lp String)
getName :: rs -> String
createOcclusionQuery :: rs -> IO q
setAmbientLight :: rs -> Float -> Float -> Float -> IO ()
setShadingType :: rs -> ShadeOptions -> IO ()
setLightingEnabled :: rs -> Bool -> IO ()
setWBufferEnabled :: rs -> Bool -> IO ()
setWaitForVerticalBlank :: rs -> Bool -> IO ()
useLights :: rs -> [(Proj4,Light)] -> IO ()
setWorldMatrix :: rs -> Proj4 -> IO ()
setViewMatrix :: rs -> Proj4 -> IO ()
setProjectionMatrix :: rs -> Mat4 -> IO ()
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 -> 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
{
psAmbient = ambient
, psDiffuse = diffuse
, psSpecular = specular
, psEmissive = emissive
, psShininess = shininess
, psTracking = vertexColourTracking
, psSourceBlendFactor = sourceBlendFactor
, psDestBlendFactor = destBlendFactor
, psSourceBlendFactorAlpha = sourceBlendFactorAlpha
, psDestBlendFactorAlpha = destBlendFactorAlpha
, psSeparateBlend = separateBlend
, psBlendOperation = blendOperation
, psAlphaBlendOperation = alphaBlendOperation
, psSeparateBlendOperation = separateBlendOperation
, psDepthCheck = depthCheck
, psDepthWrite = depthWrite
, psDepthFunc = depthFunc
, psDepthBiasConstant = depthBiasConstant
, psDepthBiasSlopeScale = depthBiasSlopeScale
, psColourWrite = colourWrite
, psAlphaRejectFunc = alphaRejectFunc
, psAlphaRejectVal = alphaRejectVal
, psAlphaToCoverageEnabled = alphaToCoverageEnabled
, psCullMode = cullMode
, psLightingEnabled = lightingEnabled
, psShadeOptions = shadeOptions
, psPolygonMode = polygonMode
, psPolygonModeOverrideable = polygonModeOverrideable
, psFogMode = fogMode
, psFogColour = fogColour
, psFogStart = fogStart
, psFogEnd = fogEnd
, psFogDensity = fogDensity
, psTextureUnitStates = textureUnitStates
, psLinkedGpuProgram = linkedGpuProgram
, psPointSize = pointSize
, psPointMinSize = pointMinSize
, psPointMaxSize = pointMaxSize
, psPointSpritesEnabled = pointSpritesEnabled
, psPointAttenuationEnabled = pointAttenuationEnabled
} = pass
let passSurfaceAndLightParams = True
passFogParams = True
case linkedGpuProgram of
Nothing -> unbindLinkedGpuProgram rs
Just lp -> bindLinkedGpuProgram rs lp
when passSurfaceAndLightParams $ do
when lightingEnabled $
setSurfaceParams rs ambient diffuse specular emissive shininess vertexColourTracking
setLightingEnabled rs lightingEnabled
when passFogParams $ do
setFog rs fogMode fogColour fogDensity fogStart fogEnd
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
let (pac,pal,paq) = psPointAttenuationCoeffs pass
setPointParameters rs pointSize pointAttenuationEnabled pac pal paq pointMinSize pointMaxSize
when (Set.member RSC_POINT_SPRITES caps) $
setPointSpritesEnabled rs pointSpritesEnabled
sequence_ [setTextureUnitSettings time rs i tus | i <- [0..] | tus <- textureUnitStates]
forM_ [length textureUnitStates..rscNumTextureUnits (getCapabilities rs) 1] $ \tu -> do
setActiveTextureUnit rs tu
setTexture rs Nothing
setDepthBufferFunction rs depthFunc
setDepthBufferCheckEnabled rs depthCheck
setDepthBufferWriteEnabled rs depthWrite
setDepthBias rs depthBiasConstant depthBiasSlopeScale
setAlphaRejectSettings rs alphaRejectFunc alphaRejectVal alphaToCoverageEnabled
setColourBufferWriteEnabled rs colourWrite colourWrite colourWrite colourWrite
setCullingMode rs cullMode
setShadingType rs shadeOptions
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
, tusTextureType = texType
, tusAddressMode = uvw
, tusBorderColour = borderColour
, tusColourBlendMode = colourBlendMode
, tusAlphaBlendMode = alphaBlendMode
, tusMinFilter = minFilter
, tusMagFilter = magFilter
, tusMipFilter = mipFilter
, tusMaxAniso = maxAniso
, tusMipmapBias = mipmapBias
, tusBindingType = bindingType
, tusFrames = frames
, tusEffects = effects
} = tl
texl = fromMaybe (error "fromJust 12") frames
setActiveTextureUnit rs texUnit
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
setVertexTexture rs $ Just tex
setTexture rs Nothing
_ -> do
setVertexTexture rs Nothing
setTexture rs $ Just tex
False -> do
setTexture rs $ Just tex
setTextureUnitFiltering rs texType minFilter magFilter mipFilter
when (Set.member RSC_ANISOTROPY caps) $
setTextureLayerAnisotropy rs texType maxAniso
when (Set.member RSC_MIPMAP_LOD_BIAS caps) $
setTextureMipmapBias rs mipmapBias
when (Set.member RSC_BLENDING caps) $ do
setTextureBlendMode rs colourBlendMode alphaBlendMode
setTextureAddressingMode rs texType uvw
when (amU uvw == TAM_BORDER || amV uvw == TAM_BORDER || amW uvw == TAM_BORDER) $
setTextureBorderColour rs texType borderColour
setTextureCoordCalculation rs TEXCALC_NONE
forM_ effects $ \e -> case teType e of
ET_ENVIRONMENT_MAP -> setTextureCoordCalculation rs TEXCALC_ENVIRONMENT_MAP
_ -> return ()