module Graphics.LambdaCube.RenderSystem.GL.Texture where
import Control.Monad
import Data.Maybe
import Data.Ord
import Foreign
import qualified Data.Set as Set
import Graphics.Rendering.OpenGL.Raw.ARB.Compatibility
import Graphics.Rendering.OpenGL.Raw.Core31
import Graphics.LambdaCube.HardwareBuffer
import Graphics.LambdaCube.Image
import Graphics.LambdaCube.PixelFormat
import Graphics.LambdaCube.RenderSystem.GL.Utils
import Graphics.LambdaCube.RenderSystemCapabilities
import Graphics.LambdaCube.Texture
import Graphics.LambdaCube.Types
data GLTexture
= GLTexture
{ gltxName :: String
, gltxWidth :: Int
, gltxHeight :: Int
, gltxDepth :: Int
, gltxNumRequestedMipmaps :: TextureMipmap
, gltxNumMipmaps :: Int
, gltxMipmapsHardwareGenerated :: Bool
, gltxGamma :: FloatType
, gltxHwGamma :: Bool
, gltxFSAA :: Int
, gltxFSAAHint :: String
, gltxTextureType :: TextureType
, gltxFormat :: PixelFormat
, gltxUsage :: TextureUsage
, gltxSrcFormat :: PixelFormat
, gltxSrcWidth :: Int
, gltxSrcHeight :: Int
, gltxSrcDepth :: Int
, gltxDesiredFormat :: PixelFormat
, gltxDesiredIntegerBitDepth :: Int
, gltxDesiredFloatBitDepth :: Int
, gltxTreatLuminanceAsAlpha :: Bool
, gltxTextureObject :: GLuint
}
instance Eq GLTexture where
x == y = compare x y == EQ
instance Ord GLTexture where
compare = comparing gltxTextureObject
instance HardwareBuffer GLTexture
instance Texture GLTexture where
txName = gltxName
txWidth = gltxWidth
txHeight = gltxHeight
txDepth = gltxDepth
txNumRequestedMipmaps = gltxNumRequestedMipmaps
txNumMipmaps = gltxNumMipmaps
txMipmapsHardwareGenerated = gltxMipmapsHardwareGenerated
txGamma = gltxGamma
txHwGamma = gltxHwGamma
txFSAA = gltxFSAA
txFSAAHint = gltxFSAAHint
txTextureType = gltxTextureType
txFormat = gltxFormat
txSrcFormat = gltxSrcFormat
txSrcWidth = gltxSrcWidth
txSrcHeight = gltxSrcHeight
txSrcDepth = gltxSrcDepth
txDesiredFormat = gltxDesiredFormat
txDesiredIntegerBitDepth = gltxDesiredIntegerBitDepth
txDesiredFloatBitDepth = gltxDesiredFloatBitDepth
txTreatLuminanceAsAlpha = gltxTreatLuminanceAsAlpha
mkGLTexture :: RenderSystemCapabilities -> String -> TextureType -> Int -> Int -> Int -> TextureMipmap -> PixelFormat -> TextureUsage -> Bool -> Int -> String -> Maybe [Image] -> IO GLTexture
mkGLTexture rcaps name texType width height depth numMips format usage hwGammaCorrection _fsaa _fsaaHint mimage = do
let caps = rscCapabilities rcaps
putStrLn $ "createTexture " ++ "create " ++ show texType ++ " texture: " ++ name
when (texType == TEX_TYPE_3D && Set.notMember RSC_TEXTURE_3D caps) $ error "3D Textures not supported before OpenGL 1.2"
(major,minor) <- getGLVersion
let glVer a b = major > a || (major >= a && minor >= b)
texTarget = (getGLTextureTarget texType)
mWidth = optionalPO2 rcaps width
mHeight = optionalPO2 rcaps height
mDepth = optionalPO2 rcaps depth
mFormat = getNativeFormat texType format False
maxMips = getMaxMipmaps mWidth mHeight mDepth mFormat
mNumMipmaps = maxMips
mTextureID <- alloca $ \buf -> glGenTextures 1 buf >> peek buf
glBindTexture texTarget mTextureID
when (glVer 1 2) $ glTexParameteri texTarget gl_TEXTURE_MAX_LEVEL mNumMipmaps
glTexParameteri texTarget gl_TEXTURE_MIN_FILTER $ fromIntegral gl_NEAREST
glTexParameteri texTarget gl_TEXTURE_MAG_FILTER $ fromIntegral gl_NEAREST
when (glVer 1 2) $ do
glTexParameteri texTarget gl_TEXTURE_WRAP_S $ fromIntegral gl_CLAMP_TO_EDGE
glTexParameteri texTarget gl_TEXTURE_WRAP_T $ fromIntegral gl_CLAMP_TO_EDGE
let mMipmapsHardwareGenerated = Set.member RSC_AUTOMIPMAP caps
let moreMips = case numMips of
MIP_UNLIMITED -> True
MIP_DEFAULT -> True
MIP_NUMBER n -> n > 0
when (tuAutoMipmap usage && moreMips && mMipmapsHardwareGenerated) $ glTexParameteri texTarget gl_GENERATE_MIPMAP $ fromIntegral gl_TRUE
let format' = getClosestGLInternalFormat mFormat hwGammaCorrection
isCompressed _ = False
case isCompressed mFormat of
True -> do
putStrLn "compressed format is not implemented!"
False -> do
let setMip (w,h,d) mip = do
case texType of
TEX_TYPE_1D -> glTexImage1D gl_TEXTURE_1D mip format' w 0 gl_RGBA gl_UNSIGNED_BYTE nullPtr
TEX_TYPE_2D -> glTexImage2D gl_TEXTURE_2D mip format' w h 0 gl_RGBA gl_UNSIGNED_BYTE nullPtr
TEX_TYPE_3D -> glTexImage3D gl_TEXTURE_3D mip format' w h d 0 gl_RGBA gl_UNSIGNED_BYTE nullPtr
TEX_TYPE_CUBE_MAP -> forM_ [0..5] $ \face ->
glTexImage2D (gl_TEXTURE_CUBE_MAP_POSITIVE_X + face) mip format' w h 0 gl_RGBA gl_UNSIGNED_BYTE nullPtr
return (max 1 (w `div` 2), max 1 (h `div` 2), max 1 (d `div` 2))
f = fromIntegral
foldM_ setMip (f mWidth,f mHeight,f mDepth) [0..(fromIntegral mNumMipmaps)]
when (isJust mimage) $ do
let images = fromJust mimage
imInfo i = (fmt,f w,f h)
where
f = fromIntegral
fmt = case imFormat i of
PF_L8 -> gl_LUMINANCE
PF_BYTE_LA -> gl_LUMINANCE_ALPHA
PF_R8G8B8 -> gl_RGB
PF_R8G8B8A8 -> gl_RGBA
_ -> error "mkGLTexture"
w = imWidth i
h = imHeight i
upload2D target i = do
let (fmt,w,h) = imInfo i
putStrLn $ "createTexture " ++ "upload2d: " ++ imName i
glTexImage2D target 0 format' w h 0 fmt gl_UNSIGNED_BYTE $ imDataPtr i
case texType of
TEX_TYPE_1D -> do
let (fmt,w,_h) = imInfo image
image = head images
glTexImage1D gl_TEXTURE_1D 0 format' w 0 fmt gl_UNSIGNED_BYTE $ imDataPtr image
TEX_TYPE_2D -> upload2D gl_TEXTURE_2D $ head images
TEX_TYPE_CUBE_MAP -> mapM_ (uncurry upload2D) $ zip [ gl_TEXTURE_CUBE_MAP_POSITIVE_Z
, gl_TEXTURE_CUBE_MAP_NEGATIVE_Z
, gl_TEXTURE_CUBE_MAP_POSITIVE_Y
, gl_TEXTURE_CUBE_MAP_NEGATIVE_Y
, gl_TEXTURE_CUBE_MAP_NEGATIVE_X
, gl_TEXTURE_CUBE_MAP_POSITIVE_X
] images
_ -> return ()
--_createSurfaceList();
putStrLn $ "createTexture " ++ "created texture: " ++ name
return GLTexture
{ gltxName = name
, gltxWidth = 0 --TODO
, gltxHeight = 0 --TODO
, gltxDepth = 0 --TODO
, gltxNumRequestedMipmaps = MIP_DEFAULT --TODO
, gltxNumMipmaps = 0 --TODO
, gltxMipmapsHardwareGenerated = True --TODO
, gltxGamma = 0 --TODO
, gltxHwGamma = True --TODO
, gltxFSAA = 0 --TODO
, gltxFSAAHint = "" --TODO
, gltxTextureType = texType
, gltxFormat = PF_R8G8B8
, gltxUsage = TextureUsage HBU_WRITE_ONLY False False
, gltxSrcFormat = PF_R8G8B8
, gltxSrcWidth = 0 --TODO
, gltxSrcHeight = 0 --TODO
, gltxSrcDepth = 0 --TODO
, gltxDesiredFormat = PF_R8G8B8 --TODO
, gltxDesiredIntegerBitDepth = 0 --TODO
, gltxDesiredFloatBitDepth = 0 --TODO
, gltxTreatLuminanceAsAlpha = True --TODO
, gltxTextureObject = mTextureID
}