{-# 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 ()