{-# LANGUAGE LambdaCase #-}
module LambdaCube.GL.Data where

import Control.Applicative
import Control.Monad
import Data.IORef
import Data.List as L
import Data.Maybe
import Foreign 
--import qualified Data.IntMap as IM
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.Vector as V
import qualified Data.Vector.Storable as SV

--import Control.DeepSeq

import Graphics.GL.Core33
import Graphics.GL.EXT.TextureFilterAnisotropic
import Data.Word
import Codec.Picture
import Codec.Picture.Types

import LambdaCube.GL.Type
import LambdaCube.GL.Util

-- Buffer
disposeBuffer :: Buffer -> IO ()
disposeBuffer (Buffer _ bo) = withArray [bo] $ glDeleteBuffers 1

compileBuffer :: [Array] -> IO Buffer
compileBuffer arrs = do
    let calcDesc (offset,setters,descs) (Array arrType cnt setter) =
          let size = cnt * sizeOfArrayType arrType
          in (size + offset, (offset,size,setter):setters, ArrayDesc arrType cnt offset size:descs)
        (bufSize,arrSetters,arrDescs) = foldl' calcDesc (0,[],[]) arrs
    bo <- alloca $! \pbo -> glGenBuffers 1 pbo >> peek pbo
    glBindBuffer GL_ARRAY_BUFFER bo
    glBufferData GL_ARRAY_BUFFER (fromIntegral bufSize) nullPtr GL_STATIC_DRAW
    forM_ arrSetters $! \(offset,size,setter) -> setter $! glBufferSubData GL_ARRAY_BUFFER (fromIntegral offset) (fromIntegral size)
    glBindBuffer GL_ARRAY_BUFFER 0
    return $! Buffer (V.fromList $! reverse arrDescs) bo

updateBuffer :: Buffer -> [(Int,Array)] -> IO ()
updateBuffer (Buffer arrDescs bo) arrs = do
    glBindBuffer GL_ARRAY_BUFFER bo
    forM arrs $ \(i,Array arrType cnt setter) -> do
        let ArrayDesc ty len offset size = arrDescs V.! i
        when (ty == arrType && cnt == len) $
            setter $! glBufferSubData GL_ARRAY_BUFFER (fromIntegral offset) (fromIntegral size)
    glBindBuffer GL_ARRAY_BUFFER 0

bufferSize :: Buffer -> Int
bufferSize = V.length . bufArrays

arraySize :: Buffer -> Int -> Int
arraySize buf arrIdx = arrLength $! bufArrays buf V.! arrIdx

arrayType :: Buffer -> Int -> ArrayType
arrayType buf arrIdx = arrType $! bufArrays buf V.! arrIdx

-- Texture
disposeTexture :: TextureData -> IO ()
disposeTexture (Texture2DName to) = withArray [to] $ glDeleteTextures 1

disposeTextureCube :: TextureCubeData -> IO ()
disposeTextureCube (TextureCubeName to) = withArray [to] $ glDeleteTextures 1

-- FIXME: Temporary implemenation
uploadTexture2DToGPU :: DynamicImage -> IO TextureData
uploadTexture2DToGPU = uploadTexture2DToGPU' True False True False

uploadTexture2DToGPU' :: Bool -> Bool -> Bool -> Bool -> DynamicImage -> IO TextureData
uploadTexture2DToGPU' isFiltered isSRGB isMip isClamped bitmap' = do
    let bitmap = case bitmap' of
          ImageRGB8 i@(Image w h _)   -> bitmap'
          ImageRGBA8 i@(Image w h _)  -> bitmap'
          ImageYCbCr8 i@(Image w h _) -> ImageRGB8 $ convertImage i
          di -> ImageRGBA8 $ convertRGBA8 di

    glPixelStorei GL_UNPACK_ALIGNMENT 1
    to <- alloca $! \pto -> glGenTextures 1 pto >> peek pto
    glBindTexture GL_TEXTURE_2D to
    let (width,height) = bitmapSize bitmap
        bitmapSize (ImageRGB8 (Image w h _)) = (w,h)
        bitmapSize (ImageRGBA8 (Image w h _)) = (w,h)
        bitmapSize _ = error "unsupported image type :("
        withBitmap (ImageRGB8 (Image w h v)) f = SV.unsafeWith v $ f (w,h) 3 0
        withBitmap (ImageRGBA8 (Image w h v)) f = SV.unsafeWith v $ f (w,h) 4 0
        withBitmap _ _ = error "unsupported image type :("
        texFilter = if isFiltered then GL_LINEAR else GL_NEAREST
        wrapMode = case isClamped of
            True    -> GL_CLAMP_TO_EDGE
            False   -> GL_REPEAT
        (minFilter,maxLevel) = case isFiltered && isMip of
            False   -> (texFilter,0)
            True    -> (GL_LINEAR_MIPMAP_LINEAR, floor $ log (fromIntegral $ max width height) / log 2)
    glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_S $ fromIntegral wrapMode
    glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_T $ fromIntegral wrapMode
    glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER $ fromIntegral minFilter
    glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER $ fromIntegral texFilter
    glTexParameteri GL_TEXTURE_2D GL_TEXTURE_BASE_LEVEL 0
    glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MAX_LEVEL $ fromIntegral maxLevel
    withBitmap bitmap $ \(w,h) nchn 0 ptr -> do
        let internalFormat  = fromIntegral $ if isSRGB then (if nchn == 3 then GL_SRGB8 else GL_SRGB8_ALPHA8) else (if nchn == 3 then GL_RGB8 else GL_RGBA8)
            dataFormat      = fromIntegral $ case nchn of
                3   -> GL_RGB
                4   -> GL_RGBA
                _   -> error "unsupported texture format!"
        glTexImage2D GL_TEXTURE_2D 0 internalFormat (fromIntegral w) (fromIntegral h) 0 dataFormat GL_UNSIGNED_BYTE $ castPtr ptr
    when isMip $ glGenerateMipmap GL_TEXTURE_2D
    return $ Texture2DName to


compatibleImage :: DynamicImage -> DynamicImage
compatibleImage bitmap' = case bitmap' of
          ImageRGB8 i@(Image w h _)   -> bitmap'
          ImageRGBA8 i@(Image w h _)  -> bitmap'
          ImageYCbCr8 i@(Image w h _) -> ImageRGB8 $ convertImage i
          di -> ImageRGBA8 $ convertRGBA8 di

imageFormat :: Bool {- ^ is SRGB -} -> Int {- number of channels -} -> (GLenum,GLint) {- ^ dataFormat,internalFormat -}
imageFormat isSRGB 3 = (GL_RGB , fromIntegral $ if isSRGB then GL_SRGB8        else GL_RGB8)
imageFormat isSRGB 4 = (GL_RGBA, fromIntegral $ if isSRGB then GL_SRGB8_ALPHA8 else GL_RGBA8)
imageFormat isSRGB _ = error "unsupported texture format!"

uploadCubeMapToGPU :: [DynamicImage] -> IO TextureCubeData
uploadCubeMapToGPU = uploadCubeMapToGPU' True False True True


uploadCubeMapToGPU' :: Bool -> Bool -> Bool -> Bool -> [DynamicImage] -> IO TextureCubeData
uploadCubeMapToGPU' isFiltered isSRGB isMip isClamped (bitmap':bitmaps') = do
    -- The six faces of the cube are represented by six subtextures that must be square and of the same size.

    let (bitmap,side):bitmaps =
            zip (map compatibleImage (bitmap':bitmaps'))
                [GL_TEXTURE_CUBE_MAP_POSITIVE_X .. GL_TEXTURE_CUBE_MAP_NEGATIVE_Z]

    glPixelStorei GL_UNPACK_ALIGNMENT 1
    to <- alloca $! \pto -> glGenTextures 1 pto >> peek pto
    glBindTexture GL_TEXTURE_CUBE_MAP to
    let (width,height) = bitmapSize bitmap
        bitmapSize (ImageRGB8 (Image w h _)) = (w,h)
        bitmapSize (ImageRGBA8 (Image w h _)) = (w,h)
        bitmapSize _ = error "unsupported image type :("
        withBitmap (ImageRGB8 (Image w h v)) f = SV.unsafeWith v $ f (w,h) 3 0
        withBitmap (ImageRGBA8 (Image w h v)) f = SV.unsafeWith v $ f (w,h) 4 0
        withBitmap _ _ = error "unsupported image type :("
        texFilter = if isFiltered then GL_LINEAR else GL_NEAREST
        wrapMode = case isClamped of
            True    -> GL_CLAMP_TO_EDGE
            False   -> GL_REPEAT
        (minFilter,maxLevel) = case isFiltered && isMip of
            False   -> (texFilter,0)
            True    -> (GL_LINEAR_MIPMAP_LINEAR, floor $ log (fromIntegral $ max width height) / log 2)

    glTexParameteri GL_TEXTURE_CUBE_MAP GL_TEXTURE_MIN_FILTER $ fromIntegral minFilter
    glTexParameteri GL_TEXTURE_CUBE_MAP GL_TEXTURE_MAG_FILTER $ fromIntegral texFilter
    glGetEXTTextureFilterAnisotropic >>= \case
        False -> return ()
        True  -> alloca $ \ptr -> do
                    poke ptr 0
                    glGetIntegerv GL_MAX_TEXTURE_MAX_ANISOTROPY_EXT ptr
                    max <- peek ptr
                    glTexParameteri GL_TEXTURE_CUBE_MAP GL_TEXTURE_MAX_ANISOTROPY_EXT max
    glTexParameteri GL_TEXTURE_CUBE_MAP GL_TEXTURE_WRAP_S $ fromIntegral wrapMode
    glTexParameteri GL_TEXTURE_CUBE_MAP GL_TEXTURE_WRAP_T $ fromIntegral wrapMode

    glTexParameteri GL_TEXTURE_CUBE_MAP GL_TEXTURE_BASE_LEVEL 0
    glTexParameteri GL_TEXTURE_CUBE_MAP GL_TEXTURE_MAX_LEVEL $ fromIntegral maxLevel
    fmt <- withBitmap bitmap $ \(w,h) nchn 0 ptr -> do
        let fmt@(dataFormat,internalFormat) = imageFormat isSRGB nchn
        -- Graphics.GL.Core42.glTexStorage2D GL_TEXTURE_CUBE_MAP (maxLevel + 1) internalFormat (fromIntegral w) (fromIntegral h)
        -- glTexImage2D :: MonadIO m => GLenum -> GLint -> GLint -> GLsizei -> GLsizei -> GLint -> GLenum -> GLenum -> Ptr a -> m ()
        glTexImage2D side 0 internalFormat (fromIntegral w) (fromIntegral h) 0 dataFormat GL_UNSIGNED_BYTE $ castPtr ptr
        return (fmt,(w,h))
    forM_ bitmaps $ \(b,targ) -> withBitmap b $ \wh nchn 0 ptr -> do
        let (dataFormat,internalFormat) = case imageFormat isSRGB nchn of { x | (x,wh)==fmt -> x; _ -> error "incompatible images" }
        glTexImage2D targ 0 internalFormat (fromIntegral $ fst wh) (fromIntegral $ snd wh) 0 dataFormat GL_UNSIGNED_BYTE $ castPtr ptr

    when isMip $ glGenerateMipmap GL_TEXTURE_CUBE_MAP
    -- A GL_INVALID_OPERATION error will be generated if target is GL_TEXTURE_CUBE_MAP,
    -- and not all cube-map faces are initialized and consistent.
    return $ TextureCubeName to