module Graphics.OpenGLES.Texture (
Texture,
--TextureColorFormat,
--TextureBitLayout,
--TextureInternalFormat,
--TextureData,
glLoadKtx,
glLoadKtxFile,
texSlot,
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)
data Texture = Texture GLenum GLO (IORef Ktx)
texSlot :: Word32 -> Texture -> GL ()
texSlot slot (Texture target glo _) = do
tex <- readIORef glo >>= return . fst
glActiveTexture (0x84C0 + slot)
glBindTexture target tex
data TextureColorFormat = ALPHA | RGB | RGBA | LUMINANCE | LUMINANCE_ALPHA
data TextureBitLayout = UByte | US565 | US444 | US5551
| 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
| 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
| ATITC
| S3TC
| ETC
glLoadKtx :: Maybe Texture -> Ktx -> GL Texture
glLoadKtx oldtex ktx@Ktx{..} = do
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
let fmt = if comp || sizedFormats
then if ktxGlInternalFormat == 0x8D64 && hasETC2
then 0x9274
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
(True, 0x0DE1) -> do
B.useAsCStringLen (head faces) $ \(ptr, len) ->
glCompressedTexImage2D target level fmt w h 0 (i len) (castPtr ptr)
(False, 0x0DE1) -> do
B.useAsCString (head faces) $ \ptr ->
glTexImage2D target level fmt w h 0 ktxGlFormat ktxGlType (castPtr ptr)
(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)
(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)
(True, 0x806F) -> do
B.useAsCStringLen (head faces) $ \(ptr, len) ->
glCompressedTexImage3D target level fmt w h d 0 (i len) (castPtr ptr)
(False, 0x806F) -> do
B.useAsCString (head faces) $ \ptr ->
glTexImage3D target level fmt w h d 0 ktxGlFormat ktxGlType (castPtr ptr)
(True, 0x8C1A) -> do
B.useAsCStringLen (head faces) $ \(ptr, len) ->
glCompressedTexImage3D target level fmt w h ktxNumElems 0 (i len) (castPtr ptr)
(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
sizedFormats = hasES3 || hasExt "GL_OES_required_internalformat"
hasETC2 = hasES3
hasPVRTC = hasExt "GL_IMG_texture_compression_pvrtc"
hasATITC = hasExt "GL_ATI_texture_compression_atitc"
hasS3TC = hasExt "GL_EXT_texture_compression_s3tc"
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^(ktxNumMipLevels1)
= 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
data Sampler =
Sampler (WrapMode, WrapMode, Maybe WrapMode) Float (MagFilter, MinFilter)
newtype MagFilter = MagFilter Int32
magNearest = MagFilter 0x2600
magLinear = MagFilter 0x2601
newtype MinFilter = MinFilter Int32
minNearest = MinFilter 0x2600
minLinear = MinFilter 0x2601
nearestMipmapNearest = MinFilter 0x2700
linearMipmapNearest = MinFilter 0x2701
nearestMipmapLinear = MinFilter 0x2702
linearMipmapLinear = MinFilter 0x2703
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
glTexParameterf target 0x84FE a
glTexParameteri target 0x2800 g
glTexParameteri target 0x2801 n