{-# LANGUAGE RecordWildCards #-}
module Graphics.OpenGLES.Texture (
  -- * Texture
  Texture,
  --TextureColorFormat,
  --TextureBitLayout,
  --TextureInternalFormat,
  --TextureData,
  glLoadKtx,
  glLoadKtxFile,

  texSlot,

  -- * Sampler
  setSampler,
  Sampler(..),
  
  MagFilter,
  magNearest,
  magLinear,
  
  MinFilter,
  minNearest,
  minLinear,
  nearestMipmapNearest,
  linearMipmapNearest,
  nearestMipmapLinear,
  linearMipmapLinear,
  
  WrapMode,
  tiledRepeat,
  clampToEdge,
  mirroredRepeat
  ) where
import Control.Applicative
import Control.Monad
import qualified Data.ByteString as B
import Data.Int
import Data.Word
import Data.IORef
import Graphics.OpenGLES.Base
import Graphics.OpenGLES.Env
import Graphics.OpenGLES.Internal
import Graphics.TextureContainer.KTX
import Foreign.Ptr (castPtr)

-- glo, target, ktx
data Texture = Texture GLenum GLO (IORef Ktx)
-- XXX Texture DoubleBufferring

texSlot :: Word32 -> Texture -> GL ()
texSlot slot (Texture target glo _) = do
	tex <- readIORef glo >>= return . fst
	glActiveTexture (0x84C0 + slot) -- GL_TEXTURE_0 + slot
	glBindTexture target tex

data TextureColorFormat = ALPHA | RGB | RGBA | LUMINANCE | LUMINANCE_ALPHA

data TextureBitLayout = UByte | US565 | US444 | US5551
	-- | ES 3.0
	| Byte | UShort | Short | UInt | Int | HalfFloat | Float | US4444 | UI2_10_10_10Rev | UI24_8 | UI_10f11f11fRev | UI5999Rev | F32UI24_8Rev

data TextureInternalFormat = Alpha | Rgb | Rgba | Luminance | LuminanceAlpha
	-- 3.0
	| R8 | R8i | R8ui | R8snorm | R16i | R16ui | R16f | R32i | R32ui | R32f
	| Rg8 | Rg8i | Rg8ui | Rg8snorm | Rg16i | Rg16ui | Rg16f | Rg32i | Rg32ui | Rg32f
	| Rgb8 | Rgb8i | Rgb8ui | Rgb8snorm | Rgb16i | Rgb16ui | Rgb16f | Rgb32i | Rgb32ui | Rgb32f
	| Rgba8 | Rgba8i | Rgba8ui | Rgba8snorm | Rgba16i | Rgba16ui | Rgba16f | Rgba32i | Rgba32ui | Rgba32f
	| Rgb5a1 | Rgb565 | Rgb9e5 | Rgb10a2 | Rgb10a2ui | Srgb8 | Rgba4 | Srgb8Alpha8
	| R11fG11fB10f | DepthComponent16 | DepthComponent24 | DepthComponent32
	| Depth24Stencil8 | Depth32fStencil8

data TextureData =
	  PlainTexture
	| PVRTC -- PowerVR SGX(iOS), Samsung S5PC110(Galaxy S/Tab)
	| ATITC -- ATI Imageon, Qualcomm Adreno
	| S3TC -- NVIDIA Tegra2, ZiiLabs ZMS-08 HD
	| ETC -- Android, ARM Mali
	-- .| _3Dc -- ATI, NVidia
	-- .| Palette

-- | Load a GL Texture object from Ktx texture container.
-- See <https://github.com/KhronosGroup/KTX/blob/master/lib/loader.c>
-- TODO: reject 2DArray/3D texture if unsupported
glLoadKtx :: Maybe Texture -> Ktx -> GL Texture
glLoadKtx oldtex ktx@Ktx{..} = do
	--putStrLn.show $ ktx
	let newTexture target = case oldtex of
		Just (Texture _ glo ref) -> do
			writeIORef ref ktx
			readIORef glo >>= glBindTexture target . fst
			return (Texture target glo ref)
		Nothing -> Texture target
			<$> newGLO glGenTextures (glBindTexture target) glDeleteTextures
			<*> newIORef ktx
	case checkKtx ktx of
		Left msg -> glLog (msg ++ ": " ++ ktxName) >> newTexture 0
		Right (comp, target, genmip) -> do
			tex <- newTexture target
			-- ES2 compat;
			let fmt = if comp || sizedFormats
				then if ktxGlInternalFormat == 0x8D64 && hasETC2 -- ETC1_RGB8_OES
					then 0x9274 -- GL_COMPRESSED_RGB8_ETC2
					else ktxGlInternalFormat
				else ktxGlBaseInternalFormat
			putStrLn . show $ (comp, target,genmip, ktxGlInternalFormat, hasETC2, fmt)
			let uploadMipmap _ _ _ _ [] = return ()
			    uploadMipmap level w h d (faces:rest) = do
				case (comp, target) of
					-- 2D Compressed
					(True, 0x0DE1) -> do
						B.useAsCStringLen (head faces) $ \(ptr, len) ->
							glCompressedTexImage2D target level fmt w h 0 (i len) (castPtr ptr)
					-- 2D Uncompressed
					(False, 0x0DE1) -> do
						B.useAsCString (head faces) $ \ptr ->
							glTexImage2D target level fmt w h 0 ktxGlFormat ktxGlType (castPtr ptr)
					-- Cube Map Compressed
					(True, 0x8513) -> do
						forM_ (zip [texture_cube_map_positive_x..] faces) $ \(face, image) ->
							B.useAsCStringLen image $ \(ptr, len) ->
								glCompressedTexImage2D face level fmt w h 0 (i len) (castPtr ptr)
					-- Cube Map Uncompressed
					(False, 0x8513) -> do
						forM_ (zip [texture_cube_map_positive_x..] faces) $ \(face, image) ->
							B.useAsCString image $ \ptr ->
								glTexImage2D face level fmt w h 0 ktxGlFormat ktxGlType (castPtr ptr)
					-- 3D Compressed
					(True, 0x806F) -> do
						B.useAsCStringLen (head faces) $ \(ptr, len) ->
							glCompressedTexImage3D target level fmt w h d 0 (i len) (castPtr ptr)
					-- 3D Uncompressed
					(False, 0x806F) -> do
						B.useAsCString (head faces) $ \ptr ->
							glTexImage3D target level fmt w h d 0 ktxGlFormat ktxGlType (castPtr ptr)
					-- 2D Array Compressed
					(True, 0x8C1A) -> do
						B.useAsCStringLen (head faces) $ \(ptr, len) ->
							glCompressedTexImage3D target level fmt w h ktxNumElems 0 (i len) (castPtr ptr)
					-- 2D Array Uncompressed
					(False, 0x8C1A) -> do
						B.useAsCString (head faces) $ \ptr ->
							glTexImage3D target level fmt w h ktxNumFaces 0 ktxGlFormat ktxGlType (castPtr ptr)
				showError $ "gl{,Compressed}TexImage{2D,3D} " ++ ktxName
				uploadMipmap (level + 1) (div2 w) (div2 h) (div2 d) rest
				
				where
					div2 x = max 1 (div x 2)
					i = fromIntegral

			uploadMipmap 0 ktxPixelWidth ktxPixelHeight ktxPixelDepth ktxImage
			when genmip $ do
				glGenerateMipmap target
				void $ showError $ "glGenerateMipmap " ++ ktxName
			return tex

glLoadKtxFile :: FilePath -> GL Texture
glLoadKtxFile path = ktxFromFile path >>= glLoadKtx Nothing

-- glPixelStorei(GL_UNPACK_ALIGNMENT, 4)
--hasES2 =
--	supportsSwizzle = GL_FALSE;
--	sizedFormats = _NO_SIZED_FORMATS;
--	R16Formats = _KTX_NO_R16_FORMATS;
--	supportsSRGB = GL_FALSE;
--hasES3 = sizedFormats = _NON_LEGACY_FORMATS;
--hasExt "GL_OES_required_internalformat" =
--	sizedFormats |= _ALL_SIZED_FORMATS
sizedFormats = hasES3 || hasExt "GL_OES_required_internalformat"
-- There are no OES extensions for sRGB textures or R16 formats.
hasETC2 = hasES3
hasPVRTC = hasExt "GL_IMG_texture_compression_pvrtc"
hasATITC = hasExt "GL_ATI_texture_compression_atitc"
hasS3TC = hasExt "GL_EXT_texture_compression_s3tc"

-- | Check a KTX file header.
-- returning (isCompressed?, textureTarget, generateMipmapNeeded?)
checkKtx :: Ktx -> Either String (Bool, GLenum, Bool)
checkKtx t = (,,) <$> isCompressed t <*> detectTarget t <*> needsGenMipmap t

isCompressed Ktx { ktxGlTypeSize = s } | s /= 1 && s /= 2 && s /= 4 = Left "checkKtx: Invalid glTypeSize"
isCompressed Ktx { ktxGlType = 0, ktxGlFormat = 0 } = Right True
isCompressed Ktx { ktxGlType = t, ktxGlFormat = f } | t == 0 || f == 0 = Left "checkKtx: Invalid glType"
isCompressed _ = Right False

detectTarget ktx@Ktx { ktxNumElems = 0 } = detectCube ktx
detectTarget ktx = detectCube ktx >>= \target ->
	if target == texture_2d
		then Right texture_2d_array
		else Left "checkKtx: No API for 3D and cube arrays yet"
detectCube ktx@Ktx { ktxNumFaces = 1 } = detectDim ktx
detectCube ktx@Ktx { ktxNumFaces = 6 } = detectDim ktx >>= \dim ->
	if dim == 2
		then Right texture_cube_map
		else Left "checkKtx: cube map needs 2D faces"
detectCube _ = Left "checkKtx: numberOfFaces must be either 1 or 6"

detectDim Ktx { ktxPixelWidth = 0 } = Left "checkKtx: texture must have width"
detectDim Ktx { ktxPixelHeight = 0, ktxPixelDepth = 0 } = Left "checkKtx: 1D texture is not supported"
detectDim Ktx { ktxPixelHeight = 0 } = Left "checkKtx: texture must have height if it has depth"
detectDim Ktx { ktxPixelDepth = 0 } = Right texture_2d
detectDim _ = Right texture_3d

needsGenMipmap Ktx { ktxNumMipLevels = 0 } = Right True
needsGenMipmap Ktx {..}
	| max (max ktxPixelDepth ktxPixelHeight) ktxPixelDepth < 2^(ktxNumMipLevels-1)
	= Left "checkKtx: Can't have more mip levels than 1 + log2(max(width, height, depth))"
needsGenMipmap _ = Right False

texture_2d = 0x0DE1
texture_cube_map = 0x8513
texture_2d_array = 0x8C1A
texture_3d = 0x806F

texture_cube_map_positive_x = 0x8515


-- ** Sampler

-- 2d vs. 3d / mag + min vs. max
-- | (Texture wrap mode, A number of ANISOTROPY filter sampling points
-- (specify 1.0 to disable anisotropy filter), (Fallback) Mag and Min filters).
-- 
-- When /EXT_texture_filter_anisotropic/ is not supported, fallback filters
-- are used instead.
data Sampler =
	Sampler (WrapMode, WrapMode, Maybe WrapMode) Float (MagFilter, MinFilter)

newtype MagFilter = MagFilter Int32
magNearest = MagFilter 0x2600
magLinear = MagFilter 0x2601

-- TODO NoMipmap => use minLinear instead / forceGenMip?
newtype MinFilter = MinFilter Int32
minNearest = MinFilter 0x2600
minLinear = MinFilter 0x2601
nearestMipmapNearest = MinFilter 0x2700
linearMipmapNearest = MinFilter 0x2701
nearestMipmapLinear = MinFilter 0x2702
linearMipmapLinear = MinFilter 0x2703

-- TODO: NPOT && not ClampToEdge && not (hasES3 || hasExt "GL_OES_texture_npot") => error
newtype WrapMode = WrapMode Int32
tiledRepeat = WrapMode 0x2901
clampToEdge = WrapMode 0x812F
mirroredRepeat = WrapMode 0x8370

setSampler :: Texture -> Sampler -> GL ()
setSampler (Texture target glo _) (Sampler (WrapMode s, WrapMode t, r) a
		(MagFilter g, MinFilter n)) = do
	tex <- readIORef glo >>= return . fst
	glBindTexture target tex
	glTexParameteri target 0x2802 s
	glTexParameteri target 0x2803 t
	maybe (return ()) (\(WrapMode x) -> glTexParameteri target 0x8072 x) r
	--if a /= 1.0 && hasExt "GL_EXT_texture_filter_anisotropic" then
	-- GL_TEXTURE_MAX_ANISOTROPY_EXT
	glTexParameterf target 0x84FE a
	glTexParameteri target 0x2800 g
	glTexParameteri target 0x2801 n

--setLOD :: Texture -> Int32 -> Int32 -> GL ()
--setTexCompFunc :: Texture ->  ->  -> GL ()

-- mipmaps, compressed, fallbacks
-- [comptex, fallback]
-- glm basepath = /data/app.name/assets/...
-- glm preffered compression type (filename suffiex)
---- iOS: PVRTC
---- Android with Alpha: PVRTC+ATITC+S3TC+Uncompressed
---- Android without Alpha: ETC1
---- PC: S3TC + Uncompressed
--glm detect compression support
-- record Gen/Del/Draw* calls and responces
-- prefferedformat == "etc1" like.
-- texture from file "name" [path..] genMipmap?flag
--Utils.hs shrinked triangles, 
--  Update[Sub]Texture,UpdateVertex(Buffer)
-- "texname" [tex1,tex2,...] auto select
-- texture atlas managment