{-# LANGUAGE TemplateHaskell #-}
--{-# LANGUAGE Strict #-}
module Picture.Preload
    where

import Codec.Picture
import Graphics.Rendering.OpenGL hiding (Point (..),translate,scale,imageHeight,imageWidth)
import qualified Graphics.Rendering.OpenGL as GL

import qualified Data.Vector.Storable as V

import Control.Lens
import Control.Monad

import Foreign

import Shaders

data PreloadData = PreloadData
    { _charMap :: Image PixelRGBA8
--    , _textures :: [Image PixelRGBA8]
    , _basicShader :: Program
    , _textShader :: Program
    , _circShader :: Program
    , _arcShader  :: Program
    , _lineShader :: Program
    , _fadeCircleShader :: Program
    , _basicVAO :: VertexArrayObject
    , _textVAO  :: VertexArrayObject
    , _circVAO  :: VertexArrayObject
    , _arcVAO  :: VertexArrayObject
    , _posVBO :: BufferObject
    , _colVBO :: BufferObject
    , _texVBO :: BufferObject
    , _ptrPosVBO :: Ptr Float
    , _ptrColVBO :: Ptr Float
    , _ptrCharPos :: Ptr Float
    , _ptrCharCol :: Ptr Float
    , _ptrCharTex :: Ptr Float
    , _ptrCircPos :: Ptr Float
    , _ptrCircCol :: Ptr Float
    , _ptrCircSca :: Ptr Float
    , _ptrArcPos :: Ptr Float
    , _ptrArcCol :: Ptr Float
    , _ptrArcSca :: Ptr Float
    , _ptrLinePos :: Ptr Float
    , _ptrLineCol :: Ptr Float
    , _uniWinSize :: UniformLocation
    , _csZoomUni :: UniformLocation
    , _asWinUni :: UniformLocation
    , _asZoomUni :: UniformLocation
    }
data VAO = VAO
    { _vao :: VertexArrayObject
    , _vaoBufferTargets :: [(BufferObject,Ptr Float,Int)]
    }

makeLenses ''PreloadData

floatSize = sizeOf (0.5 :: GLfloat)

setupVAO :: [(BufferObject,GLuint,Int)] -> IO VertexArrayObject
setupVAO ps = do
    theVAO <- genObjectName
    bindVertexArrayObject $= Just theVAO
    forM_ ps $ \(vbo,aloc,i) -> do
        bindBuffer ArrayBuffer $= Just vbo
        vertexAttribPointer (AttribLocation aloc) $=
            ( ToFloat
            , VertexArrayDescriptor (fromIntegral i) 
                                    Float 
                                    (fromIntegral $ floatSize * i) 
                                    (bufferOffset 0)
            )
        vertexAttribArray (AttribLocation aloc) $= Enabled
    return theVAO

loadTextures :: IO [Image PixelRGBA8]
loadTextures = do
--    echarMap <- readImage "data/texture/smudgedDirt.png"
    echarMap <- readImage "data/texture/charMap.png"
    case echarMap of
        Left err -> do 
            putStrLn err
            return []
        Right charMap -> 
            return [convertRGBA8 charMap]

bufferOffset :: Integral a => a -> Ptr b
bufferOffset = plusPtr nullPtr . fromIntegral

doPreload' :: IO PreloadData
doPreload' = do
-- compile shader programs
    bs <- makeBasicShader
    ts <- makeTextureShader
    cs <- makeCircleShader
    as <- makeArcShader
    fcs <- makeFadeShader

    winSizeUni <- GL.uniformLocation cs "winSize"
    zoomUni    <- GL.uniformLocation cs "zoom"
    asWinSizeUniLoc <- GL.uniformLocation as "winSize"
    asZoomUniLoc    <- GL.uniformLocation as "zoom"
-- get uniform locations

--setup vbos
--need to be bound before assigning the vertex attribute pointers
    posVBO <- genObjectName
    colVBO <- genObjectName
    texVBO <- genObjectName

-- load charmap as texture
--    Right cmap <- readImage "data/texture/smudgedDirt.png"
    Right cmap <- readImage "data/texture/charMap.png"
    let tex = convertRGBA8 cmap
    texo <- genObjectName
    textureBinding Texture2D $= Just texo
    let texData = V.toList $ imageData tex
        wtex = fromIntegral $ imageWidth  tex
        htex = fromIntegral $ imageHeight tex
    withArray texData $ \ptr -> do
        texImage2D Texture2D NoProxy 0 RGBA8 (TextureSize2D wtex htex) 0 
                        (PixelData RGBA UnsignedByte ptr)
    generateMipmap' Texture2D
    textureFilter Texture2D $= ((Linear',Just Linear') , Nearest)

-- setup VAOs: basic vao
    basicVAO <- setupVAO [(posVBO,0,3),(colVBO,1,4)]
    textVAO <- setupVAO [(posVBO,0,3),(colVBO,1,4),(texVBO,2,2)]
    circVAO <- setupVAO [(posVBO,0,3),(colVBO,1,4),(texVBO,2,1)]
    arcVAO <- setupVAO [(posVBO,0,3),(colVBO,1,4),(texVBO,2,4)]

-- allocate memory for vertex attributes
-- for triangles
    ptrPosVBO <- mallocArray (3*3*20000)
    ptrColVBO <- mallocArray (3*4*20000)
-- for characters
    ptrCharPos <- mallocArray (3*20000)
    ptrCharCol <- mallocArray (4*20000)
    ptrCharTex <- mallocArray (2*20000)
-- for circles
    ptrCircPos <- mallocArray (3*20000)
    ptrCircCol <- mallocArray (4*20000)
    ptrCircSca <- mallocArray (2*20000)
-- for lines
    ptrLinePos <- mallocArray (3*20000)
    ptrLineCol <- mallocArray (4*20000)
-- for arcs
    ptrArcPos <- mallocArray (3*20000)
    ptrArcCol <- mallocArray (4*20000)
    ptrArcSca <- mallocArray (4*20000)

    return $ PreloadData
        { _charMap      = convertRGBA8 cmap
        , _basicShader  = bs
        , _textShader   = ts
        , _circShader = cs
        , _arcShader = as
        , _fadeCircleShader = fcs
        , _basicVAO = basicVAO
        , _textVAO  = textVAO
        , _circVAO  = circVAO
        , _arcVAO   = arcVAO
        , _posVBO = posVBO
        , _colVBO = colVBO
        , _texVBO = texVBO
        , _ptrPosVBO = ptrPosVBO
        , _ptrColVBO = ptrColVBO
        , _ptrCharPos = ptrCharPos
        , _ptrCharCol = ptrCharCol
        , _ptrCharTex = ptrCharTex
        , _ptrCircPos = ptrCircPos
        , _ptrCircCol = ptrCircCol
        , _ptrCircSca = ptrCircSca
        , _ptrArcPos = ptrArcPos
        , _ptrArcCol = ptrArcCol
        , _ptrArcSca = ptrArcSca
        , _ptrLinePos = ptrLinePos
        , _ptrLineCol = ptrLineCol
        , _uniWinSize = winSizeUni
        , _csZoomUni  = zoomUni
        , _asWinUni = asWinSizeUniLoc
        , _asZoomUni = asZoomUniLoc
        }

cleanUpPreload :: PreloadData -> IO ()
cleanUpPreload pd = do
    free (_ptrPosVBO pd)
    free (_ptrColVBO pd)
    free (_ptrCharPos pd)
    free (_ptrCharCol pd)
    free (_ptrCharTex pd)
    free (_ptrCircPos pd)
    free (_ptrCircCol pd)
    free (_ptrCircSca pd)
    free (_ptrArcPos pd)
    free (_ptrArcCol pd)
    free (_ptrArcSca pd)