justin/loop
1
0
Fork 0
Code Issues Pull Requests 1 Packages Projects Releases Wiki Activity

DSA gl texture naming and storage

Browse Source
This commit is contained in:
justin
2023-03-08 13:35:25 +00:00
parent 7f0c7ad159
commit 2279af5510
3 changed files with 50 additions and 39 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Shader.hs
+9 -6
View File
@@ -20,7 +20,7 @@ import qualified Data.Vector.Mutable as MV
import Control.Monad.Primitive
import Foreign
import Graphics.Rendering.OpenGL hiding (Point,translate,scale,imageHeight)
import Graphics.GL.Core43
import Graphics.GL.Core45
drawShaderLay :: Int -> UMV.MVector (PrimState IO) Int -> Int -> FullShader' -> IO ()
{-# INLINE drawShaderLay #-}
@@ -30,8 +30,10 @@ drawShaderLay l countsVector shadIn fs = do
glUseProgram (_shadProg' fs)
bindVertexArrayObject $= Just (_vao $ _shadVAO' fs)
case _shadTex' fs of
Just ShaderTexture{_textureObject = txo}
-> textureBinding Texture2D $= Just txo
Just ShaderTexture{_textureObject = txo} --, _textureTarget = tt}
-- -> textureBinding Texture2D $= Just txo
-- -> glBindTexture tt txo
-> glBindTextureUnit 0 txo
_ -> return ()
glDrawArrays
(marshalEPrimitiveMode $ _shadPrim' fs)
@@ -45,9 +47,10 @@ drawShader fs i = do
glUseProgram (_shadProg' fs)
bindVertexArrayObject $= Just (_vao $ _shadVAO' fs)
case _shadTex' fs of
Just ShaderTexture{_textureObject = TextureObject txo
, _textureTarget = tt }
-> glBindTexture tt txo
Just ShaderTexture{_textureObject = txo
} --, _textureTarget = tt }
-- -> glBindTexture tt txo
-> glBindTextureUnit 0 txo
_ -> return ()
glDrawArrays
(marshalEPrimitiveMode $ _shadPrim' fs)
src/Shader/AuxAddition.hs
+39 -31
View File
@@ -5,6 +5,9 @@ module Shader.AuxAddition
, addUniforms'
, tilesToLine -- ^ kept in case it is needed in the future
) where
import Unsafe.Coerce
import Foreign.Marshal
import Foreign.Storable
import Shader.Data
import Control.Monad
import qualified Data.ByteString as BS
@@ -15,54 +18,59 @@ import Codec.Picture
import qualified Data.Vector.Storable as VS
import Control.Lens
import Graphics.Rendering.OpenGL hiding (Point,translate,scale,imageHeight)
import Graphics.GL.Core43
import Graphics.GL.Core45
-- I am not sure if this assumes that the shader is constructed directly before
-- the texture is added...
addTexture' :: String -> FullShader' -> IO FullShader'
addTexture' = addTexture2D 3 ((Linear',Just Linear') , Linear')
addTexture' = addTexture2D 3 GL_LINEAR_MIPMAP_LINEAR GL_LINEAR
vaddTextureNoFilter' :: String -> FullShader' -> IO FullShader'
vaddTextureNoFilter' = addTexture2D 1 ((Nearest,Nothing), Nearest)
vaddTextureNoFilter' = addTexture2D 1 GL_NEAREST GL_NEAREST
--vaddTextureNoFilter' = addTexture2D 3 ((Linear',Just Linear') , Linear')
addTexture2D :: GLint -> ((TextureFilter,Maybe TextureFilter),TextureFilter)
addTexture2D :: GLint -- number mipmap levels
-- -> ((TextureFilter,Maybe TextureFilter),TextureFilter)
-> GLenum -- minfilter
-> GLenum -- magfilter
-> String -> FullShader' -> IO FullShader'
addTexture2D nlev filt texpath shad = do
addTexture2D nlev minfilt magfilt texpath shad = do
Right cmap <- readImage texpath
let tex = convertRGBA8 cmap
textureOb <- genObjectName
textureBinding Texture2D $= Just textureOb
let wtex = fromIntegral $ imageWidth tex
htex = fromIntegral $ imageHeight tex
glTexStorage2D GL_TEXTURE_2D nlev GL_RGBA8 wtex htex
VS.unsafeWith (imageData tex) $ \ptr -> do
glTexSubImage2D GL_TEXTURE_2D 0 0 0 wtex htex GL_RGBA GL_UNSIGNED_BYTE ptr
textureFilter Texture2D $= filt
generateMipmap' Texture2D
return $ shad & shadTex' ?~ ShaderTexture
{_textureObject = textureOb
,_textureTarget = GL_TEXTURE_2D
}
let texdata = convertRGBA8 cmap
let wtex = fromIntegral $ imageWidth texdata
htex = fromIntegral $ imageHeight texdata
alloca $ \nameptr -> do
glCreateTextures GL_TEXTURE_2D 1 nameptr
texname <- peek nameptr
glTextureStorage2D texname nlev GL_RGBA8 wtex htex
VS.unsafeWith (imageData texdata) $ \ptr -> do
glTextureSubImage2D texname 0 0 0 wtex htex GL_RGBA GL_UNSIGNED_BYTE ptr
glGenerateTextureMipmap texname
glTextureParameteri texname GL_TEXTURE_MIN_FILTER (unsafeCoerce minfilt)
glTextureParameteri texname GL_TEXTURE_MAG_FILTER (unsafeCoerce magfilt)
return $ shad & shadTex' ?~ ShaderTexture
{_textureObject = texname }
-- | for transforming a 256x256 image containing 64 tiles of 16x16 pixels into
-- an image that was directly readable by glTexSubImage3D, used the
-- transformation tilesToLine 8 128 on the underlying pixels.
addTextureArray' :: String -> FullShader' -> IO FullShader'
addTextureArray' texturePath shad = do
textureOb <- genObjectName
textureBinding Texture2DArray $= Just textureOb
err <- glGetError
print err
Right cmap <- readImage texturePath
let tex = convertRGBA8 cmap
glTexStorage3D GL_TEXTURE_2D_ARRAY 3 GL_RGBA8 32 32 64
VS.unsafeWith (imageData tex) $ \ptr -> do
glTexSubImage3D GL_TEXTURE_2D_ARRAY 0 0 0 0 32 32 64 GL_RGBA GL_UNSIGNED_BYTE ptr
textureFilter Texture2DArray $= ((Linear',Just Linear') , Linear')
generateMipmap' Texture2DArray
return $ shad & shadTex' ?~ ShaderTexture
{ _textureObject = textureOb
, _textureTarget = GL_TEXTURE_2D_ARRAY
}
let texdata = convertRGBA8 cmap
alloca $ \nameptr -> do
glCreateTextures GL_TEXTURE_2D_ARRAY 1 nameptr
texname <- peek nameptr
glTextureStorage3D texname 3 GL_RGBA8 32 32 64
VS.unsafeWith (imageData texdata) $ \ptr -> do
glTextureSubImage3D texname 0 0 0 0 32 32 64 GL_RGBA GL_UNSIGNED_BYTE ptr
glGenerateTextureMipmap texname
glTextureParameteri texname GL_TEXTURE_MIN_FILTER (unsafeCoerce GL_LINEAR_MIPMAP_LINEAR)
glTextureParameteri texname GL_TEXTURE_MAG_FILTER (unsafeCoerce GL_LINEAR)
return $ shad & shadTex' ?~ ShaderTexture
{ _textureObject = texname}
-- I am completely unclear on why this works with its current parameters
tilesToLine
src/Shader/Data.hs
+2 -2
View File
@@ -79,8 +79,8 @@ data EBO = EBO
}
{- | Datatype containing the reference to a texture object. -}
data ShaderTexture = ShaderTexture
{ _textureObject :: TextureObject
, _textureTarget :: GLenum
{ _textureObject :: GLuint -- DSA style texture, 450
-- , _textureTarget :: GLenum
}
data EPrimitiveMode
= EPoints