module Graphics.Luminance.Core.Texture where
import Control.Monad ( when )
import Control.Monad.IO.Class ( MonadIO(..) )
import Control.Monad.Trans.Resource ( MonadResource, register )
import Data.Foldable ( toList )
import Data.Proxy ( Proxy(..) )
import Foreign.Marshal.Alloc ( alloca )
import Foreign.Marshal.Array ( withArray )
import Foreign.Marshal.Utils ( with )
import Foreign.Ptr ( castPtr )
import Foreign.Storable ( Storable(peek) )
import Graphics.GL
import Graphics.GL.Ext.ARB.BindlessTexture
import Graphics.Luminance.Core.Pixel
import Numeric.Natural ( Natural )
data Wrap
= ClampToEdge
| ClampToBorder
| Repeat
deriving (Eq,Show)
fromWrap :: (Eq a,Num a) => Wrap -> a
fromWrap w = case w of
ClampToEdge -> GL_CLAMP_TO_EDGE
ClampToBorder -> GL_CLAMP_TO_BORDER
Repeat -> GL_REPEAT
data Filter
= Nearest
| Linear
deriving (Eq,Show)
fromFilter :: (Eq a,Num a) => Filter -> a
fromFilter f = case f of
Nearest -> GL_NEAREST
Linear -> GL_LINEAR
data CompareFunc
= Never
| Less
| Equal
| LessOrEqual
| Greater
| GreaterOrEqual
| NotEqual
| Always
deriving (Eq,Show)
fromCompareFunc :: (Eq a,Num a) => CompareFunc -> a
fromCompareFunc f = case f of
Never -> GL_NEVER
Less -> GL_LESS
Equal -> GL_EQUAL
LessOrEqual -> GL_LEQUAL
Greater -> GL_GREATER
GreaterOrEqual -> GL_GEQUAL
NotEqual -> GL_NOTEQUAL
Always -> GL_ALWAYS
data Texture2D f = Texture2D {
textureID :: GLuint
, textureHandle :: GLuint64
, textureW :: GLsizei
, textureH :: GLsizei
, textureFormat :: GLenum
, textureType :: GLenum
} deriving (Eq,Show)
createTexture :: forall p m. (Pixel p,MonadIO m,MonadResource m)
=> Natural
-> Natural
-> Natural
-> Sampling
-> m (Texture2D p)
createTexture w h mipmaps sampling = do
(tid,texH) <- liftIO . alloca $ \p -> do
glCreateTextures GL_TEXTURE_2D 1 p
tid <- peek p
glTextureStorage2D tid (fromIntegral mipmaps) ift w' h'
glTextureParameteri tid GL_TEXTURE_BASE_LEVEL 0
glTextureParameteri tid GL_TEXTURE_MAX_LEVEL (fromIntegral mipmaps 1)
setTextureSampling tid sampling
texH <- glGetTextureHandleARB tid
glMakeTextureHandleResidentARB texH
pure (tid,texH)
_ <- register $ do
glMakeTextureHandleNonResidentARB texH
with tid $ glDeleteTextures 1
pure $ Texture2D tid texH w' h' ft typ
where
ft = pixelFormat (Proxy :: Proxy p)
ift = pixelIFormat (Proxy :: Proxy p)
typ = pixelType (Proxy :: Proxy p)
w' = fromIntegral w
h' = fromIntegral h
newtype Sampler = Sampler { samplerID :: GLuint } deriving (Eq,Show)
data Sampling = Sampling {
samplingWrapS :: Wrap
, samplingWrapT :: Wrap
, samplingWrapR :: Wrap
, samplingMinFilter :: Filter
, samplingMagFilter :: Filter
, samplingCompareFunction :: Maybe CompareFunc
} deriving (Eq,Show)
defaultSampling :: Sampling
defaultSampling = Sampling {
samplingWrapS = ClampToEdge
, samplingWrapT = ClampToEdge
, samplingWrapR = ClampToEdge
, samplingMinFilter = Linear
, samplingMagFilter = Linear
, samplingCompareFunction = Nothing
}
createSampler :: (MonadIO m,MonadResource m)
=> Sampling
-> m Sampler
createSampler s = do
sid <- liftIO . alloca $ \p -> do
glCreateSamplers 1 p
sid <- peek p
setSamplerSampling sid s
pure sid
_ <- register . with sid $ glDeleteSamplers 1
pure $ Sampler sid
setSampling :: (Eq a,Eq b,MonadIO m,Num a,Num b) => (GLenum -> a -> b -> IO ()) -> GLenum -> Sampling -> m ()
setSampling f objID s = liftIO $ do
f objID GL_TEXTURE_WRAP_S . fromWrap $ samplingWrapS s
f objID GL_TEXTURE_WRAP_T . fromWrap $ samplingWrapT s
f objID GL_TEXTURE_WRAP_R . fromWrap $ samplingWrapR s
f objID GL_TEXTURE_MIN_FILTER . fromFilter $ samplingMinFilter s
f objID GL_TEXTURE_MAG_FILTER . fromFilter $ samplingMagFilter s
case samplingCompareFunction s of
Just cmpf -> do
f objID GL_TEXTURE_COMPARE_FUNC $ fromCompareFunc cmpf
f objID GL_TEXTURE_COMPARE_MODE GL_COMPARE_REF_TO_TEXTURE
Nothing ->
f objID GL_TEXTURE_COMPARE_MODE GL_NONE
setTextureSampling :: (MonadIO m) => GLenum -> Sampling -> m ()
setTextureSampling = setSampling glTextureParameteri
setSamplerSampling :: (MonadIO m) => GLenum -> Sampling -> m ()
setSamplerSampling = setSampling glSamplerParameteri
uploadWhole :: (Foldable f,MonadIO m,PixelBase p ~ a,Storable a)
=> Texture2D p
-> Bool
-> f a
-> m ()
uploadWhole (Texture2D tid _ w h fmt typ) autolvl dat =
liftIO $ do
withArray (toList dat) $ glTextureSubImage2D tid 0 0 0 w h fmt typ . castPtr
when autolvl $ glGenerateTextureMipmap tid
uploadSub :: (Foldable f,MonadIO m,PixelBase p ~ a,Storable a)
=> Texture2D p
-> Int
-> Int
-> Natural
-> Natural
-> Bool
-> f a
-> m ()
uploadSub (Texture2D tid _ _ _ fmt typ) x y w h autolvl dat =
liftIO $ do
withArray (toList dat) $ glTextureSubImage2D tid 0 (fromIntegral x)
(fromIntegral y) (fromIntegral w) (fromIntegral h) fmt typ . castPtr
when autolvl $ glGenerateTextureMipmap tid
fillWhole :: (Foldable f, MonadIO m,PixelBase p ~ a,Storable a)
=> Texture2D p
-> Bool
-> f a
-> m ()
fillWhole tex = fillSub tex 0 0 (fromIntegral $ textureW tex) (fromIntegral $ textureH tex)
fillSub :: (Foldable f,MonadIO m,PixelBase p ~ a,Storable a)
=> Texture2D p
-> Int
-> Int
-> Natural
-> Natural
-> Bool
-> f a
-> m ()
fillSub (Texture2D tid _ _ _ fmt typ) x y w h autolvl filling =
liftIO $ do
withArray (toList filling) $ glClearTexSubImage tid 0 (fromIntegral x)
(fromIntegral y) 0 (fromIntegral w) (fromIntegral h) 1 fmt typ . castPtr
when autolvl $ glGenerateTextureMipmap tid