module Graphics.Caramia.Texture
(
newTexture
, Texture()
, TextureSpecification(..)
, textureSpecification
, Topology(..)
, uploadToTexture
, Uploading(..)
, uploading1D
, uploading2D
, uploading3D
, UploadFormat(..)
, CubeSide(..)
, TextureUnit
, generateMipmaps
, setWrapping
, getWrapping
, setMinFilter
, setMagFilter
, getMinFilter
, getMagFilter
, setAnisotropy
, getAnisotropy
, setCompareMode
, getCompareMode
, MinFilter(..)
, MagFilter(..)
, Wrapping(..)
, CompareMode(..)
, viewSpecification
, viewWidth
, viewHeight
, viewDepth
, viewMipmapLevels
, viewSize2D
, viewSize3D
, maxMipmapLevels )
where
import Control.Monad.IO.Class
import Control.Monad.Catch
import Data.Data ( Data )
import GHC.Generics
import qualified Graphics.Caramia.Buffer.Internal as Buf
import Graphics.Caramia.ImageFormats.Internal
import Graphics.Caramia.Internal.Exception
import Graphics.Caramia.Internal.TexStorage
import Graphics.Caramia.Internal.OpenGLCApi
import Graphics.Caramia.Prelude
import Graphics.Caramia.Resource
import Graphics.Caramia.Texture.Internal
import Graphics.GL.Ext.ARB.TextureBufferObject
import Graphics.GL.Ext.EXT.TextureFilterAnisotropic
import Graphics.GL.Ext.ARB.TextureMultisample
import Graphics.GL.Ext.ARB.TextureStorage
import Foreign
import Linear.V2 ( V2(..) )
import Linear.V3 ( V3(..) )
textureSpecification :: TextureSpecification
textureSpecification = TextureSpecification {
topology = error "textureSpecification: topology is not set."
, imageFormat = error "textureSpecification: image format is not set."
, mipmapLevels = 1 }
viewWidth :: Texture -> Int
viewWidth (viewSpecification -> spec) = viewWidth' (topology spec)
where
viewWidth' (Tex1D {..}) = width1D
viewWidth' (Tex2D {..}) = width2D
viewWidth' (Tex3D {..}) = width3D
viewWidth' (Tex1DArray {..}) = width1DArray
viewWidth' (Tex2DArray {..}) = width2DArray
viewWidth' (Tex2DMultisample {..}) = width2DMS
viewWidth' (Tex2DMultisampleArray {..}) = width2DMSArray
viewWidth' (TexCube {..}) = widthCube
viewWidth' (TexBuffer {}) =
error "viewWidth: buffer texture has no meaningful width."
viewSize2D :: Texture -> V2 Int
viewSize2D tex = V2 (viewWidth tex) (viewHeight tex)
viewSize3D :: Texture -> V3 Int
viewSize3D tex = V3 (viewWidth tex) (viewHeight tex) (viewDepth tex)
viewHeight :: Texture -> Int
viewHeight (viewSpecification -> spec) = viewHeight' (topology spec)
where
viewHeight' (Tex1D {..}) = 1
viewHeight' (Tex2D {..}) = height2D
viewHeight' (Tex3D {..}) = height3D
viewHeight' (Tex1DArray {..}) = 1
viewHeight' (Tex2DArray {..}) = height2DArray
viewHeight' (Tex2DMultisample {..}) = height2DMS
viewHeight' (Tex2DMultisampleArray {..}) = height2DMSArray
viewHeight' (TexCube {..}) = widthCube
viewHeight' (TexBuffer {}) = 1
viewDepth :: Texture -> Int
viewDepth (viewSpecification -> spec) = viewDepth' (topology spec)
where
viewDepth' (Tex1D {..}) = 1
viewDepth' (Tex2D {..}) = 1
viewDepth' (Tex3D {..}) = depth3D
viewDepth' (Tex1DArray {..}) = layers1D
viewDepth' (Tex2DArray {..}) = layers2D
viewDepth' (Tex2DMultisample {..}) = 1
viewDepth' (Tex2DMultisampleArray {..}) = layers2DMS
viewDepth' (TexCube {..}) = 1
viewDepth' (TexBuffer {}) = 1
viewMipmapLevels :: Texture -> Int
viewMipmapLevels = mipmapLevels . viewSpecification
isMultisamplingTopology :: Topology -> Bool
isMultisamplingTopology (Tex2DMultisample {..}) = True
isMultisamplingTopology (Tex2DMultisampleArray {..}) = True
isMultisamplingTopology _ = False
newTexture :: MonadIO m
=> TextureSpecification
-> m Texture
newTexture spec = liftIO $ mask_ $ do
topologySanityCheck (topology spec)
when (not (isMultisamplingTopology (topology spec)) &&
mipmapLevels spec < 1) $
error "newTexture: mipmapLevels is not positive."
res <- newResource creator
deleter
(return ())
index <- newUnique
return Texture { resource = res
, ordIndex = index
, viewSpecification = spec }
where
num_mipmaps = mipmapLevels spec
topologySanityCheck t@(Tex1D {..})
| width1D <= 0 = badTopology t
| not (isValidMipmap width1D num_mipmaps) = badMipmaps
| otherwise = return ()
topologySanityCheck t@(Tex2D {..})
| width2D <= 0 || height2D <= 0 = badTopology t
| not (isValidMipmap (max width2D height2D) num_mipmaps) = badMipmaps
| otherwise = return ()
topologySanityCheck t@(Tex3D {..})
| width3D <= 0 || height3D <= 0 || depth3D <= 0 = badTopology t
| not (isValidMipmap (max width3D $ max height3D depth3D) num_mipmaps) =
badMipmaps
| otherwise = return ()
topologySanityCheck t@(Tex1DArray {..})
| width1DArray <= 0 || layers1D <= 0 = badTopology t
| not (isValidMipmap width1DArray num_mipmaps) =
badMipmaps
| otherwise = return ()
topologySanityCheck t@(Tex2DArray {..})
| width2DArray <= 0 || height2DArray <= 0 ||
layers2D <= 0 = badTopology t
| not (isValidMipmap (max width2DArray height2DArray) num_mipmaps) =
badMipmaps
| otherwise = return ()
topologySanityCheck t@(Tex2DMultisample {..})
| width2DMS <= 0 || height2DMS <= 0 = badTopology t
| otherwise = return ()
topologySanityCheck t@(Tex2DMultisampleArray {..})
| width2DMSArray <= 0 || height2DMSArray <= 0 ||
layers2DMS <= 0 = badTopology t
| otherwise = return ()
topologySanityCheck t@(TexCube {..})
| widthCube <= 0 = badTopology t
| not (isValidMipmap widthCube num_mipmaps) =
badMipmaps
| otherwise = return ()
topologySanityCheck (TexBuffer {}) = return ()
badTopology _ = error "newTexture: bad topology."
badMipmaps =
error $ "newTexture: bad number of mipmap levels: " <> show num_mipmaps
deleter (Texture_ name) =
with name $ glDeleteTextures 1
creator = do
name <- bracketOnError
(alloca $ \name_ptr ->
glGenTextures 1 name_ptr *> peek name_ptr)
(deleter . Texture_ )
(\name -> do
if gl_ARB_texture_storage
then createByTopologyTexStorage name (topology spec)
else createByTopologyFakeTextureStorage name (topology spec)
return name)
return (Texture_ name)
createByTopologyFakeTextureStorage :: GLuint -> Topology -> IO ()
createByTopologyFakeTextureStorage name (Tex1D {..}) =
fakeTextureStorage1D name
GL_TEXTURE_1D
(safeFromIntegral num_mipmaps)
(toConstantIF (imageFormat spec))
(safeFromIntegral width1D)
createByTopologyFakeTextureStorage name (Tex2D {..}) =
fakeTextureStorage2D name
GL_TEXTURE_2D
(safeFromIntegral num_mipmaps)
(toConstantIF (imageFormat spec))
(safeFromIntegral width2D)
(safeFromIntegral height2D)
createByTopologyFakeTextureStorage name (Tex3D {..}) =
fakeTextureStorage3D name
GL_TEXTURE_3D
(safeFromIntegral num_mipmaps)
(toConstantIF (imageFormat spec))
(safeFromIntegral width3D)
(safeFromIntegral height3D)
(safeFromIntegral depth3D)
createByTopologyFakeTextureStorage name (Tex1DArray {..}) =
fakeTextureStorage2D name
GL_TEXTURE_1D_ARRAY
(safeFromIntegral num_mipmaps)
(toConstantIF (imageFormat spec))
(safeFromIntegral width1DArray)
(safeFromIntegral layers1D)
createByTopologyFakeTextureStorage name (Tex2DArray {..}) =
fakeTextureStorage3D name
GL_TEXTURE_2D_ARRAY
(safeFromIntegral num_mipmaps)
(toConstantIF (imageFormat spec))
(safeFromIntegral width2DArray)
(safeFromIntegral height2DArray)
(safeFromIntegral layers2D)
createByTopologyFakeTextureStorage name tex@(Tex2DMultisample {..}) =
createByTopologyTexStorage name tex
createByTopologyFakeTextureStorage name tex@(Tex2DMultisampleArray {..}) =
createByTopologyTexStorage name tex
createByTopologyFakeTextureStorage name (TexCube {..}) =
fakeTextureStorage2D name
GL_TEXTURE_CUBE_MAP
(safeFromIntegral num_mipmaps)
(toConstantIF (imageFormat spec))
(safeFromIntegral widthCube)
(safeFromIntegral widthCube)
createByTopologyFakeTextureStorage name tex@(TexBuffer {..}) =
createByTopologyTexStorage name tex
createByTopologyTexStorage :: GLuint -> Topology -> IO ()
createByTopologyTexStorage name (Tex1D {..}) =
withBinding GL_TEXTURE_1D GL_TEXTURE_BINDING_1D name $
glTexStorage1D GL_TEXTURE_1D
(safeFromIntegral num_mipmaps)
(toConstantIF (imageFormat spec))
(safeFromIntegral width1D)
createByTopologyTexStorage name (Tex2D {..}) =
withBinding GL_TEXTURE_2D GL_TEXTURE_BINDING_2D name $
glTexStorage2D GL_TEXTURE_2D
(safeFromIntegral num_mipmaps)
(toConstantIF (imageFormat spec))
(safeFromIntegral width2D)
(safeFromIntegral height2D)
createByTopologyTexStorage name (Tex3D {..}) =
withBinding GL_TEXTURE_3D GL_TEXTURE_BINDING_3D name $
glTexStorage3D GL_TEXTURE_3D
(safeFromIntegral num_mipmaps)
(toConstantIF (imageFormat spec))
(safeFromIntegral width3D)
(safeFromIntegral height3D)
(safeFromIntegral depth3D)
createByTopologyTexStorage name (Tex1DArray {..}) =
withBinding GL_TEXTURE_1D_ARRAY GL_TEXTURE_BINDING_1D_ARRAY name $
glTexStorage2D GL_TEXTURE_1D_ARRAY
(safeFromIntegral num_mipmaps)
(toConstantIF (imageFormat spec))
(safeFromIntegral width1DArray)
(safeFromIntegral layers1D)
createByTopologyTexStorage name (Tex2DArray {..}) =
withBinding GL_TEXTURE_2D_ARRAY GL_TEXTURE_BINDING_2D_ARRAY name $
glTexStorage3D GL_TEXTURE_2D_ARRAY
(safeFromIntegral num_mipmaps)
(toConstantIF (imageFormat spec))
(safeFromIntegral width2DArray)
(safeFromIntegral height2DArray)
(safeFromIntegral layers2D)
createByTopologyTexStorage name (Tex2DMultisample {..}) =
checkOpenGLOrExtensionM (OpenGLVersion 3 2)
"GL_ARB_texture_multisample"
gl_ARB_texture_multisample $
withBinding GL_TEXTURE_2D_MULTISAMPLE
GL_TEXTURE_BINDING_2D_MULTISAMPLE
name $
glTexImage2DMultisample
GL_TEXTURE_2D_MULTISAMPLE
(safeFromIntegral samples2DMS)
(fromIntegral $ toConstantIF (imageFormat spec))
(safeFromIntegral width2DMS)
(safeFromIntegral height2DMS)
(if fixedSampleLocations2DMS
then 1 else 0)
createByTopologyTexStorage name (Tex2DMultisampleArray {..}) =
checkOpenGLOrExtensionM (OpenGLVersion 3 2)
"GL_ARB_texture_multisample"
gl_ARB_texture_multisample $
withBinding GL_TEXTURE_2D_MULTISAMPLE_ARRAY
GL_TEXTURE_BINDING_2D_MULTISAMPLE_ARRAY
name $
glTexImage3DMultisample
GL_TEXTURE_2D_MULTISAMPLE_ARRAY
(safeFromIntegral samples2DMSArray)
(fromIntegral $ toConstantIF (imageFormat spec))
(safeFromIntegral width2DMSArray)
(safeFromIntegral height2DMSArray)
(safeFromIntegral layers2DMS)
(if fixedSampleLocations2DMSArray
then 1 else 0)
createByTopologyTexStorage name (TexCube {..}) =
withBinding GL_TEXTURE_CUBE_MAP
GL_TEXTURE_BINDING_CUBE_MAP
name $
glTexStorage2D GL_TEXTURE_CUBE_MAP
(safeFromIntegral num_mipmaps)
(fromIntegral $ toConstantIF (imageFormat spec))
(safeFromIntegral widthCube)
(safeFromIntegral widthCube)
createByTopologyTexStorage name (TexBuffer {..}) =
checkOpenGLOrExtensionM (OpenGLVersion 3 1)
"GL_ARB_texture_buffer_object"
gl_ARB_texture_buffer_object $
withBinding GL_TEXTURE_BUFFER
GL_TEXTURE_BINDING_BUFFER
name $
withResource (Buf.resource texBuffer) $ \(Buf.Buffer_ bufname) ->
glTexBuffer GL_TEXTURE_BUFFER
(fromIntegral $ toConstantIF (imageFormat spec))
bufname
generateMipmaps :: (MonadIO m, MonadMask m) => Texture -> m ()
generateMipmaps = flip withBindingByTopology glGenerateMipmap
data UploadFormat =
UR
| URG
| URGB
| URGBA
| UBGR
| UBGRA
| UDEPTH_COMPONENT
| USTENCIL_INDEX
deriving ( Eq, Ord, Show, Read, Typeable, Data, Generic )
toConstantUF :: UploadFormat -> GLenum
toConstantUF UR = GL_RED
toConstantUF URG = GL_RG
toConstantUF URGB = GL_RGB
toConstantUF URGBA = GL_RGBA
toConstantUF UBGR = GL_BGR
toConstantUF UBGRA = GL_BGRA
toConstantUF UDEPTH_COMPONENT = GL_DEPTH_COMPONENT
toConstantUF USTENCIL_INDEX = GL_STENCIL_INDEX
data Uploading = Uploading
{ fromBuffer :: !Buf.Buffer
, bufferOffset :: !Int
, toMipmapLevel :: !Int
, specificationType :: !SpecificationType
, uploadFormat :: !UploadFormat
, xOffset :: !Int
, yOffset :: !Int
, zOffset :: !Int
, uWidth :: !Int
, uHeight :: !Int
, uDepth :: !Int
, cubeSide :: CubeSide
, numColumns :: !Int
, numRows :: !Int
, pixelAlignment :: !Int
}
deriving ( Eq, Typeable )
data CubeSide =
PositiveY
| NegativeY
| PositiveX
| NegativeX
| PositiveZ
| NegativeZ
deriving ( Eq, Ord, Show, Read, Typeable, Data, Generic )
toConstantCS :: CubeSide -> GLenum
toConstantCS PositiveX = GL_TEXTURE_CUBE_MAP_POSITIVE_X
toConstantCS NegativeX = GL_TEXTURE_CUBE_MAP_NEGATIVE_X
toConstantCS PositiveY = GL_TEXTURE_CUBE_MAP_POSITIVE_Y
toConstantCS NegativeY = GL_TEXTURE_CUBE_MAP_NEGATIVE_Y
toConstantCS PositiveZ = GL_TEXTURE_CUBE_MAP_POSITIVE_Z
toConstantCS NegativeZ = GL_TEXTURE_CUBE_MAP_NEGATIVE_Z
uploading1D :: Buf.Buffer
-> Int
-> SpecificationType
-> UploadFormat
-> Uploading
uploading1D buffer pixels stype uf =
Uploading {
fromBuffer = buffer
, bufferOffset = 0
, specificationType = stype
, uploadFormat = uf
, toMipmapLevel = 0
, xOffset = 0
, yOffset = 0
, zOffset = 0
, uWidth = pixels
, uHeight = 1
, uDepth = 1
, numColumns = pixels
, cubeSide = PositiveY
, numRows = 1
, pixelAlignment = 1 }
uploading2D :: Buf.Buffer
-> Int
-> Int
-> SpecificationType
-> UploadFormat
-> Uploading
uploading2D buffer width height stype uf =
Uploading {
fromBuffer = buffer
, bufferOffset = 0
, specificationType = stype
, uploadFormat = uf
, toMipmapLevel = 0
, xOffset = 0
, yOffset = 0
, zOffset = 0
, uWidth = width
, uHeight = height
, uDepth = 1
, numColumns = width
, cubeSide = PositiveY
, numRows = height
, pixelAlignment = 1 }
uploading3D :: Buf.Buffer
-> Int
-> Int
-> Int
-> SpecificationType
-> UploadFormat
-> Uploading
uploading3D buffer width height depth stype uf =
Uploading {
fromBuffer = buffer
, bufferOffset = 0
, specificationType = stype
, uploadFormat = uf
, toMipmapLevel = 0
, xOffset = 0
, yOffset = 0
, zOffset = 0
, uWidth = width
, uHeight = height
, uDepth = depth
, numColumns = width
, cubeSide = PositiveY
, numRows = height
, pixelAlignment = 1 }
uploadToTexture :: MonadIO m
=> Uploading
-> Texture
-> m ()
uploadToTexture uploading tex = liftIO $ mask_ $
withResource (Buf.resource (fromBuffer uploading)) $ \(Buf.Buffer_ buf) ->
withBoundPixelUnpackBuffer buf $ do
old_num_cols <- fromIntegral <$> gi GL_UNPACK_ROW_LENGTH
old_num_rows <- fromIntegral <$> gi GL_UNPACK_IMAGE_HEIGHT
old_alignment <- fromIntegral <$> gi GL_UNPACK_ALIGNMENT
glPixelStorei GL_UNPACK_ROW_LENGTH
(safeFromIntegral $ numColumns uploading)
flip finally (glPixelStorei GL_UNPACK_ROW_LENGTH old_num_cols) $ do
glPixelStorei GL_UNPACK_IMAGE_HEIGHT
(safeFromIntegral $ numRows uploading)
flip finally (glPixelStorei GL_UNPACK_IMAGE_HEIGHT old_num_rows) $ do
glPixelStorei GL_UNPACK_ALIGNMENT
(safeFromIntegral $ pixelAlignment uploading)
flip finally (glPixelStorei GL_UNPACK_ALIGNMENT old_alignment) $
withResource (resource tex) $ \(Texture_ texname) ->
case topology $ viewSpecification tex of
Tex1D {..} ->
upload1D GL_TEXTURE_1D GL_TEXTURE_BINDING_1D
texname uploading
Tex2D {..} ->
upload2D GL_TEXTURE_2D GL_TEXTURE_BINDING_2D
texname uploading
Tex3D {..} ->
upload3D GL_TEXTURE_3D GL_TEXTURE_BINDING_3D
texname uploading
Tex1DArray {..} ->
upload2D GL_TEXTURE_1D_ARRAY GL_TEXTURE_BINDING_1D_ARRAY
texname uploading
Tex2DArray {..} ->
upload3D GL_TEXTURE_2D_ARRAY GL_TEXTURE_BINDING_2D_ARRAY
texname uploading
Tex2DMultisample {..} ->
error $ "uploadToTexture: cannot upload to " <>
"multisampling textures."
Tex2DMultisampleArray {..} ->
error $ "uploadToTexture: cannot upload to " <>
"multisampling array textures."
TexCube {..} ->
uploadCube GL_TEXTURE_CUBE_MAP
GL_TEXTURE_BINDING_CUBE_MAP
texname uploading
TexBuffer {..} ->
error $ "uploadToTexture: cannot upload to " <>
"buffer textures. (please upload directly to the " <>
"associated buffer instead.)"
upload1D :: GLenum -> GLenum -> GLuint -> Uploading -> IO ()
upload1D target binding tex (Uploading {..}) =
withBinding target binding tex $
glTexSubImage1D target
(safeFromIntegral toMipmapLevel)
(safeFromIntegral xOffset)
(safeFromIntegral uWidth)
(toConstantUF uploadFormat)
(toConstantST specificationType)
(intPtrToPtr $
fromIntegral bufferOffset)
upload2D :: GLenum -> GLenum -> GLuint -> Uploading -> IO ()
upload2D target binding tex (Uploading {..}) =
withBinding target binding tex $
glTexSubImage2D target
(safeFromIntegral toMipmapLevel)
(safeFromIntegral xOffset)
(safeFromIntegral yOffset)
(safeFromIntegral uWidth)
(safeFromIntegral uHeight)
(toConstantUF uploadFormat)
(toConstantST specificationType)
(intPtrToPtr $
fromIntegral bufferOffset)
upload3D :: GLenum -> GLenum -> GLuint -> Uploading -> IO ()
upload3D target binding tex (Uploading {..}) =
withBinding target binding tex $
glTexSubImage3D target
(safeFromIntegral toMipmapLevel)
(safeFromIntegral xOffset)
(safeFromIntegral yOffset)
(safeFromIntegral zOffset)
(safeFromIntegral uWidth)
(safeFromIntegral uHeight)
(safeFromIntegral uDepth)
(toConstantUF uploadFormat)
(toConstantST specificationType)
(intPtrToPtr $
fromIntegral bufferOffset)
uploadCube :: GLenum -> GLenum -> GLuint -> Uploading -> IO ()
uploadCube target binding tex (Uploading {..}) =
withBinding target binding tex $
glTexSubImage2D (toConstantCS cubeSide)
(safeFromIntegral toMipmapLevel)
(safeFromIntegral xOffset)
(safeFromIntegral yOffset)
(safeFromIntegral uWidth)
(safeFromIntegral uHeight)
(toConstantUF uploadFormat)
(toConstantST specificationType)
(intPtrToPtr $
fromIntegral bufferOffset)
isValidMipmap :: Int -> Int -> Bool
isValidMipmap w level
| w <= 0 = False
| level < 0 = False
| level > floor (logBase (2 :: Double) (fromIntegral w)) + 1 = False
| otherwise = True
maxMipmapLevels :: Int -> Int
maxMipmapLevels width
| width <= 0 = 0
| otherwise = floor (logBase (2 :: Double) (fromIntegral width)) + 1
class TexParam a where
tpEnum :: a -> GLenum
tpToConstant :: a -> GLenum
tpFromConstant :: GLenum -> a
data MinFilter =
MiNearest
| MiLinear
| MiNearestMipmapNearest
| MiLinearMipmapNearest
| MiNearestMipmapLinear
| MiLinearMipmapLinear
deriving ( Eq, Ord, Show, Read, Typeable, Data, Generic, Enum )
data MagFilter =
MaNearest
| MaLinear
deriving ( Eq, Ord, Show, Read, Typeable, Data, Generic, Enum )
data Wrapping =
Clamp
| Repeat
deriving ( Eq, Ord, Show, Read, Typeable, Data, Generic, Enum )
data CompareMode
= NoCompare
| CompareRefToTexture
deriving ( Eq, Ord, Show, Read, Typeable, Data, Generic, Enum )
toConstantC :: CompareMode -> GLenum
toConstantC NoCompare = GL_NONE
toConstantC CompareRefToTexture = GL_COMPARE_REF_TO_TEXTURE
toConstantW :: Wrapping -> GLenum
toConstantW Clamp = GL_CLAMP_TO_EDGE
toConstantW Repeat = GL_REPEAT
instance TexParam MinFilter where
tpEnum _ = GL_TEXTURE_MIN_FILTER
tpToConstant MiNearest = GL_NEAREST
tpToConstant MiLinear = GL_LINEAR
tpToConstant MiNearestMipmapNearest = GL_NEAREST_MIPMAP_NEAREST
tpToConstant MiLinearMipmapNearest = GL_LINEAR_MIPMAP_NEAREST
tpToConstant MiNearestMipmapLinear = GL_NEAREST_MIPMAP_LINEAR
tpToConstant MiLinearMipmapLinear = GL_LINEAR_MIPMAP_LINEAR
tpFromConstant c
| c == GL_NEAREST = MiNearest
| c == GL_LINEAR = MiLinear
| c == GL_NEAREST_MIPMAP_NEAREST = MiNearestMipmapNearest
| c == GL_LINEAR_MIPMAP_NEAREST = MiLinearMipmapNearest
| c == GL_NEAREST_MIPMAP_LINEAR = MiNearestMipmapLinear
| c == GL_LINEAR_MIPMAP_LINEAR = MiLinearMipmapLinear
| otherwise = error "MinFilter: unexpected filtering value."
instance TexParam MagFilter where
tpEnum _ = GL_TEXTURE_MAG_FILTER
tpToConstant MaNearest = GL_NEAREST
tpToConstant MaLinear = GL_LINEAR
tpFromConstant c
| c == GL_NEAREST = MaNearest
| c == GL_LINEAR = MaLinear
| otherwise = error "MagFilter: unexpected filtering value."
setMinFilter :: (MonadIO m, MonadMask m) => MinFilter -> Texture -> m ()
setMinFilter = setTexParam
setMagFilter :: (MonadIO m, MonadMask m) => MagFilter -> Texture -> m ()
setMagFilter = setTexParam
getMinFilter :: MonadIO m => Texture -> m MinFilter
getMinFilter = getTexParam
getMagFilter :: MonadIO m => Texture -> m MagFilter
getMagFilter = getTexParam
setTexParam :: (MonadIO m, MonadMask m, TexParam a) => a -> Texture -> m ()
setTexParam param tex = withBindingByTopology tex $ \target ->
glTexParameteri target (tpEnum param) (fromIntegral $ tpToConstant param)
getTexParam :: forall m a. (MonadIO m, TexParam a) => Texture -> m a
getTexParam tex = liftIO $ withBindingByTopology tex $ \target ->
alloca $ \result_ptr -> do
glGetTexParameteriv target (tpEnum (undefined :: a)) result_ptr
tpFromConstant . fromIntegral <$> peek result_ptr
setWrapping :: (MonadIO m, MonadMask m) => Wrapping -> Texture -> m ()
setWrapping wrapping tex = withBindingByTopology tex $ \target -> do
glTexParameteri target GL_TEXTURE_WRAP_S
(fromIntegral $ toConstantW wrapping)
glTexParameteri target GL_TEXTURE_WRAP_T
(fromIntegral $ toConstantW wrapping)
glTexParameteri target GL_TEXTURE_WRAP_R
(fromIntegral $ toConstantW wrapping)
setCompareMode :: (MonadIO m, MonadMask m) => CompareMode -> Texture -> m ()
setCompareMode cmp_mode tex = withBindingByTopology tex $ \target ->
glTexParameteri target GL_TEXTURE_COMPARE_MODE
(fromIntegral $ toConstantC cmp_mode)
getCompareMode :: (MonadIO m, MonadMask m) => Texture -> m CompareMode
getCompareMode tex = liftIO $ withBindingByTopology tex $ \target ->
alloca $ \result_ptr -> do
glGetTexParameteriv target GL_TEXTURE_COMPARE_MODE result_ptr
result <- peek result_ptr
return $ if
| result == GL_NONE -> NoCompare
| result == GL_COMPARE_REF_TO_TEXTURE -> CompareRefToTexture
| otherwise -> error "getCompareMode: unexpected comparing mode."
getWrapping :: (MonadIO m, MonadMask m) => Texture -> m Wrapping
getWrapping tex = liftIO $ withBindingByTopology tex $ \target ->
alloca $ \result_ptr -> do
glGetTexParameteriv target GL_TEXTURE_WRAP_S result_ptr
result <- peek result_ptr
return $ if
| result == GL_CLAMP_TO_EDGE -> Clamp
| result == GL_REPEAT -> Repeat
| otherwise -> error "getWrapping: unexpected wrapping mode."
setAnisotropy :: (MonadIO m, MonadMask m) => Float -> Texture -> m ()
setAnisotropy ani tex = withBindingByTopology tex $ \target ->
glTexParameterf target GL_TEXTURE_MAX_ANISOTROPY_EXT ani
getAnisotropy :: (MonadIO m, MonadMask m) => Texture -> m Float
getAnisotropy tex = liftIO $ withBindingByTopology tex $ \target ->
alloca $ \ani_ptr -> do
glGetTexParameterfv target GL_TEXTURE_MAX_ANISOTROPY_EXT ani_ptr
peek ani_ptr