module Graphics.GLUtil.Textures where
import Control.Monad (forM_)
import Graphics.Rendering.OpenGL
import qualified Graphics.Rendering.OpenGL.GL.VertexArrays as GL
import Graphics.Rendering.OpenGL.Raw.Core31 (glGenerateMipmap,
gl_TEXTURE_2D, gl_TEXTURE_CUBE_MAP)
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)
import Foreign.Marshal.Array (withArray)
import Graphics.GLUtil.TypeMapping (HasGLType(..))
data TexColor = TexMono | 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)
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
_ -> loadAux Luminance' Luminance
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 Nothing 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 :: TextureTarget -> [TextureObject] -> IO a -> IO a
withTextures tt ts m = do mapM_ aux (zip ts [0..])
r <- m
cleanup 0 ts
return r
where aux (t,i) = do activeTexture $= TextureUnit i
textureBinding tt $= Just t
cleanup _ [] = return ()
cleanup i (_:ts') = do activeTexture $= TextureUnit i
textureBinding Texture2D $= Nothing
cleanup (i+1) ts'
withTextures2D :: [TextureObject] -> IO a -> IO a
withTextures2D = withTextures Texture2D
generateMipmap' :: TextureTarget -> IO ()
generateMipmap' Texture2D = glGenerateMipmap gl_TEXTURE_2D
generateMipmap' TextureCubeMap = glGenerateMipmap gl_TEXTURE_CUBE_MAP
generateMipmap' _ = error $ "generateMipmap' is only defined for "++
"2D textures and cube maps."