--{-# LANGUAGE Strict #-}
{-# LANGUAGE DeriveFoldable, StandaloneDeriving #-}
module Picture.Render
    ( renderPicture'
    , renderFoldable
    , picToLTree
    )
    where

import Shader

import Control.Lens
import Control.Monad

import qualified Control.Foldl as F

import Picture.Preload
import Picture.Data
import Picture.Tree
import Geometry

import Foreign hiding (rotate)

import Graphics.Rendering.OpenGL hiding (Line,translate,scale,imageHeight,imageWidth,Polygon,Color,T)

import Data.Foldable
import Data.Maybe (fromJust)

import qualified Data.IntMap.Strict as IM

import qualified SDL as SDL

renderPicture' :: RenderData -> Float -> Float -> (Float,Float) -> (Float,Float) ->
                    [(Point2,Point2,Point2,Point2)] -> [Point4] -> Picture -> IO (Word32,Word32)
renderPicture' pdata rot zoom (tranx,trany) (winx,winy) wallPoints lightPoints pic = do
    wallPokeStart <- SDL.ticks

-- setting the depth function to less, instead of lequal, 
-- seems to stop a lot of unecessary drawing
-- of wall shadows when creating the light map
    depthFunc $= Just Less

-- set common uniforms
    setShaderUniforms rot zoom (tranx,trany) (winx,winy) 
        ( (extractProgAndUnis $ _lightSourceShader pdata) 
        : (extractProgAndUnis $ _wallShadowShader pdata) 
        : (extractProgAndUnis $ _wallShader pdata) 
        : (extractProgAndUnis $ _backgroundShader pdata) 
        : (map extractProgAndUnis $ _listShaders pdata)
        )

-- draw lightmap

    bindFramebuffer Framebuffer $= (_spareFBO pdata)
    depthFunc $= Just Less
    clearColor $= Color4 0 0.5 0 1
    clearDepth $= (200)
    clear [ColorBuffer]
--    depthMask $= Enabled

    nWalls <- F.foldM (pokeShader (_wallShadowShader pdata)) wallPoints
    bindShaderBuffers [_wallShadowShader pdata] [nWalls]

    forM_ lightPoints $ \(x,y,r,lum) -> do
        cullFace $= Just Front
        clear [DepthBuffer]

-- currentProgram does get called twice: here and inside drawShader below
        currentProgram $= Just (_shaderProgram $ _wallShadowShader pdata)
        uniform (head $ fromJust $ _shaderCustomUnis $ _wallShadowShader pdata)
            $= Vector2 (x) (y)
        blendFunc $= (Zero,One)
        drawShader (_wallShadowShader pdata) nWalls

        cullFace $= Nothing
        
        let lightPtr = (\(_,ptr,_) -> ptr) $ head 
                            $ _vaoBufferTargets $ _shaderVAO $ _lightSourceShader pdata
        pokeFourOff lightPtr 0 (x,y,r,lum)
        bindShaderBuffers [_lightSourceShader pdata] [1]
        
        blendFuncSeparate    $= ((Zero,Zero),(Zero, OneMinusSrcAlpha))
        drawShader (_lightSourceShader pdata) 1

    startWallTicks <- SDL.ticks
    wallPokeEnd <- SDL.ticks
    ticksS <- SDL.ticks
    ticksAfterL <- SDL.ticks

    blend $= Disabled

--    blendFunc $= (Zero,One)
    bindFramebuffer Framebuffer $= defaultFramebufferObject
--
--    blendFunc $= (SrcAlpha, OneMinusSrcAlpha)
    bindShaderBuffers [_fullscreenShader pdata] [4]
    textureBinding Texture2D $= Just (_fboTexture pdata)
--    blendFunc $= (One, Zero)
    drawShader (_fullscreenShader pdata) 4

    blend $= Enabled

-- draw picture on top of light/shadow map
-- set drawing for on top
    blendFuncSeparate    $= ((SrcAlphaSaturate, OneMinusSrcAlpha), (Zero,One))
    clear [DepthBuffer]

-- draw background
    bindArrayBuffers 1 $ _vaoBufferTargets $ _shaderVAO $ _backgroundShader pdata
    depthFunc $= Just Less

    currentProgram $= Just (_shaderProgram $ _backgroundShader pdata)
    bindVertexArrayObject $= Just (_vao $ _shaderVAO $ _backgroundShader pdata)
    let backPtr = (\(_,x,_) -> x) $ head $ _vaoBufferTargets $ _shaderVAO $ _backgroundShader pdata
        backPtr2 = (\(_,x,_) -> x) $ (_vaoBufferTargets $ _shaderVAO $ _backgroundShader pdata) !! 1
    pokeFourOff backPtr 0 (tranx,trany,rot,zoom)
    pokeTwoOff backPtr2 0  (winx,winy)
    textureBinding Texture2D $= (fmap _textureObject $ _shaderTexture $ _backgroundShader pdata)
    drawArrays Points (fromIntegral 0) (fromIntegral 1)

    depthFunc $= Just Lequal

-- draw layer 0
    ticks2 <- renderFoldable pdata rot zoom (tranx,trany) (winx,winy) $ picToLTree (Just 0) pic
                                                        --((picToAlt 0 pic) :: [RenderType])
-- reset blend so that light map doesn't apply
    blendFunc $= (SrcAlpha,OneMinusSrcAlpha)
    ticks3 <- renderFoldable pdata rot zoom (tranx,trany) (winx,winy) $ picToLTree (Just 1) pic
-- set drawing for on top
    aticks <- SDL.ticks
    blendFuncSeparate    $= ((SrcAlphaSaturate, OneMinusSrcAlpha), (Zero,One))
    ticks4 <- renderFoldable pdata rot zoom (tranx,trany) (winx,winy) $ picToLTree (Just 2) pic
    bticks <- SDL.ticks

-- render walls
    blendFunc $= (SrcAlpha,OneMinusSrcAlpha)
    -- poke data
    let lights = map (\(x,y,r,g) -> ((x,y),(r,g,0,0))) lightPoints
        wallPairs = map (\(a,b,_,_) -> [(a,(1,1,1,1)),(b,(1,1,1,1))]) wallPoints
        f (x,y) = [(x,y,0),(x,y,0),(x,y,-1)]
        g (x,y) = [(x,y,0),(x,y,-1),(x,y,-1)]
        wp = concatMap (\(a,b,_,_) -> f a ++ g b) wallPoints
        h p = (p,(1,0,0,1))
    i <- F.foldM (pokeShader (_wallShader pdata)) $ map h wp

    -- bind buffers
    bindShaderBuffers [_wallShader pdata] [i]

    -- draw call
    drawShaders [_wallShader pdata] [i]

    resetShaderUniforms (map extractProgAndUnis $ _listShaders pdata)

    endWallTicks <- SDL.ticks
    --return (ticksAfterL, ticks2+ticks3+ticks4, endWallTicks - startWallTicks)
    ticksE <- SDL.ticks
    --return (ticksAfterL, ticksE - ticksS)
    --return (ticksAfterL, ticks2 + ticks3 + ticks4)
    return (ticksAfterL, wallPokeEnd - wallPokeStart)

----------------end renderPicture'

renderFoldable :: Foldable f => RenderData -> Float -> Float -> (Float,Float) -> (Float,Float)
                    -> f RenderType -> IO Word32
renderFoldable pdata rot zoom (tranx,trany) (winx,winy) tree = do
    pokeStartTicks <- SDL.ticks

    let slist = _listShaders pdata

-- poke data, returns list of number of vertices for each shader
    is <- F.foldM (pokeShaders slist) tree

-- the idea of doing as binding of buffers at once, rather than interweaving with draw
-- calls, is to prevent opengl from waiting for a draw call to finish
-- before it performs another state change
    bindShaderBuffers slist is

    drawShaders slist is
    
    pokeEndTicks <- SDL.ticks
    return $ pokeEndTicks - pokeStartTicks

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