module Shader
    ( pokeShaders
    , pokeArrayOff
    , pokeShader'
    , bindArrayBuffers'
    , bindShaderBuffers
    , drawShader
    , drawShaders
    , setShaderUniforms
    , resetShaderUniforms
    , extractProgAndUnis 
    , freeShaderPointers
    , setPerpMatUniform
    , module Shader.Data
    )
  where
import Geometry
import Shader.Data
import Shader.Parameters
import MatrixHelper
import Picture.Data

import Foreign
import Control.Monad
import qualified Control.Foldl as F
import Graphics.Rendering.OpenGL hiding (Point,translate,scale,imageHeight)
--import Text.RawString.QQ
import Linear.Matrix
import Linear.V4

extractProgAndUnis :: FullShader -> (Program,UniformLocation)
extractProgAndUnis s = (_shaderProgram s, _shaderMatrixUniform s)

pokeShaders :: [FullShader] -> F.FoldM IO RenderType [Int]
pokeShaders = traverse pokeShader'
--pokeShaders = traverse pokeShader

pokeShader' :: FullShader -> F.FoldM IO RenderType Int
pokeShader' fs = F.FoldM (pokeRender' fls ptr stride)  (return 0) return
  where 
    theVBO = _vaoVBO $ _shaderVAO fs
    ptr = _vboPointer theVBO
    stride = sum $ _vboAttribSizes theVBO
    fls = _shaderPokeStrategy fs

pokeRender' 
    :: (RenderType -> [[[Float]]])
    -> Ptr Float
    -> Int  -- ^ stride
    -> Int 
    -> RenderType 
    -> IO Int
pokeRender' toFs ptr stride n rt = pokeList' ptr stride n (toFs rt)

pokeList' :: Ptr Float -> Int -> Int -> [[[Float]]] -> IO Int
pokeList' ptr stride = foldM (pokePtrs' ptr stride)

pokePtrs' :: Ptr Float -> Int -> Int -> [[Float]] -> IO Int
pokePtrs' ptr stride n fss = do
    pokeArrayOff ptr (stride * n) (concat fss)
    return $ n + 1

pokeArrayOff :: Storable a => Ptr a -> Int -> [a] -> IO ()
pokeArrayOff ptr i = zipWithM_ (pokeElemOff ptr) [i..]

bindArrayBuffers' :: Int -> VBO -> IO ()
bindArrayBuffers' numVs theVBO = do
    bindBuffer ArrayBuffer $= Just (_vbo theVBO)
    bufferData ArrayBuffer $= 
        (fromIntegral $ floatSize * numVs * (sum $ _vboAttribSizes theVBO), _vboPointer theVBO, DynamicDraw)
    

bindShaderBuffers :: [FullShader] -> [Int] -> IO ()
bindShaderBuffers = zipWithM_ f
  where 
    f fs i = bindArrayBuffers' i $ _vaoVBO $ _shaderVAO fs

drawShaders :: [FullShader] -> [Int] -> IO ()
drawShaders = zipWithM_ drawShader

drawShader :: FullShader -> Int -> IO ()
{-# INLINE drawShader #-}
drawShader fs i = do 
    currentProgram $= Just (_shaderProgram fs)
    bindVertexArrayObject $= Just (_vao $ _shaderVAO fs)
    case _shaderTexture fs of 
        Just ShaderTexture{_textureObject = txo}
            -> textureBinding Texture2D $= Just txo
        _   -> return ()
    drawArrays (_shaderDrawPrimitive fs) 0 (fromIntegral i)



resetShaderUniforms :: [(Program, UniformLocation)] -> IO ()
{-# INLINE resetShaderUniforms #-}
resetShaderUniforms = setShaderUniforms 0 1 (0,0) (2,2)

setShaderUniforms :: Float -> Float -> Point2 -> Point2 -> [(Program,UniformLocation)] -> IO ()
{-# INLINE setShaderUniforms #-}
setShaderUniforms rot czoom (tranx,trany) (winx,winy) fss = do
    let scalMat = Linear.Matrix.transpose $
            V4 (V4 (2*czoom/winx) 0             0 (0::GLfloat))
                (V4 0             (2*czoom/winy) 0 0)
                (V4 0             0             1 0)
                (V4 0             0             0 1)
    let rotMat = Linear.Matrix.transpose $
            V4 (V4 (cos rot) (sin (-rot)) 0 0)
                (V4 (sin rot) (cos rot)    0 0)
                (V4 0             0        1 0)
                (V4 0             0        0 1)
    let tranMat = Linear.Matrix.transpose $
            V4 (V4 1        0        0 0)
                (V4 0        1        0 0)
                (V4 0        0        1 0)
                (V4 (-tranx) (-trany) 0 1)
    let wmat = scalMat !*! rotMat !*! tranMat
        vToL (V4 a b c d) = [a,b,c,d]
    wmata <- (newMatrix RowMajor $ concatMap vToL $ vToL wmat) :: IO (GLmatrix GLfloat)
-- set common uniforms
    forM_ fss $ \shad -> do
        currentProgram $= Just (fst shad)
        uniform (snd shad) $= wmata

setPerpMatUniform 
    :: Float -- ^ rotation
    -> Float -- ^ zoom
    -> Point2 -- ^ translation
    -> Point2 -- ^ window size
    -> Point2 -- ^ viewfrom point
    -> FullShader
    -> IO ()
setPerpMatUniform rot czoom trans wins vFrom shad = do
    pmat <- (newMatrix RowMajor $ perspectiveMatrix rot czoom trans wins vFrom) :: IO (GLmatrix GLfloat)
    currentProgram $= Just (_shaderProgram shad)
    uniform (_shaderMatrixUniform shad) $= pmat
    return ()

freeShaderPointers :: FullShader -> IO ()
freeShaderPointers fs = free $ _vboPointer $ _vaoVBO $ _shaderVAO fs