loop/src/Render.hs

module Render
    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,Float)]             -- Lights
    -> Int -- ^ number of walls
    -> Int -- ^ number of silhoutte lines to draw
    -> Int -- ^ number of surface triangles to draw
    -> IO ()
createLightMap pdata lightPoints nWalls nSils nsurfVs = do
    depthFunc $= Just Less
    -- clear buffer to full alpha and furthest depth
    -- clearColor is specified in preloadRender
    clearColor $= Color4 0 0 0 1
    clear [ColorBuffer,DepthBuffer]
    --colorMask $= Color4 Disabled Disabled Disabled Disabled
    cullFace $= Just Back
    -- draw walls from your point of view in order to set z buffer
    drawShader (_lightingWallShader pdata) nWalls
    -- draw foreground elements to set z buffer
    drawShader (_lightingSurfaceShader pdata) nsurfVs 
    -- 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
    depthMask $= Disabled
    blendFunc $= (Zero, OneMinusSrcAlpha)
    stencilTest $= Enabled
    depthFunc $= Just Lequal
    --flip VS.mapM_ (VS.fromList lightPoints) $ \(V3 x y z,r,lum) -> do
    forM_ lightPoints $ \(V3 x y z,r,lum) -> do
        -- stencil out shadows
        colorMask $= Color4 Disabled Disabled Disabled Disabled
        clear [StencilBuffer]
        cullFace $= Just Back
        stencilOp $= (OpKeep,OpKeep,OpIncr)
        stencilFunc $= (Always, 0, 255)
        currentProgram $= Just (_shaderProgram $ _lightingOccludeShader pdata)
        uniform (head $  _shaderCustomUnis $ _lightingOccludeShader pdata)
            $= Vector3 x y z
        drawShader (_lightingOccludeShader pdata) nWalls
        currentProgram $= Just (_shaderProgram $ _lightingLineShadowShader pdata)
        uniform (head $  _shaderCustomUnis $ _lightingLineShadowShader pdata)
            $= Vector3 x y z
        drawShader (_lightingLineShadowShader pdata) nSils

        cullFace $= Just Front
        stencilOp $= (OpKeep,OpKeep,OpDecr)
        currentProgram $= Just (_shaderProgram $ _lightingOccludeShader pdata)
        drawShader (_lightingOccludeShader pdata) nWalls

        currentProgram $= Just (_shaderProgram $ _lightingLineShadowShader pdata)
        drawShader (_lightingLineShadowShader pdata) nSils
        -- draw geometry surfaces
        cullFace $= Just Back
        colorMask $= Color4 Disabled Disabled Disabled Enabled
        stencilFunc $= (Equal, 0, 255)
        currentProgram $= Just (_shaderProgram $ _lightingSurfaceShader pdata)
        uniform (head $  _shaderCustomUnis $ _lightingSurfaceShader pdata)
            $= Vector3 x y z
        uniform (_shaderCustomUnis (_lightingSurfaceShader pdata) !! 1)
            $= Vector2 r lum
        drawShader (_lightingSurfaceShader pdata) nsurfVs 
        -- draw wall light "circles"
        currentProgram $= Just (_shaderProgram $ _lightingWallShader pdata)
        uniform (head $ _shaderCustomUnis $ _lightingWallShader pdata)
            $= Vector3 x y z
        uniform (_shaderCustomUnis (_lightingWallShader pdata) !! 1)
            $= Vector2 r lum
        drawShader (_lightingWallShader pdata) nWalls
    cullFace $= Nothing
    stencilTest $= Disabled
{- | Blur between two framebuffers.
Assumes no depth testing is done -}
pingPongBlur :: RenderData -> IO ()
pingPongBlur pdata = do
    bindFramebuffer Framebuffer $= fst (_fbo3 pdata)
    textureBinding Texture2D $= Just (snd $ _fbo2 pdata)
    drawShader (_bloomBlurShader pdata) 4

    bindFramebuffer Framebuffer $= fst (_fbo2 pdata)
    textureBinding Texture2D $= Just (snd $ _fbo3 pdata)
    drawShader (_bloomBlurShader pdata) 4
-- 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

drawTextureOnFramebuffer
    :: FullShader
    -> FramebufferObject
    -> TextureObject
    -> IO ()
drawTextureOnFramebuffer fs fbo to = do
    bindFramebuffer Framebuffer $= fbo
    textureBinding Texture2D $= Just to
    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

renderFoldableTimed
    :: MV.MVector (PrimState IO) FullShader
    -> Picture
    -> IO Word32
renderFoldableTimed shadV struct = do
    pokeStartTicks <- SDL.ticks
    counts <- UMV.replicate 6 0
    pokeBindFoldable shadV counts struct
    MV.imapM_ (drawShaderLay 0 counts) shadV
    pokeEndTicks <- SDL.ticks
    return $ pokeEndTicks - pokeStartTicks
------------------------------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

pokeTwoOff 
    :: Ptr Float 
    -> Int 
    -> (Float,Float) 
    -> IO ()
{-# INLINE pokeTwoOff #-}
pokeTwoOff ptr n (x,y) = do
    pokeElemOff ptr (2*n+0) x
    pokeElemOff ptr (2*n+1) y
pokeThreeOff 
    :: Ptr Float 
    -> Int 
    -> (Float,Float,Float) 
    -> IO ()
{-# INLINE pokeThreeOff #-}
pokeThreeOff ptr n (x,y,z) = do
    pokeElemOff ptr (3*n+0) x
    pokeElemOff ptr (3*n+1) y
    pokeElemOff ptr (3*n+2) z
pokeFourOff :: Ptr Float -> Int -> (Float,Float,Float,Float) -> IO ()
{-# INLINE pokeFourOff #-}
pokeFourOff ptr n (x,y,z,w) = do
    pokeElemOff ptr (4*n+0) x
    pokeElemOff ptr (4*n+1) y
    pokeElemOff ptr (4*n+2) z
    pokeElemOff ptr (4*n+3) w