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
, maxMipmapLevels )
where
import Graphics.Caramia.Prelude
import Graphics.Caramia.Texture.Internal
import Graphics.Caramia.Internal.TexStorage
import Graphics.Caramia.Internal.OpenGLCApi
import qualified Graphics.Caramia.Buffer.Internal as Buf
import Graphics.Caramia.ImageFormats.Internal
import Graphics.Caramia.Resource
import Control.Exception
import Foreign
import Foreign.C.Types
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."
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 :: TextureSpecification
-> IO Texture
newTexture spec = 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 <- atomicModifyIORef' ordIndices $ \old -> ( old+1, old )
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
has_tex_storage <- has_GL_ARB_texture_storage
if has_tex_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 {..}) =
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 {..}) =
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 {..}) =
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 :: Texture -> IO ()
generateMipmaps = flip withBindingByTopology glGenerateMipmap
data UploadFormat =
UR
| URG
| URGB
| URGBA
| UBGR
| UBGRA
| UDEPTH_COMPONENT
| USTENCIL_INDEX
deriving ( Eq, Ord, Show, Read, Typeable )
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 )
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 :: Uploading
-> Texture
-> IO ()
uploadToTexture uploading tex = 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 MagFilter =
MaNearest
| MaLinear
deriving ( Eq, Ord, Show, Read, Typeable )
data Wrapping =
Clamp
| Repeat
deriving ( Eq, Ord, Show, Read, Typeable )
data CompareMode
= NoCompare
| CompareRefToTexture
deriving ( Eq, Ord, Show, Read, Typeable )
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 :: MinFilter -> Texture -> IO ()
setMinFilter = setTexParam
setMagFilter :: MagFilter -> Texture -> IO ()
setMagFilter = setTexParam
getMinFilter :: Texture -> IO MinFilter
getMinFilter = getTexParam
getMagFilter :: Texture -> IO MagFilter
getMagFilter = getTexParam
setTexParam :: TexParam a => a -> Texture -> IO ()
setTexParam param tex = withBindingByTopology tex $ \target ->
glTexParameteri target (tpEnum param) (fromIntegral $ tpToConstant param)
getTexParam :: forall a. TexParam a => Texture -> IO a
getTexParam tex = withBindingByTopology tex $ \target ->
alloca $ \result_ptr -> do
glGetTexParameteriv target (tpEnum (undefined :: a)) result_ptr
tpFromConstant . fromIntegral <$> peek result_ptr
setWrapping :: Wrapping -> Texture -> IO ()
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 :: CompareMode -> Texture -> IO ()
setCompareMode cmp_mode tex = withBindingByTopology tex $ \target ->
glTexParameteri target gl_TEXTURE_COMPARE_MODE
(fromIntegral $ toConstantC cmp_mode)
getCompareMode :: Texture -> IO CompareMode
getCompareMode tex = withBindingByTopology tex $ \target ->
alloca $ \result_ptr -> do
glGetTexParameteriv target gl_TEXTURE_COMPARE_MODE result_ptr
result <- fromIntegral <$> peek result_ptr
return $ if
| result == gl_NONE -> NoCompare
| result == gl_COMPARE_REF_TO_TEXTURE -> CompareRefToTexture
| otherwise -> error "getCompareMode: unexpected comparing mode."
getWrapping :: Texture -> IO Wrapping
getWrapping tex = withBindingByTopology tex $ \target ->
alloca $ \result_ptr -> do
glGetTexParameteriv target gl_TEXTURE_WRAP_S result_ptr
result <- fromIntegral <$> peek result_ptr
return $ if
| result == gl_CLAMP_TO_EDGE -> Clamp
| result == gl_REPEAT -> Repeat
| otherwise -> error "getWrapping: unexpected wrapping mode."
setAnisotropy :: Float -> Texture -> IO ()
setAnisotropy ani tex = withBindingByTopology tex $ \target ->
glTexParameterf target gl_TEXTURE_MAX_ANISOTROPY_EXT (CFloat ani)
getAnisotropy :: Texture -> IO Float
getAnisotropy tex = withBindingByTopology tex $ \target ->
alloca $ \ani_ptr -> do
glGetTexParameterfv target gl_TEXTURE_MAX_ANISOTROPY_EXT ani_ptr
unwrap <$> peek ani_ptr
where
unwrap (CFloat f) = f