module Graphics.Rendering.OpenGL.GL.Texturing.Objects (
TextureObject(TextureObject), textureBinding,
textureResident, areTexturesResident,
TexturePriority, texturePriority, prioritizeTextures,
generateMipmap'
) where
import Data.List
import Data.Maybe (fromMaybe)
import Data.StateVar
import Foreign.Marshal.Array
import Graphics.Rendering.OpenGL.GL.GLboolean
import Graphics.Rendering.OpenGL.GL.QueryUtils
import Graphics.Rendering.OpenGL.GL.Texturing.TexParameter
import Graphics.Rendering.OpenGL.GL.Texturing.TextureObject
import Graphics.Rendering.OpenGL.GL.Texturing.TextureTarget
import Graphics.GL
textureBinding :: BindableTextureTarget t => t -> StateVar (Maybe TextureObject)
textureBinding :: t -> StateVar (Maybe TextureObject)
textureBinding t :: t
t =
IO (Maybe TextureObject)
-> (Maybe TextureObject -> IO ()) -> StateVar (Maybe TextureObject)
forall a. IO a -> (a -> IO ()) -> StateVar a
makeStateVar
(do TextureObject
o <- (GLenum -> TextureObject) -> PName1I -> IO TextureObject
forall p a. GetPName1I p => (GLenum -> a) -> p -> IO a
getEnum1 (GLenum -> TextureObject
TextureObject (GLenum -> TextureObject)
-> (GLenum -> GLenum) -> GLenum -> TextureObject
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GLenum -> GLenum
forall a b. (Integral a, Num b) => a -> b
fromIntegral) (t -> PName1I
forall t. BindableTextureTarget t => t -> PName1I
marshalBindableTextureTargetPName1I t
t)
Maybe TextureObject -> IO (Maybe TextureObject)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe TextureObject -> IO (Maybe TextureObject))
-> Maybe TextureObject -> IO (Maybe TextureObject)
forall a b. (a -> b) -> a -> b
$ if TextureObject
o TextureObject -> TextureObject -> Bool
forall a. Eq a => a -> a -> Bool
== TextureObject
defaultTextureObject then Maybe TextureObject
forall a. Maybe a
Nothing else TextureObject -> Maybe TextureObject
forall a. a -> Maybe a
Just TextureObject
o)
(GLenum -> GLenum -> IO ()
forall (m :: * -> *). MonadIO m => GLenum -> GLenum -> m ()
glBindTexture (t -> GLenum
forall t. BindableTextureTarget t => t -> GLenum
marshalBindableTextureTarget t
t) (GLenum -> IO ())
-> (Maybe TextureObject -> GLenum) -> Maybe TextureObject -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TextureObject -> GLenum
textureID (TextureObject -> GLenum)
-> (Maybe TextureObject -> TextureObject)
-> Maybe TextureObject
-> GLenum
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TextureObject -> Maybe TextureObject -> TextureObject
forall a. a -> Maybe a -> a
fromMaybe TextureObject
defaultTextureObject))
defaultTextureObject :: TextureObject
defaultTextureObject :: TextureObject
defaultTextureObject = GLenum -> TextureObject
TextureObject 0
textureResident :: ParameterizedTextureTarget t => t -> GettableStateVar Bool
textureResident :: t -> GettableStateVar Bool
textureResident t :: t
t =
GettableStateVar Bool -> GettableStateVar Bool
forall a. IO a -> IO a
makeGettableStateVar (GettableStateVar Bool -> GettableStateVar Bool)
-> GettableStateVar Bool -> GettableStateVar Bool
forall a b. (a -> b) -> a -> b
$
(GLint -> Bool) -> t -> TexParameter -> GettableStateVar Bool
forall t a.
ParameterizedTextureTarget t =>
(GLint -> a) -> t -> TexParameter -> IO a
getTexParameteri GLint -> Bool
forall a. (Eq a, Num a) => a -> Bool
unmarshalGLboolean t
t TexParameter
TextureResident
areTexturesResident :: [TextureObject] -> IO ([TextureObject],[TextureObject])
areTexturesResident :: [TextureObject] -> IO ([TextureObject], [TextureObject])
areTexturesResident texObjs :: [TextureObject]
texObjs = do
[GLenum]
-> (Int -> Ptr GLenum -> IO ([TextureObject], [TextureObject]))
-> IO ([TextureObject], [TextureObject])
forall a b. Storable a => [a] -> (Int -> Ptr a -> IO b) -> IO b
withArrayLen ((TextureObject -> GLenum) -> [TextureObject] -> [GLenum]
forall a b. (a -> b) -> [a] -> [b]
map TextureObject -> GLenum
textureID [TextureObject]
texObjs) ((Int -> Ptr GLenum -> IO ([TextureObject], [TextureObject]))
-> IO ([TextureObject], [TextureObject]))
-> (Int -> Ptr GLenum -> IO ([TextureObject], [TextureObject]))
-> IO ([TextureObject], [TextureObject])
forall a b. (a -> b) -> a -> b
$ \len :: Int
len texObjsBuf :: Ptr GLenum
texObjsBuf ->
Int
-> (Ptr GLboolean -> IO ([TextureObject], [TextureObject]))
-> IO ([TextureObject], [TextureObject])
forall a b. Storable a => Int -> (Ptr a -> IO b) -> IO b
allocaArray Int
len ((Ptr GLboolean -> IO ([TextureObject], [TextureObject]))
-> IO ([TextureObject], [TextureObject]))
-> (Ptr GLboolean -> IO ([TextureObject], [TextureObject]))
-> IO ([TextureObject], [TextureObject])
forall a b. (a -> b) -> a -> b
$ \residentBuf :: Ptr GLboolean
residentBuf -> do
GLboolean
allResident <-
GLint -> Ptr GLenum -> Ptr GLboolean -> IO GLboolean
forall (m :: * -> *).
MonadIO m =>
GLint -> Ptr GLenum -> Ptr GLboolean -> m GLboolean
glAreTexturesResident (Int -> GLint
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len) Ptr GLenum
texObjsBuf Ptr GLboolean
residentBuf
if GLboolean -> Bool
forall a. (Eq a, Num a) => a -> Bool
unmarshalGLboolean GLboolean
allResident
then ([TextureObject], [TextureObject])
-> IO ([TextureObject], [TextureObject])
forall (m :: * -> *) a. Monad m => a -> m a
return ([TextureObject]
texObjs, [])
else do
[(TextureObject, GLboolean)]
tr <- ([GLboolean] -> [(TextureObject, GLboolean)])
-> IO [GLboolean] -> IO [(TextureObject, GLboolean)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([TextureObject] -> [GLboolean] -> [(TextureObject, GLboolean)]
forall a b. [a] -> [b] -> [(a, b)]
zip [TextureObject]
texObjs) (IO [GLboolean] -> IO [(TextureObject, GLboolean)])
-> IO [GLboolean] -> IO [(TextureObject, GLboolean)]
forall a b. (a -> b) -> a -> b
$ Int -> Ptr GLboolean -> IO [GLboolean]
forall a. Storable a => Int -> Ptr a -> IO [a]
peekArray Int
len Ptr GLboolean
residentBuf
let (resident :: [(TextureObject, GLboolean)]
resident, nonResident :: [(TextureObject, GLboolean)]
nonResident) = ((TextureObject, GLboolean) -> Bool)
-> [(TextureObject, GLboolean)]
-> ([(TextureObject, GLboolean)], [(TextureObject, GLboolean)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (GLboolean -> Bool
forall a. (Eq a, Num a) => a -> Bool
unmarshalGLboolean (GLboolean -> Bool)
-> ((TextureObject, GLboolean) -> GLboolean)
-> (TextureObject, GLboolean)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TextureObject, GLboolean) -> GLboolean
forall a b. (a, b) -> b
snd) [(TextureObject, GLboolean)]
tr
([TextureObject], [TextureObject])
-> IO ([TextureObject], [TextureObject])
forall (m :: * -> *) a. Monad m => a -> m a
return (((TextureObject, GLboolean) -> TextureObject)
-> [(TextureObject, GLboolean)] -> [TextureObject]
forall a b. (a -> b) -> [a] -> [b]
map (TextureObject, GLboolean) -> TextureObject
forall a b. (a, b) -> a
fst [(TextureObject, GLboolean)]
resident, ((TextureObject, GLboolean) -> TextureObject)
-> [(TextureObject, GLboolean)] -> [TextureObject]
forall a b. (a -> b) -> [a] -> [b]
map (TextureObject, GLboolean) -> TextureObject
forall a b. (a, b) -> a
fst [(TextureObject, GLboolean)]
nonResident)
type TexturePriority = GLclampf
texturePriority :: ParameterizedTextureTarget t => t -> StateVar TexturePriority
texturePriority :: t -> StateVar TexturePriority
texturePriority = (TexturePriority -> TexturePriority)
-> (TexturePriority -> TexturePriority)
-> TexParameter
-> t
-> StateVar TexturePriority
forall t a.
ParameterizedTextureTarget t =>
(TexturePriority -> a)
-> (a -> TexturePriority) -> TexParameter -> t -> StateVar a
texParamf TexturePriority -> TexturePriority
forall a b. (Real a, Fractional b) => a -> b
realToFrac TexturePriority -> TexturePriority
forall a b. (Real a, Fractional b) => a -> b
realToFrac TexParameter
TexturePriority
prioritizeTextures :: [(TextureObject,TexturePriority)] -> IO ()
prioritizeTextures :: [(TextureObject, TexturePriority)] -> IO ()
prioritizeTextures tps :: [(TextureObject, TexturePriority)]
tps =
[GLenum] -> (Int -> Ptr GLenum -> IO ()) -> IO ()
forall a b. Storable a => [a] -> (Int -> Ptr a -> IO b) -> IO b
withArrayLen (((TextureObject, TexturePriority) -> GLenum)
-> [(TextureObject, TexturePriority)] -> [GLenum]
forall a b. (a -> b) -> [a] -> [b]
map (TextureObject -> GLenum
textureID (TextureObject -> GLenum)
-> ((TextureObject, TexturePriority) -> TextureObject)
-> (TextureObject, TexturePriority)
-> GLenum
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TextureObject, TexturePriority) -> TextureObject
forall a b. (a, b) -> a
fst) [(TextureObject, TexturePriority)]
tps) ((Int -> Ptr GLenum -> IO ()) -> IO ())
-> (Int -> Ptr GLenum -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \len :: Int
len texObjsBuf :: Ptr GLenum
texObjsBuf ->
[TexturePriority] -> (Ptr TexturePriority -> IO ()) -> IO ()
forall a b. Storable a => [a] -> (Ptr a -> IO b) -> IO b
withArray (((TextureObject, TexturePriority) -> TexturePriority)
-> [(TextureObject, TexturePriority)] -> [TexturePriority]
forall a b. (a -> b) -> [a] -> [b]
map (TextureObject, TexturePriority) -> TexturePriority
forall a b. (a, b) -> b
snd [(TextureObject, TexturePriority)]
tps) ((Ptr TexturePriority -> IO ()) -> IO ())
-> (Ptr TexturePriority -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$
GLint -> Ptr GLenum -> Ptr TexturePriority -> IO ()
forall (m :: * -> *).
MonadIO m =>
GLint -> Ptr GLenum -> Ptr TexturePriority -> m ()
glPrioritizeTextures (Int -> GLint
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len) Ptr GLenum
texObjsBuf
generateMipmap' :: ParameterizedTextureTarget t => t -> IO ()
generateMipmap' :: t -> IO ()
generateMipmap' = GLenum -> IO ()
forall (m :: * -> *). MonadIO m => GLenum -> m ()
glGenerateMipmap (GLenum -> IO ()) -> (t -> GLenum) -> t -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t -> GLenum
forall t. ParameterizedTextureTarget t => t -> GLenum
marshalParameterizedTextureTarget