module Graphics.LambdaCube.RenderSystem.GL.Texture where

import Control.Monad
import Data.Maybe
import Data.Ord
import Foreign
import qualified Data.Set as Set

import Graphics.Rendering.OpenGL.Raw.ARB.Compatibility
import Graphics.Rendering.OpenGL.Raw.Core31

import Graphics.LambdaCube.HardwareBuffer
import Graphics.LambdaCube.Image
import Graphics.LambdaCube.PixelFormat
import Graphics.LambdaCube.RenderSystem.GL.Utils
import Graphics.LambdaCube.RenderSystemCapabilities
import Graphics.LambdaCube.Texture
import Graphics.LambdaCube.Types

data GLTexture
    = GLTexture
    { gltxName                      :: String
    , gltxWidth                     :: Int
    , gltxHeight                    :: Int
    , gltxDepth                     :: Int
    , gltxNumRequestedMipmaps       :: TextureMipmap
    , gltxNumMipmaps                :: Int
    , gltxMipmapsHardwareGenerated  :: Bool
    , gltxGamma                     :: FloatType
    , gltxHwGamma                   :: Bool
    , gltxFSAA                      :: Int
    , gltxFSAAHint                  :: String
    , gltxTextureType               :: TextureType
    , gltxFormat                    :: PixelFormat
    , gltxUsage                     :: TextureUsage
    , gltxSrcFormat                 :: PixelFormat
    , gltxSrcWidth                  :: Int
    , gltxSrcHeight                 :: Int
    , gltxSrcDepth                  :: Int

    , gltxDesiredFormat             :: PixelFormat
    , gltxDesiredIntegerBitDepth    :: Int
    , gltxDesiredFloatBitDepth      :: Int
    , gltxTreatLuminanceAsAlpha     :: Bool

    , gltxTextureObject             :: GLuint
    }

instance Eq GLTexture where
    x == y = compare x y == EQ

instance Ord GLTexture where
    compare = comparing gltxTextureObject

instance HardwareBuffer GLTexture

instance Texture GLTexture where
    txName                      = gltxName
    txWidth                     = gltxWidth
    txHeight                    = gltxHeight
    txDepth                     = gltxDepth
    txNumRequestedMipmaps       = gltxNumRequestedMipmaps
    txNumMipmaps                = gltxNumMipmaps
    txMipmapsHardwareGenerated  = gltxMipmapsHardwareGenerated
    txGamma                     = gltxGamma
    txHwGamma                   = gltxHwGamma
    txFSAA                      = gltxFSAA
    txFSAAHint                  = gltxFSAAHint
    txTextureType               = gltxTextureType
    txFormat                    = gltxFormat
    txSrcFormat                 = gltxSrcFormat
    txSrcWidth                  = gltxSrcWidth
    txSrcHeight                 = gltxSrcHeight
    txSrcDepth                  = gltxSrcDepth

    txDesiredFormat             = gltxDesiredFormat
    txDesiredIntegerBitDepth    = gltxDesiredIntegerBitDepth
    txDesiredFloatBitDepth      = gltxDesiredFloatBitDepth
    txTreatLuminanceAsAlpha     = gltxTreatLuminanceAsAlpha

