module Graphics.GLUtil.Textures where
import Control.Monad (forM_)
import Graphics.Rendering.OpenGL
import qualified Graphics.Rendering.OpenGL.GL.VertexArrays as GL
import Data.Array.Storable (StorableArray, withStorableArray)
import Data.ByteString.Internal (ByteString, toForeignPtr)
import Data.Vector.Storable (Vector, unsafeWith)
import Data.Word (Word8, Word16)
import Foreign.ForeignPtr (ForeignPtr, withForeignPtr)
import Foreign.Ptr (Ptr, plusPtr, castPtr, nullPtr)
import Foreign.Marshal.Array (withArray)
import Graphics.GLUtil.TypeMapping (HasGLType(..))
data TexColor = TexMono | TexRG | TexRGB | TexBGR | TexRGBA
data TexInfo a = TexInfo { texWidth :: GLsizei
, texHeight :: GLsizei
, texColor :: TexColor
, texData :: a }
texInfo :: Int -> Int -> TexColor -> a -> TexInfo a
texInfo w h = TexInfo (fromIntegral w) (fromIntegral h)
class HasGLType (Elem a) => IsPixelData a where
type Elem a
withPixels :: a -> (Ptr (Elem a) -> IO c) -> IO c
instance HasGLType b => IsPixelData [b] where
type Elem [b] = b
withPixels = withArray
instance HasGLType b => IsPixelData (Ptr b) where
type Elem (Ptr b) = b
withPixels = flip ($)
instance HasGLType b => IsPixelData (ForeignPtr b) where
type Elem (ForeignPtr b) = b
withPixels = withForeignPtr
instance HasGLType b => IsPixelData (StorableArray i b) where
type Elem (StorableArray i b) = b
withPixels = withStorableArray
instance HasGLType b => IsPixelData (Vector b) where
type Elem (Vector b) = b
withPixels = unsafeWith
instance IsPixelData ByteString where
type Elem ByteString = Word8
withPixels b m = aux . toForeignPtr $ b
where aux (fp,o,_) = withForeignPtr fp $ \p ->
m (plusPtr p o)
newtype ShortString = ShortString ByteString
instance IsPixelData ShortString where
type Elem ShortString = Word16
withPixels (ShortString b) m = aux. toForeignPtr $ b
where aux (fp,o,_) = withForeignPtr fp $ \p ->
m (plusPtr (castPtr p :: Ptr Word16) o)
freshTexture :: forall a proxy. HasGLType a
=> Int -> Int -> TexColor -> proxy a -> IO TextureObject
freshTexture w h c _ = loadTexture $ texInfo w h c (nullPtr::Ptr a)
freshTextureWord8 :: Int -> Int -> TexColor -> IO TextureObject
freshTextureWord8 w h c = loadTexture $ texInfo w h c (nullPtr::Ptr Word8)
freshTextureFloat :: Int -> Int -> TexColor -> IO TextureObject
freshTextureFloat w h c = loadTexture $ texInfo w h c (nullPtr::Ptr GLfloat)
loadTexture :: IsPixelData a => TexInfo a -> IO TextureObject
loadTexture tex = do [obj] <- genObjectNames 1
reloadTexture obj tex
return obj
reloadTexture :: forall a. IsPixelData a =>
TextureObject -> TexInfo a -> IO ()
reloadTexture obj tex = do textureBinding Texture2D $= Just obj
loadTex $ texColor tex
where loadTex TexMono = case pixelType of
GL.UnsignedShort -> loadAux Luminance16 Luminance
GL.Float -> loadAux R32F Red
GL.HalfFloat -> loadAux R16F Red
GL.UnsignedByte -> loadAux R8 Red
_ -> loadAux Luminance' Luminance
loadTex TexRG = case pixelType of
GL.UnsignedShort -> loadAux RG16 RGInteger
GL.Float -> loadAux RG32F RG
GL.HalfFloat -> loadAux RG16F RG
GL.UnsignedByte -> loadAux RG8UI RGInteger
GL.Byte -> loadAux RG8I RGInteger
GL.Int -> loadAux RG32I RGInteger
GL.UnsignedInt -> loadAux RG32UI RGInteger
_ -> error "Unknown pixelType for TexRG"
loadTex TexRGB = loadAux RGBA' RGB
loadTex TexBGR = loadAux RGBA' BGR
loadTex TexRGBA = loadAux RGBA' RGBA
sz = TextureSize2D (texWidth tex) (texHeight tex)
pixelType = glType (undefined::Elem a)
loadAux i e = withPixels (texData tex) $
(texImage2D Texture2D NoProxy 0 i sz 0 .
PixelData e pixelType)
texture2DWrap :: StateVar (Repetition, Clamping)
texture2DWrap = makeStateVar (get (textureWrapMode Texture2D S))
(forM_ [S,T] . aux)
where aux x d = textureWrapMode Texture2D d $= x
texture3DWrap :: StateVar (Repetition, Clamping)
texture3DWrap = makeStateVar (get (textureWrapMode Texture2D S))
(forM_ [S,T,R] . aux)
where aux x d = textureWrapMode Texture2D d $= x
withTextures :: BindableTextureTarget t => t -> [TextureObject] -> IO a -> IO a
withTextures tt ts m = do mapM_ aux (zip ts [0..])
r <- m
cleanup 0 ts
activeTexture $= TextureUnit 0
return r
where aux (t,i) = do activeTexture $= TextureUnit i
textureBinding tt $= Just t
cleanup _ [] = return ()
cleanup i (_:ts') = do activeTexture $= TextureUnit i
textureBinding tt $= Nothing
cleanup (i+1) ts'
withTextures2D :: [TextureObject] -> IO a -> IO a
withTextures2D = withTextures Texture2D
withTexturesAt :: BindableTextureTarget t
=> t -> [(TextureObject,GLuint)] -> IO a -> IO a
withTexturesAt tt ts m = do mapM_ aux ts
r <- m
mapM_ (cleanup . snd) ts
return r
where aux (t,i) = do activeTexture $= TextureUnit i
textureBinding tt $= Just t
cleanup i = do activeTexture $= TextureUnit i
textureBinding tt $= Nothing