--------------------------------------------------------------------------------
-- |
-- Module      :  Graphics.Rendering.OpenGL.GL.Texturing.Objects
-- Copyright   :  (c) Sven Panne 2002-2019
-- License     :  BSD3
--
-- Maintainer  :  Sven Panne <svenpanne@gmail.com>
-- Stability   :  stable
-- Portability :  portable
--
-- This module corresponds to section 3.8.12 (Texture Objects) of the OpenGL 2.1
-- specs.
--
--------------------------------------------------------------------------------

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

--------------------------------------------------------------------------------

-- | Generate mipmaps for the specified texture target. Note that from OpenGL
-- 3.1 onwards you should use this function instead of the texture parameter
-- 'Graphics.Rendering.OpenGL.GL.Texturing.Parameters.generateMipmap'.

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