module Textures (
Texture3D(),
Texture2D(),
Texture1D(),
TextureCube(),
Texture(type TextureFormat, type TextureSize, type TextureVertexCoord, type TextureFragmentCoord, textureCPUFormatByteSize, sample, sampleBias, sampleLod),
newTexture,
newDepthTexture,
FromFrameBufferColor(..),
FromFrameBufferDepth(..),
DepthColorFormat(),
fromFrameBufferCubeColor,
fromFrameBufferCubeDepth
) where
import Data.Vec ((:.)(..), Vec2, Vec3, Vec4)
import Shader
import Resources
import OutputMerger
import Foreign.Ptr
import qualified Graphics.Rendering.OpenGL as GL
import Graphics.Rendering.OpenGL (($=), get)
import qualified Graphics.UI.GLUT as GLUT
import System.IO.Unsafe (unsafePerformIO)
import Formats
import Control.Monad
import Data.List
newtype Texture3D f = Texture3D WinMappedTexture
newtype Texture2D f = Texture2D WinMappedTexture
newtype Texture1D f = Texture1D WinMappedTexture
newtype TextureCube f = TextureCube WinMappedTexture
class Texture t where
type TextureFormat t
type TextureSize t
type TextureVertexCoord t
type TextureFragmentCoord t
mkTexture :: CPUFormat (TextureFormat t) -> GL.PixelInternalFormat -> TextureSize t -> [Ptr a] -> IO t
textureCPUFormatByteSize :: CPUFormat (TextureFormat t) -> TextureSize t -> [Int]
sample :: Sampler -> t -> TextureFragmentCoord t -> Color (TextureFormat t) (Fragment Float)
sampleBias :: Sampler -> t -> TextureFragmentCoord t -> Fragment Float -> Color (TextureFormat t) (Fragment Float)
sampleLod :: Sampler -> t -> TextureVertexCoord t -> Vertex Float -> Color (TextureFormat t) (Vertex Float)
newTexture :: (Texture t, GPUFormat (TextureFormat t))
=> CPUFormat (TextureFormat t)
-> TextureFormat t
-> TextureSize t
-> [Ptr a]
-> IO t
newTexture f i = mkTexture f (toGLInternalFormat i)
newDepthTexture :: (Texture t, DepthColorFormat (TextureFormat t))
=> CPUFormat (TextureFormat t)
-> DepthFormat
-> TextureSize t
-> [Ptr a]
-> IO t
newDepthTexture f i = mkTexture f (toGLInternalFormat i)
mipLevels 1 = 1 : mipLevels 1
mipLevels x = x : mipLevels (x `div` 2)
mipLevels' 1 = [1]
mipLevels' x = x : mipLevels' (x `div` 2)
instance ColorFormat f => Texture (Texture3D f) where
type TextureFormat (Texture3D f) = f
type TextureSize (Texture3D f) = Vec3 Int
type TextureVertexCoord (Texture3D f) = Vec3 (Vertex Float)
type TextureFragmentCoord (Texture3D f) = Vec3 (Fragment Float)
mkTexture f i s ps = liftM Texture3D $ newWinMappedTexture $ \ tex cache ->
do f' <- evaluateDeep f
i' <- evaluateDeep i
x:.y:.z:.() <- evaluateDeep s
ps' <- mapM evaluatePtr ps
GLUT.currentWindow $= Just (contextWindow cache)
let size = GL.TextureSize3D (fromIntegral x) (fromIntegral y) (fromIntegral z)
GL.textureBinding GL.Texture3D $= Just tex
mapM_ (\(n, p) ->
GL.texImage3D GL.NoProxy n i' size 0
(GL.PixelData (toGLPixelFormat (undefined::f)) (toGLDataType f') p))
[(i,p) | i<- [0..] | p<- ps']
GL.textureLevelRange GL.Texture3D $= (0, fromIntegral $ length ps' 1)
textureCPUFormatByteSize f (x:.y:.z:.()) = map (\(x,y,z)-> y*z*formatRowByteSize f x) [(x',y',z') | x' <- mipLevels x | y' <- mipLevels y | z' <- mipLevels z | _ <- mipLevels' (max x (max y z))]
sample s (Texture3D t) v = fSampleBinFunc "texture3D" Sampler3D s t v
sampleBias s (Texture3D t) v b = fSampleTernFunc "texture3D" Sampler3D s t v b
sampleLod s (Texture3D t) v m = vSampleTernFunc "texture3DLod" Sampler3D s t v m
instance ColorFormat f => Texture (Texture2D f) where
type TextureFormat (Texture2D f) = f
type TextureSize (Texture2D f) = Vec2 Int
type TextureVertexCoord (Texture2D f) = Vec2 (Vertex Float)
type TextureFragmentCoord (Texture2D f) = Vec2 (Fragment Float)
mkTexture f i s ps = liftM Texture2D $ newWinMappedTexture $ \ tex cache->
do f' <- evaluateDeep f
i' <- evaluateDeep i
x:.y:.() <- evaluateDeep s
ps' <- mapM evaluatePtr ps
GLUT.currentWindow $= Just (contextWindow cache)
let size = GL.TextureSize2D (fromIntegral x) (fromIntegral y)
GL.textureBinding GL.Texture2D $= Just tex
mapM_ (\(n, p) ->
GL.texImage2D Nothing GL.NoProxy n i' size 0
(GL.PixelData (toGLPixelFormat (undefined::f)) (toGLDataType f') p))
[(i,p) | i<- [0..] | p<- ps']
GL.textureLevelRange GL.Texture2D $= (0, fromIntegral $ length ps' 1)
textureCPUFormatByteSize f (x:.y:.()) = map (\(x,y)-> y*formatRowByteSize f x) [(x',y') | x' <- mipLevels x | y' <- mipLevels y | _ <- mipLevels' (max x y)]
sample s (Texture2D t) v = fSampleBinFunc "texture2D" Sampler2D s t v
sampleBias s (Texture2D t) v b = fSampleTernFunc "texture2D" Sampler2D s t v b
sampleLod s (Texture2D t) v m = vSampleTernFunc "texture2DLod" Sampler2D s t v m
instance ColorFormat f => Texture (Texture1D f) where
type TextureFormat (Texture1D f) = f
type TextureSize (Texture1D f) = Int
type TextureVertexCoord (Texture1D f) = Vertex Float
type TextureFragmentCoord (Texture1D f) = Fragment Float
mkTexture f i s ps = liftM Texture1D $ newWinMappedTexture $ \ tex cache ->
do f' <- evaluateDeep f
i' <- evaluateDeep i
x <- evaluateDeep s
ps' <- mapM evaluatePtr ps
GLUT.currentWindow $= Just (contextWindow cache)
let size = GL.TextureSize1D (fromIntegral x)
GL.textureBinding GL.Texture1D $= Just tex
mapM_ (\(n, p) ->
GL.texImage1D GL.NoProxy n i' size 0
(GL.PixelData (toGLPixelFormat (undefined::f)) (toGLDataType f') p))
[(i,p) | i<- [0..] | p<- ps']
GL.textureLevelRange GL.Texture1D $= (0, fromIntegral $ length ps' 1)
textureCPUFormatByteSize f x = map (\x-> formatRowByteSize f x) [x' | x' <- mipLevels' x]
sample s (Texture1D t) v = fSampleBinFunc "texture1D" Sampler1D s t (v:.())
sampleBias s (Texture1D t) v b = fSampleTernFunc "texture1D" Sampler1D s t (v:.()) b
sampleLod s (Texture1D t) v m = vSampleTernFunc "texture1DLod" Sampler1D s t (v:.()) m
instance ColorFormat f => Texture (TextureCube f) where
type TextureFormat (TextureCube f) = f
type TextureSize (TextureCube f) = Vec2 Int
type TextureVertexCoord (TextureCube f) = Vec3 (Vertex Float)
type TextureFragmentCoord (TextureCube f) = Vec3 (Fragment Float)
mkTexture f i s ps = liftM TextureCube $ newWinMappedTexture $ \ tex cache ->
do f' <- evaluateDeep f
i' <- evaluateDeep i
x:.y:.() <- evaluateDeep s
ps' <- mapM evaluatePtr ps
GLUT.currentWindow $= Just (contextWindow cache)
let size = GL.TextureSize2D (fromIntegral x) (fromIntegral y)
GL.textureBinding GL.TextureCubeMap $= Just tex
mapM_
(\(t,ps'') ->
mapM_
(\(n, p) ->
GL.texImage2D (Just t) GL.NoProxy n i' size 0
(GL.PixelData (toGLPixelFormat (undefined::f)) (toGLDataType f') p))
[(i,p) | i<- [0..] | p<- ps''])
[(t,ps'') | t <- cubeMapTargets | ps'' <- splitIn 6 ps']
GL.textureLevelRange GL.TextureCubeMap $= (0, fromIntegral $ length ps' 1)
textureCPUFormatByteSize f (x:.y:.()) = concat $ replicate 6 $ map (\(x,y)-> y*formatRowByteSize f x) [(x',y') | x' <- mipLevels x | y' <- mipLevels y | _ <- mipLevels' (max x y)]
sample s (TextureCube t) v = fSampleBinFunc "textureCube" Sampler3D s t v
sampleBias s (TextureCube t) v b = fSampleTernFunc "textureCube" Sampler3D s t v b
sampleLod s (TextureCube t) v m = vSampleTernFunc "textureCubeLod" Sampler3D s t v m
class ColorFormat a => DepthColorFormat a
instance DepthColorFormat LuminanceFormat
instance DepthColorFormat AlphaFormat
class (Texture t) => FromFrameBufferColor t c where
fromFrameBufferColor :: TextureFormat t -> TextureSize t -> FrameBuffer c d s -> t
instance ColorFormat f => FromFrameBufferColor (Texture2D f) f where
fromFrameBufferColor f s fb = Texture2D $ unsafePerformIO $ do
newWinMappedTexture $ \ tex cache ->
do f' <- evaluateDeep (toGLInternalFormat f)
x:.y:.() <- evaluateDeep s
let size = GL.TextureSize2D (fromIntegral x) (fromIntegral y)
runFrameBufferInContext cache s fb
GL.textureBinding GL.Texture2D $= Just tex
GL.copyTexImage2D Nothing 0 f' (GL.Position 0 0) size 0
GL.textureLevelRange GL.Texture2D $= (0, 0)
instance ColorFormat f => FromFrameBufferColor (Texture1D f) f where
fromFrameBufferColor f s fb = Texture1D $ unsafePerformIO $ do
newWinMappedTexture $ \ tex cache ->
do f' <- evaluateDeep (toGLInternalFormat f)
x <- evaluateDeep s
let size = GL.TextureSize1D (fromIntegral x)
runFrameBufferInContext cache (x:.1:.()) fb
GL.textureBinding GL.Texture1D $= Just tex
GL.copyTexImage1D 0 f' (GL.Position 0 0) size 0
GL.textureLevelRange GL.Texture1D $= (0, 0)
class Texture t => FromFrameBufferDepth t where
fromFrameBufferDepth :: DepthFormat -> TextureSize t -> FrameBuffer c DepthFormat s -> t
instance DepthColorFormat f => FromFrameBufferDepth (Texture2D f) where
fromFrameBufferDepth f s fb = Texture2D $ unsafePerformIO $ do
newWinMappedTexture $ \ tex cache ->
do f' <- evaluateDeep (toGLInternalFormat f)
x:.y:.() <- evaluateDeep s
let size = GL.TextureSize2D (fromIntegral x) (fromIntegral y)
runFrameBufferInContext cache s fb
GL.textureBinding GL.Texture2D $= Just tex
GL.copyTexImage2D Nothing 0 f' (GL.Position 0 0) size 0
GL.textureLevelRange GL.Texture2D $= (0, 0)
instance DepthColorFormat f => FromFrameBufferDepth (Texture1D f) where
fromFrameBufferDepth f s fb = Texture1D $ unsafePerformIO $ do
newWinMappedTexture $ \ tex cache ->
do f' <- evaluateDeep (toGLInternalFormat f)
x <- evaluateDeep s
let size = GL.TextureSize1D (fromIntegral x)
runFrameBufferInContext cache (x:.1:.()) fb
GL.textureBinding GL.Texture1D $= Just tex
GL.copyTexImage1D 0 f' (GL.Position 0 0) size 0
GL.textureLevelRange GL.Texture1D $= (0, 0)
fromFrameBufferCubeColor :: ColorFormat c => c -> Vec2 Int -> FrameBuffer c d1 s1 -> FrameBuffer c d2 s2 -> FrameBuffer c d3 s3 -> FrameBuffer c d4 s4 -> FrameBuffer c d5 s5 -> FrameBuffer c d6 s6 -> TextureCube c
fromFrameBufferCubeDepth :: DepthColorFormat d => DepthFormat -> Vec2 Int -> FrameBuffer c1 DepthFormat s1 -> FrameBuffer c2 DepthFormat s2 -> FrameBuffer c3 DepthFormat s3 -> FrameBuffer c4 DepthFormat s4 -> FrameBuffer c5 DepthFormat s5 -> FrameBuffer c6 DepthFormat s6 -> TextureCube d
fromFrameBufferCubeColor f s b0 b1 b2 b3 b4 b5 = TextureCube $ unsafePerformIO $ do
newWinMappedTexture $ \ tex cache ->
do f' <- evaluateDeep (toGLInternalFormat f)
x:.y:.() <- evaluateDeep s
let size = GL.TextureSize2D (fromIntegral x) (fromIntegral y)
mapM_ (\ (t,io)-> do
io
GL.textureBinding GL.TextureCubeMap $= Just tex
GL.copyTexImage2D (Just t) 0 f' (GL.Position 0 0) size 0)
[(t,io) | t <- cubeMapTargets | io <- [runFrameBufferInContext cache s b0,
runFrameBufferInContext cache s b1,
runFrameBufferInContext cache s b2,
runFrameBufferInContext cache s b3,
runFrameBufferInContext cache s b4,
runFrameBufferInContext cache s b5]]
GL.textureLevelRange GL.TextureCubeMap $= (0, 0)
fromFrameBufferCubeDepth f s b0 b1 b2 b3 b4 b5 = TextureCube $ unsafePerformIO $ do
newWinMappedTexture $ \ tex cache ->
do f' <- evaluateDeep (toGLInternalFormat f)
x:.y:.() <- evaluateDeep s
let size = GL.TextureSize2D (fromIntegral x) (fromIntegral y)
mapM_ (\ (t,io)-> do
io
GL.textureBinding GL.TextureCubeMap $= Just tex
GL.copyTexImage2D (Just t) 0 f' (GL.Position 0 0) size 0)
[(t,io) | t <- cubeMapTargets | io <- [runFrameBufferInContext cache s b0,
runFrameBufferInContext cache s b1,
runFrameBufferInContext cache s b2,
runFrameBufferInContext cache s b3,
runFrameBufferInContext cache s b4,
runFrameBufferInContext cache s b5]]
GL.textureLevelRange GL.TextureCubeMap $= (0, 0)
splitIn n xs = unfoldr f xs
where f [] = Nothing
f ys = Just $ splitAt (length xs `div` n) ys