loop/src/Render.hs

module Render
    ( createLightMap
    , divideSize
    , renderFoldable
    , renderLayer
    , pingPongBetween
    , bindTO
    , bindFBO
    ) where
import Shader
import Shader.ExtraPrimitive
import Shader.Data
import Data.Preload.Render
import Picture.Data
import Geometry.Data

import Foreign hiding (rotate)
import Graphics.Rendering.OpenGL hiding (Line,translate,scale,imageHeight,Polygon,Color,T)
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
import Graphics.GL.Core43
import Control.Monad

divideSize :: Int -> Size -> Size
divideSize i (Size x y) = Size (div x $ fromIntegral i) (div y $ fromIntegral i)

{- | 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
    -> Bool -- ^ whether to draw object shadows or not
    -> TextureObject -- ^ the texture object giving positions
    -> IO ()
createLightMap pdata lightPoints nWalls nSils nCaps drawObjShads toPos = do
    let llsShad = _lightingLineShadowShader pdata
    let lcShad  = _lightingCapShader        pdata
    let lwShad  = _lightingWallShadShader   pdata
    let ltShad  = _lightingTextureShader    pdata
    -- 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: 
    -- 1. stencil out the walls from this light's point of view
    -- 2. calculate lighting based on each fragment's position
    -- to consider: adding normals/a "material" for each fragment
    blendFunc $= (Zero, OneMinusSrcColor)
    stencilTest $= Enabled
    flip VS.mapM_ (VS.fromList lightPoints) $ \(V3 x y z,rad,V3 r g b) -> do
        depthFunc $= Just Less
        -- setup stencil
        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 shadows
        currentProgram $= Just (_shadProg lwShad)
        uniform (head $  _shadUnis lwShad)
            $= Vector3 x y z
        bindVertexArrayObject $= Just (_vao $ _shadVAO lwShad)
        glDrawArrays 
            (marshalEPrimitiveMode $ _shadPrim lwShad) 
            0 
            (fromIntegral nWalls)
        when drawObjShads $ do
            --draw silhouette shadows
            currentProgram $= Just (_shadProg llsShad)
            uniform (head $  _shadUnis $ _lightingLineShadowShader pdata)
                $= Vector3 x y z
            bindVertexArrayObject $= Just (_vao $ _shadVAO llsShad)
            glDrawElements
                (marshalEPrimitiveMode $ _shadPrim llsShad) 
                (fromIntegral nSils)
                GL_UNSIGNED_SHORT
                nullPtr
            cullFace $= Just Back
            --draw caps on the near plane as required
            currentProgram $= Just (_shadProg lcShad)
            uniform (head $  _shadUnis lcShad)
                $= Vector3 x y z
            bindVertexArrayObject $= Just (_vao $ _shadVAO lcShad)
            glDrawElements
                (marshalEPrimitiveMode $ _shadPrim lcShad) 
                (fromIntegral nCaps)
                GL_UNSIGNED_SHORT
                nullPtr
        --draw lightmap itself
        depthFunc $= Just Always
        -- bind world position texture
        bindTO toPos
        colorMask $= Color4 Enabled Enabled Enabled Enabled
        stencilOp $= (OpKeep,OpKeep,OpKeep)
        stencilFunc $= (Equal, 0, 255)
        currentProgram $= Just (_shadProg ltShad)
        uniform (head $  _shadUnis ltShad)
            $= Vector3 x y z
        uniform (_shadUnis ltShad !! 1)
            $= Vector4 r g b rad
        bindVertexArrayObject $= Just (_vao $ _shadVAO ltShad)
        glDrawArrays 
            (marshalEPrimitiveMode (_shadPrim ltShad))
            0 
            (fromIntegral (4::Int))
    --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 
    :: Layer 
    -> MV.MVector (PrimState IO) FullShader
    -> UMV.MVector (PrimState IO) Int
    -> IO ()
renderLayer layer shads counts = do
    let layerCounts = UMV.slice (ln * numLayers) 6 counts
    MV.imapM_ (drawShaderLay ln layerCounts) shads
  where
    ln = layerNum layer

bindTO :: TextureObject -> IO ()
bindTO t = textureBinding Texture2D $= Just t

bindFBO :: FramebufferObject -> IO ()
bindFBO fb = bindFramebuffer Framebuffer $= fb