135 lines
4.8 KiB
Haskell
135 lines
4.8 KiB
Haskell
module Render
|
|
( createLightMap
|
|
, divideSize
|
|
, renderFoldable
|
|
, renderLayer
|
|
, pingPongBetween
|
|
, bindTO
|
|
, bindFBO
|
|
)
|
|
where
|
|
import Shader
|
|
import Shader.Data
|
|
--import Shader.Poke
|
|
import Data.Preload.Render
|
|
import Picture.Data
|
|
import Geometry.Data
|
|
|
|
--import Data.Foldable
|
|
--import Foreign hiding (rotate)
|
|
import Graphics.Rendering.OpenGL hiding (Line,translate,scale,imageHeight,Polygon,Color,T)
|
|
--import qualified SDL
|
|
import qualified Data.Vector.Unboxed.Mutable as UMV
|
|
import qualified Data.Vector.Mutable as MV
|
|
import Control.Monad.Primitive
|
|
import qualified Data.Vector.Fusion.Stream.Monadic as VS
|
|
|
|
divideSize :: Int -> Size -> Size
|
|
divideSize i (Size x y) = Size (div x $ fromIntegral i) (div y $ fromIntegral i)
|
|
|
|
--sizeToTexSize :: Size -> TextureSize2D
|
|
--sizeToTexSize (Size x y) = TextureSize2D x y
|
|
|
|
{- | Determine where light is shining in the world. -}
|
|
createLightMap
|
|
:: RenderData
|
|
-> [(Point3,Float,Point3)] -- Lights
|
|
-> Int -- ^ number of walls
|
|
-> Int -- ^ number of silhoutte lines to draw
|
|
-> Int -- ^ number of "caps" to attempt to draw
|
|
-> TextureObject -- ^ the texture object giving positions
|
|
-> IO ()
|
|
createLightMap pdata lightPoints nWalls nSils nCaps toPos = do
|
|
-- we assume that the renderbuffer's depth has been correctly set elsewhere
|
|
-- we will not be changing that here
|
|
depthMask $= Disabled
|
|
-- clearColor is specified differently in preloadRender
|
|
clearColor $= Color4 1 1 1 1
|
|
clear [ColorBuffer]
|
|
-- for each of the lights:
|
|
-- stencil out the walls from this light's point of view
|
|
-- draw fading lightmap circles on the floor
|
|
-- draw fading lightmaps on the walls
|
|
blendFunc $= (Zero, OneMinusSrcColor)
|
|
stencilTest $= Enabled
|
|
flip VS.mapM_ (VS.fromList lightPoints) $ \(V3 x y z,rad,V3 r g b) -> do
|
|
depthFunc $= Just Less
|
|
-- stencil out shadows
|
|
colorMask $= Color4 Disabled Disabled Disabled Disabled
|
|
clear [StencilBuffer]
|
|
cullFace $= Nothing
|
|
stencilOpSeparate Front $= (OpKeep,OpKeep,OpIncrWrap)
|
|
stencilOpSeparate Back $= (OpKeep,OpKeep,OpDecrWrap)
|
|
stencilFunc $= (Always, 0, 255)
|
|
--draw wall whadows
|
|
currentProgram $= Just (_shaderProgram $ _lightingOccludeShader pdata)
|
|
uniform (head $ _shaderCustomUnis $ _lightingOccludeShader pdata)
|
|
$= Vector3 x y z
|
|
drawShader (_lightingOccludeShader pdata) nWalls
|
|
--draw silhouette shadows
|
|
currentProgram $= Just (_shaderProgram $ _lightingLineShadowShader pdata)
|
|
uniform (head $ _shaderCustomUnis $ _lightingLineShadowShader pdata)
|
|
$= Vector3 x y z
|
|
drawShader (_lightingLineShadowShader pdata) nSils
|
|
cullFace $= Just Back
|
|
--draw caps on the near plane as required
|
|
currentProgram $= Just (_shaderProgram $ _lightingCapShader pdata)
|
|
uniform (head $ _shaderCustomUnis $ _lightingCapShader pdata)
|
|
$= Vector3 x y z
|
|
drawShader (_lightingCapShader pdata) nCaps
|
|
--draw lightmap itself
|
|
depthFunc $= Just Always
|
|
cullFace $= Nothing
|
|
bindTO toPos
|
|
colorMask $= Color4 Enabled Enabled Enabled Enabled
|
|
stencilOp $= (OpKeep,OpKeep,OpKeep)
|
|
stencilFunc $= (Equal, 0, 255)
|
|
currentProgram $= Just (_shaderProgram $ _fullLightingShader pdata)
|
|
uniform (head $ _shaderCustomUnis $ _fullLightingShader pdata)
|
|
$= Vector3 x y z
|
|
uniform (_shaderCustomUnis (_fullLightingShader pdata) !! 1)
|
|
$= Vector4 r g b rad
|
|
drawShader (_fullLightingShader pdata) 4
|
|
--cleanup: may not be necessary, depending on what comes after...
|
|
cullFace $= Nothing
|
|
stencilTest $= Disabled
|
|
-- assumes that vertices have already been sent to the shader
|
|
pingPongBetween
|
|
:: (FramebufferObject,TextureObject)
|
|
-> (FramebufferObject,TextureObject)
|
|
-> FullShader
|
|
-> IO ()
|
|
pingPongBetween (fb1,to1) (fb2,to2) fs = do
|
|
bindFramebuffer Framebuffer $= fb2
|
|
textureBinding Texture2D $= Just to1
|
|
drawShader fs 4
|
|
bindFramebuffer Framebuffer $= fb1
|
|
textureBinding Texture2D $= Just to2
|
|
drawShader fs 4
|
|
|
|
renderFoldable
|
|
:: MV.MVector (PrimState IO) FullShader
|
|
-> Picture
|
|
-> IO ()
|
|
renderFoldable shadV struct = do
|
|
counts <- UMV.replicate 6 0
|
|
pokeBindFoldable shadV counts struct
|
|
MV.imapM_ (drawShaderLay 0 counts) shadV
|
|
|
|
------------------------------end renderFoldable
|
|
renderLayer
|
|
:: Int
|
|
-> MV.MVector (PrimState IO) FullShader
|
|
-> UMV.MVector (PrimState IO) Int
|
|
-> IO ()
|
|
renderLayer layer shads counts = do
|
|
let layerCounts = UMV.slice (layer * 6) 6 counts
|
|
MV.imapM_ (drawShaderLay layer layerCounts) shads
|
|
|
|
bindTO :: TextureObject -> IO ()
|
|
bindTO t = textureBinding Texture2D $= Just t
|
|
|
|
bindFBO :: FramebufferObject -> IO ()
|
|
bindFBO fb = bindFramebuffer Framebuffer $= fb
|
|
|