module Graphics.OpenGLES.Texture (
Texture,
texSlot,
glLoadKtx,
glLoadKtxFile,
glLoadTex2D,
--glLoadCubeMap,
glLoadTex3D,
glLoadTex2DArray,
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 qualified Data.ByteString.Internal as B
import Data.Int
import Data.Word
import Data.IORef
import Data.Proxy
import Graphics.OpenGLES.Base
import Graphics.OpenGLES.Caps
import Graphics.OpenGLES.Internal
import Graphics.OpenGLES.PixelFormat
import Graphics.TextureContainer.KTX
import Foreign hiding (void)
import Linear
texSlot
:: Word32
-> Texture a
-> GL ()
texSlot slot (Texture target _ glo) = do
tex <- getObjId glo
glActiveTexture (0x84C0 + slot)
showError "glActiveTexture"
glBindTexture target tex
void $ showError "glBindTexture"
glLoadKtx
:: Maybe (Texture a)
-> Ktx
-> GL (Texture a)
glLoadKtx oldtex ktx@Ktx{..} = do
case checkKtx ktx of
Left msg -> glLog (msg ++ ": " ++ ktxName) >> newTexture oldtex 0 ktx
Right (comp, target, genmip) -> do
tex <- newTexture oldtex target ktx
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 a)
glLoadKtxFile path = ktxFromFile path >>= glLoadKtx Nothing
newTexture :: Maybe (Texture a) -> GLenum -> Ktx -> GL (Texture a)
newTexture (Just (Texture _ ref glo)) target ktx = do
writeIORef ref ktx
glBindTexture target =<< getObjId glo
return $ Texture target ref glo
newTexture Nothing target ktx =
Texture target <$> newIORef ktx <*> newGLO glGenTextures glDeleteTextures (glBindTexture target)
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
glLoadTex2D
:: forall a b. (Storable a, ExternalFormat a b)
=> Maybe (Texture b)
-> Bool
-> ForeignPtr a
-> V2 Word32
-> GL (Texture b)
glLoadTex2D oldtex newmip fp (V2 w h) = do
let (fmt, typ, ifmt) = efmt (Proxy :: Proxy (a, b))
let n = sizeOf (undefined :: a)
let ktx = Ktx "" B.empty typ 4 fmt ifmt fmt w h 0 0 1 0 []
[[B.PS (castForeignPtr fp) 0 (fromIntegral (w*h)*n)]]
let target = 0x0DE1
tex <- newTexture oldtex target ktx
withForeignPtr fp $ \ptr ->
glTexImage2D target 0 ifmt w h 0 fmt typ (castPtr ptr)
when newmip (glGenerateMipmap target)
return tex
glLoadTex3D
:: forall a b. (Storable a, ExternalFormat a b)
=> Maybe (Texture b)
-> Bool
-> ForeignPtr a
-> V3 Word32
-> GL (Texture b)
glLoadTex3D oldtex newmip fp (V3 w h d) = do
let (fmt, typ, ifmt) = efmt (Proxy :: Proxy (a, b))
let n = sizeOf (undefined :: a)
let ktx = Ktx "" B.empty typ 4 fmt ifmt fmt w h d 0 1 0 []
[[B.PS (castForeignPtr fp) 0 (fromIntegral (w*h*d)*n)]]
let target = 0x806F
tex <- newTexture oldtex target ktx
withForeignPtr fp $ \ptr ->
glTexImage3D target 0 ifmt w h d 0 fmt typ (castPtr ptr)
when newmip (glGenerateMipmap target)
return tex
glLoadTex2DArray
:: forall a b. (Storable a, ExternalFormat a b)
=> Maybe (Texture b)
-> Bool
-> ForeignPtr a
-> V3 Word32
-> GL (Texture b)
glLoadTex2DArray oldtex newmip fp (V3 w h d) = do
let (fmt, typ, ifmt) = efmt (Proxy :: Proxy (a, b))
let n = sizeOf (undefined :: a)
let ktx = Ktx "" B.empty typ 4 fmt ifmt fmt w h 0 d 1 0 []
[[B.PS (castForeignPtr fp) 0 (fromIntegral (w*h*d)*n)]]
let target = 0x8C1A
tex <- newTexture oldtex target ktx
withForeignPtr fp $ \ptr ->
glTexImage3D target 0 ifmt w h d 0 fmt typ (castPtr ptr)
when newmip (glGenerateMipmap target)
return tex
data Sampler = Sampler
{
_wrapMode :: (WrapMode, WrapMode, Maybe WrapMode)
, _anisotropicFilter :: Float
, _fallbackFilter :: (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 a -> Sampler -> GL ()
setSampler (Texture target _ glo) (Sampler (WrapMode s, WrapMode t, r) a
(MagFilter g, MinFilter n)) = do
tex <- getObjId glo
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