loop/src/Render.hs

{-# LANGUAGE TupleSections #-}
module Render
    where
import Shader
import Shader.Data
import Shader.Poke
--import MatrixHelper
import Data.Preload.Render
import Picture.Data
--import Picture.Tree
--import Geometry
import Geometry.Data
--import Polyhedra.Data
--import Polyhedra
import Layers

--import Control.Lens
import Control.Monad
--import qualified Control.Foldl as F
import Foreign hiding (rotate)
import Graphics.Rendering.OpenGL hiding (Line,translate,scale,imageHeight,Polygon,Color,T)
--import Data.Foldable
--import Data.Tuple.Extra
--import qualified Data.IntMap.Strict as IM
import qualified SDL

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
    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
        --depthFunc $= Just Lequal
        -- 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
    --blend $= 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

pokeBindFoldable
    -- :: Foldable f
    :: RenderData
    -> [Verx]
    -> IO (PicShads Int)
pokeBindFoldable pdata m = do
    let shads = _pictureShaders pdata
        --counts = zeroCounts
    --elist <- foldM (pokeVX' shads) counts m
    elist <- pokeVerxs (fmap (_vaoVBO . _vshaderVAO) shads) m
    bindShader shads elist
    return elist

zeroCounts :: PicShads Int
zeroCounts = PicShads 0 0 0 0 0 0

pokeVerxLayers
    :: PicShads VBO
    -> [Verx]
    -> Layers (PicShads Int)
    -> IO (Layers (PicShads Int))
pokeVerxLayers = undefined

pokeBindFoldableLayer
    :: RenderData
    -> Picture
    -> IO (Layers (PicShads Int))
pokeBindFoldableLayer pdata m = do
    let shads = _pictureShaders pdata

    slist'' <- pokeLayVerxsFold (fmap (_vaoVBO . _vshaderVAO) shads) m
    bindShaderLay shads slist''

    return slist''

renderFoldable
    :: RenderData
    -> [Verx]
    -> IO Word32
renderFoldable pdata struct = do
    pokeStartTicks <- SDL.ticks

    count <- pokeBindFoldable pdata struct
    let shads = _pictureShaders pdata

    mapM_ (uncurry (drawShaderLay 0)) ((,) <$> shads <*> count)
    
    pokeEndTicks <- SDL.ticks
    return $ pokeEndTicks - pokeStartTicks
------------------------------end renderFoldable

renderLayer :: Int -> PicShads VShader -> Layers (PicShads Int) -> IO ()
renderLayer i shads counts = sequence_ $ drawShaderLay i <$> shads <*> getLay i counts

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