mkGLTexture :: RenderSystemCapabilities -> String -> TextureType -> Int -> Int -> Int -> TextureMipmap -> PixelFormat -> TextureUsage -> Bool -> Int -> String -> Maybe [Image] -> IO GLTexture
--FIXME: image parameter is temporary!!!!
mkGLTexture rcaps name texType width height depth numMips format usage hwGammaCorrection _fsaa _fsaaHint mimage = do
    let caps = rscCapabilities rcaps
    putStrLn $ "createTexture " ++ "create " ++ show texType ++ " texture: " ++ name

    when (texType == TEX_TYPE_3D && Set.notMember RSC_TEXTURE_3D caps) $ error "3D Textures not supported before OpenGL 1.2"

    (major,minor) <- getGLVersion

    let glVer a b   = major > a || (major >= a && minor >= b)
        texTarget   = (getGLTextureTarget texType)
        -- Convert to nearest power-of-two size if required
        mWidth      = optionalPO2 rcaps width
        mHeight     = optionalPO2 rcaps height
        mDepth      = optionalPO2 rcaps depth

        -- Adjust format if required
        mFormat     = getNativeFormat texType format False -- TODO

        -- Check requested number of mipmaps
        maxMips     = getMaxMipmaps mWidth mHeight mDepth mFormat
        mNumMipmaps = maxMips -- TODO min maxMips numMips

    -- Generate texture name
    mTextureID <- alloca $ \buf -> glGenTextures 1 buf >> peek buf

    -- Set texture type
    glBindTexture texTarget mTextureID

    -- This needs to be set otherwise the texture doesn't get rendered
    when (glVer 1 2) $ glTexParameteri texTarget gl_TEXTURE_MAX_LEVEL mNumMipmaps

    -- Set some misc default parameters so NVidia won't complain, these can of course be changed later
    glTexParameteri texTarget gl_TEXTURE_MIN_FILTER $ fromIntegral gl_NEAREST
    glTexParameteri texTarget gl_TEXTURE_MAG_FILTER $ fromIntegral gl_NEAREST

    when (glVer 1 2) $ do
        glTexParameteri texTarget gl_TEXTURE_WRAP_S $ fromIntegral gl_CLAMP_TO_EDGE
        glTexParameteri texTarget gl_TEXTURE_WRAP_T $ fromIntegral gl_CLAMP_TO_EDGE

    -- If we can do automip generation and the user desires this, do so
    let mMipmapsHardwareGenerated = Set.member RSC_AUTOMIPMAP caps

    let moreMips = case numMips of
            MIP_UNLIMITED -> True
            MIP_DEFAULT   -> True -- TODO
            MIP_NUMBER n  -> n > 0

    when (tuAutoMipmap usage && moreMips && mMipmapsHardwareGenerated) $ glTexParameteri texTarget gl_GENERATE_MIPMAP $ fromIntegral gl_TRUE

    -- Allocate internal buffer so that glTexSubImageXD can be used
    -- Internal format
    let format' = getClosestGLInternalFormat mFormat hwGammaCorrection
        isCompressed _ = False -- TODO
    case isCompressed mFormat of
        True  -> do
            putStrLn "compressed format is not implemented!"
        False -> do
            let setMip (w,h,d) mip = do
                    -- Normal formats
                    case texType of
                        TEX_TYPE_1D       -> glTexImage1D gl_TEXTURE_1D mip format' w 0 gl_RGBA gl_UNSIGNED_BYTE nullPtr
                        TEX_TYPE_2D       -> glTexImage2D gl_TEXTURE_2D mip format' w h 0 gl_RGBA gl_UNSIGNED_BYTE nullPtr
                        TEX_TYPE_3D       -> glTexImage3D gl_TEXTURE_3D mip format' w h d 0 gl_RGBA gl_UNSIGNED_BYTE nullPtr
                        TEX_TYPE_CUBE_MAP -> forM_ [0..5] $ \face ->
                            glTexImage2D (gl_TEXTURE_CUBE_MAP_POSITIVE_X + face) mip format' w h 0 gl_RGBA gl_UNSIGNED_BYTE nullPtr
                    return (max 1 (w `div` 2), max 1 (h `div` 2), max 1 (d `div` 2))
                f = fromIntegral
            -- Run through this process to pregenerate mipmap piramid
            foldM_ setMip (f mWidth,f mHeight,f mDepth) [0..(fromIntegral mNumMipmaps)]

    -- TODO
    -- TEMP CODE
    when (isJust mimage) $ do
        let images = fromJust mimage
            imInfo i = (fmt,f w,f h)
              where
                f   = fromIntegral
                fmt = case imFormat i of
                    PF_L8         -> gl_LUMINANCE
                    PF_BYTE_LA    -> gl_LUMINANCE_ALPHA
                    PF_R8G8B8     -> gl_RGB
                    PF_R8G8B8A8   -> gl_RGBA
                    _             -> error "mkGLTexture"
                w   = imWidth i
                h   = imHeight i
            upload2D target i = do
                let (fmt,w,h) = imInfo i
                putStrLn $ "createTexture " ++ "upload2d: " ++ imName i
                glTexImage2D target 0 format' w h 0 fmt gl_UNSIGNED_BYTE $ imDataPtr i

        case texType of
            TEX_TYPE_1D       -> do
              let (fmt,w,_h) = imInfo image
                  image      = head images
              glTexImage1D gl_TEXTURE_1D 0 format' w 0 fmt gl_UNSIGNED_BYTE $ imDataPtr image
            TEX_TYPE_2D       -> upload2D gl_TEXTURE_2D $ head images
            TEX_TYPE_CUBE_MAP -> mapM_ (uncurry upload2D) $ zip [ gl_TEXTURE_CUBE_MAP_POSITIVE_Z -- front
                                                                , gl_TEXTURE_CUBE_MAP_NEGATIVE_Z -- back
                                                                , gl_TEXTURE_CUBE_MAP_POSITIVE_Y -- up
                                                                , gl_TEXTURE_CUBE_MAP_NEGATIVE_Y -- down
                                                                , gl_TEXTURE_CUBE_MAP_NEGATIVE_X -- left
                                                                , gl_TEXTURE_CUBE_MAP_POSITIVE_X -- right
                                                                ] images
            _ -> return ()

    --_createSurfaceList();

    -- Get final internal format
    -- TODO
    --mFormat = getBuffer(0,0)->getFormat();
    putStrLn $ "createTexture " ++ "created texture: " ++ name
    return GLTexture
        { gltxName                      = name
        , gltxWidth                     = 0 --TODO
        , gltxHeight                    = 0 --TODO
        , gltxDepth                     = 0 --TODO
        , gltxNumRequestedMipmaps       = MIP_DEFAULT --TODO
        , gltxNumMipmaps                = 0 --TODO
        , gltxMipmapsHardwareGenerated  = True --TODO
        , gltxGamma                     = 0 --TODO
        , gltxHwGamma                   = True --TODO
        , gltxFSAA                      = 0 --TODO
        , gltxFSAAHint                  = "" --TODO
        , gltxTextureType               = texType
        , gltxFormat                    = PF_R8G8B8 -- TODO
        , gltxUsage                     = TextureUsage HBU_WRITE_ONLY False False-- TODO
        , gltxSrcFormat                 = PF_R8G8B8 -- TODO
        , gltxSrcWidth                  = 0 --TODO
        , gltxSrcHeight                 = 0 --TODO
        , gltxSrcDepth                  = 0 --TODO

        , gltxDesiredFormat             = PF_R8G8B8 --TODO
        , gltxDesiredIntegerBitDepth    = 0 --TODO
        , gltxDesiredFloatBitDepth      = 0 --TODO
        , gltxTreatLuminanceAsAlpha     = True --TODO

        , gltxTextureObject             = mTextureID
        }