Move FBOs to opengl raw

2023-03-09 15:42:17 +00:00
parent 76a8b05433
commit 44b56ed163
7 changed files with 121 additions and 93 deletions
@@ -1,74 +1,81 @@
-{- | For initialising framebuffers.
- -}
-module Framebuffer.Setup
-    ( setupTextureFramebuffer
-    , setupFramebufferGivenStencil
-    , setupFramebuffer2GivenStencil 
-    , setupShadowFramebuffer
-    ) where
-import Graphics.Rendering.OpenGL hiding (Point,translate,scale,imageHeight)
-import Graphics.GL.Core43
+-- | For initialising framebuffers.
+module Framebuffer.Setup (
+    setupTextureFramebuffer,
+    setupFramebufferGivenStencil,
+    setupFramebuffer2GivenStencil,
+    setupShadowFramebuffer,
+) where

-setupTextureFramebuffer 
-    :: GLsizei
-    -> GLsizei
-    -> IO (FramebufferObject, TextureObject)
+import Data.Preload.Render
+import GLHelp
+import Graphics.GL.Core45
+import Graphics.Rendering.OpenGL hiding (Point, imageHeight, scale, translate)
+
+setupTextureFramebuffer ::
+    GLsizei ->
+    GLsizei ->
+    IO (FBO, TextureObject)
 {-# INLINE setupTextureFramebuffer #-}
 setupTextureFramebuffer x y = do
-    fboName <- genObjectName
-    bindFramebuffer Framebuffer $= fboName
-
+    --fboName <- genObjectName
+    --bindFramebuffer Framebuffer $= fboName
+    fboName <- mglCreateSingle glCreateFramebuffers
    fboTO <- genObjectName
    textureBinding Texture2D $= Just fboTO
    glTexStorage2D GL_TEXTURE_2D 1 GL_RGBA8 x y
    textureFilter Texture2D $= minMagFilter
-    framebufferTexture2D Framebuffer (ColorAttachment 0) Texture2D fboTO 0
+    --framebufferTexture2D Framebuffer (ColorAttachment 0) Texture2D fboTO 0
+    glNamedFramebufferTexture fboName GL_COLOR_ATTACHMENT0 (unTexture fboTO) 0
    fboStatus <- framebufferStatus Framebuffer
    case fboStatus of
        Complete -> return ()
        _ -> putStrLn $ "Texture framebuffer status: " ++ show fboStatus
-    return (fboName, fboTO)
+    return (FBO fboName, fboTO)

-setupShadowFramebuffer :: IO (FramebufferObject,(TextureObject,TextureObject))
+setupShadowFramebuffer :: IO (FBO, (TextureObject, TextureObject))
 setupShadowFramebuffer = do
-    fboName <- genObjectName
-    bindFramebuffer Framebuffer $= fboName
+    --fboName <- genObjectName
+    --bindFramebuffer Framebuffer $= fboName
+    fboName <- mglCreateSingle glCreateFramebuffers
    toName <- genObjectName
    toName2 <- genObjectName
    --textureBinding Texture2DArray $= Just toName
    --framebufferRenderbuffer Framebuffer DepthStencilAttachment Renderbuffer rboName
-    return (fboName,(toName,toName2))
+    return (FBO fboName, (toName, toName2))

-setupFramebufferGivenStencil 
-    :: GLuint -- RenderbufferObject 
-    -> IO (FramebufferObject, TextureObject)
+setupFramebufferGivenStencil ::
+    GLuint -> -- RenderbufferObject
+    IO (FBO, TextureObject)
 {-# INLINE setupFramebufferGivenStencil #-}
 setupFramebufferGivenStencil rboName = do
-    fboName <- genObjectName
-    bindFramebuffer Framebuffer $= fboName
+    --fboName <- genObjectName
+    --bindFramebuffer Framebuffer $= fboName
+    fboName <- mglCreateSingle glCreateFramebuffers
    toName <- genObjectName
    --framebufferRenderbuffer Framebuffer DepthStencilAttachment Renderbuffer rboName
-    glFramebufferRenderbuffer GL_FRAMEBUFFER GL_DEPTH_STENCIL_ATTACHMENT GL_RENDERBUFFER rboName
+    glNamedFramebufferRenderbuffer fboName GL_DEPTH_STENCIL_ATTACHMENT GL_RENDERBUFFER rboName
    fboStatus <- framebufferStatus Framebuffer
    case fboStatus of
        Complete -> return ()
        _ -> putStrLn $ "Framebuffer with given stencil status: " ++ show fboStatus
-    return (fboName,toName)
-setupFramebuffer2GivenStencil 
-    :: GLuint -- RenderbufferObject 
-    -> IO (FramebufferObject, (TextureObject,TextureObject))
+    return (FBO fboName, toName)
+
+setupFramebuffer2GivenStencil ::
+    GLuint -> -- RenderbufferObject
+    IO (FBO, (TextureObject, TextureObject))
 setupFramebuffer2GivenStencil rboName = do
-    fboName <- genObjectName
-    bindFramebuffer Framebuffer $= fboName
+    --fboName <- genObjectName
+    --bindFramebuffer Framebuffer $= fboName
+    fboName <- mglCreateSingle glCreateFramebuffers
    toName <- genObjectName
    toName2 <- genObjectName
    --framebufferRenderbuffer Framebuffer DepthStencilAttachment Renderbuffer rboName
-    glFramebufferRenderbuffer GL_FRAMEBUFFER GL_DEPTH_STENCIL_ATTACHMENT GL_RENDERBUFFER rboName
+    glNamedFramebufferRenderbuffer fboName GL_DEPTH_STENCIL_ATTACHMENT GL_RENDERBUFFER rboName
    fboStatus <- framebufferStatus Framebuffer
    case fboStatus of
        Complete -> return ()
        _ -> putStrLn $ "Framebuffer with given stencil and two texture objects status: " ++ show fboStatus
-    return (fboName,(toName,toName2))
+    return (FBO fboName, (toName, toName2))

-minMagFilter :: ((TextureFilter, Maybe TextureFilter),TextureFilter)
-minMagFilter = ((Nearest,Nothing),Nearest)
+minMagFilter :: ((TextureFilter, Maybe TextureFilter), TextureFilter)
+minMagFilter = ((Nearest, Nothing), Nearest)
@@ -7,6 +7,7 @@ module Framebuffer.Update
    )
 where
 import Data.Preload.Render
+import GLHelp

 import Graphics.Rendering.OpenGL
 import Graphics.GL.Core45
@@ -44,8 +45,6 @@ resizeRBO
 resizeRBO rboName xsize ysize = do
    let xsize' = fromIntegral xsize
        ysize' = fromIntegral ysize
-    --bindRenderbuffer Renderbuffer $= rboName
-    --renderbufferStorage Renderbuffer Depth24Stencil8 (RenderbufferSize xsize' ysize')
    glNamedRenderbufferStorage 
        rboName
        GL_DEPTH24_STENCIL8
@@ -57,7 +56,7 @@ updateFBOTO
    -> ((TextureFilter, Maybe TextureFilter),TextureFilter)
    -> GLenum   -- ^ internal color format
    -> RenderData
-    -> ALens' RenderData (FramebufferObject, TextureObject)
+    -> ALens' RenderData (FBO, TextureObject)
    -> IO RenderData
 updateFBOTO xsize ysize mmfilt inFormat pdata target = do
    newfbo2 <- resizeFBOTO (pdata ^# target) xsize ysize mmfilt inFormat
@@ -70,18 +69,20 @@ updateFBOTO2
    -> GLenum   -- ^ internal color format texture1
    -> GLenum   -- ^ internal color format texture2
    -> RenderData
-    -> ALens' RenderData (FramebufferObject, (TextureObject,TextureObject))
+    -> ALens' RenderData (FBO, (TextureObject,TextureObject))
    -> IO RenderData
 updateFBOTO2 xsize ysize mmfilt inFormat1 inFormat2 pdata target = do
    newfbo2 <- resizeFBOTO2 (pdata ^# target) xsize ysize mmfilt inFormat1 inFormat2
    return $ storing target newfbo2 pdata

-resizeShadowFBO :: (FramebufferObject, (TextureObject,TextureObject))
-    -> Int -> Int -> IO (FramebufferObject, (TextureObject,TextureObject))
+-- note we only really "change" the texture objects
+resizeShadowFBO :: (FBO, (TextureObject,TextureObject))
+    -> Int -> Int -> IO (FBO, (TextureObject,TextureObject))
 resizeShadowFBO (fboname,(oldto1,oldto2)) xsize ysize = do
    let xsize' = fromIntegral xsize
        ysize' = fromIntegral ysize
-    bindFramebuffer Framebuffer $= fboname
+    --bindFramebuffer Framebuffer $= fboname
+    glBindFramebuffer GL_FRAMEBUFFER (_unFBO fboname)
    deleteObjectName oldto1
    deleteObjectName oldto2
    to1 <- genObjectName
@@ -89,30 +90,28 @@ resizeShadowFBO (fboname,(oldto1,oldto2)) xsize ysize = do
    textureBinding Texture2DArray $= Just to1
    glTexStorage3D GL_TEXTURE_2D_ARRAY 1 GL_RGBA8 xsize' ysize' 10
    textureFilter Texture2DArray $= minMagFilter
-    glFramebufferTexture GL_FRAMEBUFFER GL_COLOR_ATTACHMENT0 (unTexture to1) 0
+    glNamedFramebufferTexture (_unFBO fboname) GL_COLOR_ATTACHMENT0 (unTexture to1) 0
    textureBinding Texture2DArray $= Just to2
    glTexStorage3D GL_TEXTURE_2D_ARRAY 1 GL_DEPTH24_STENCIL8 xsize' ysize' 10
    textureFilter Texture2DArray $= minMagFilter
-    glFramebufferTexture GL_FRAMEBUFFER GL_DEPTH_STENCIL_ATTACHMENT (unTexture to2) 0
+    glNamedFramebufferTexture (_unFBO fboname) GL_DEPTH_STENCIL_ATTACHMENT (unTexture to2) 0
    fboStatus <- framebufferStatus Framebuffer
    case fboStatus of
        Complete -> return ()
        _ -> error $ "after resize, resizeFBOTO2 framebuffer status:" ++ show fboStatus
    return (fboname,(to1,to2))

-unTexture :: TextureObject -> GLuint
-unTexture (TextureObject t) = t
-
 resizeFBOTO2
-    :: (FramebufferObject , (TextureObject,TextureObject))
+    :: (FBO , (TextureObject,TextureObject))
    -> Int
    -> Int
    -> ((TextureFilter, Maybe TextureFilter),TextureFilter)
    -> GLenum   -- ^ internal color format1
    -> GLenum   -- ^ internal color format2
-    -> IO (FramebufferObject, (TextureObject,TextureObject))
+    -> IO (FBO, (TextureObject,TextureObject))
 resizeFBOTO2 (fboName,(toOld1,toOld2)) xsize ysize mmfilt inFormat1 inFormat2 = do
-    bindFramebuffer Framebuffer $= fboName
+    --bindFramebuffer Framebuffer $= fboName
+    glBindFramebuffer GL_FRAMEBUFFER (_unFBO fboName)
    let xsize' = fromIntegral xsize
        ysize' = fromIntegral ysize
    deleteObjectName toOld1
@@ -126,7 +125,8 @@ resizeFBOTO2 (fboName,(toOld1,toOld2)) xsize ysize mmfilt inFormat1 inFormat2 =
    textureBinding Texture2D $= Just toName2
    glTexStorage2D GL_TEXTURE_2D 1 inFormat2 xsize' ysize'
    textureFilter Texture2D $= mmfilt
-    framebufferTexture2D Framebuffer (ColorAttachment 1) Texture2D toName2 0
+    --framebufferTexture2D Framebuffer (ColorAttachment 1) Texture2D toName2 0
+    glNamedFramebufferTexture (_unFBO fboName) GL_COLOR_ATTACHMENT1 (unTexture toName2) 0
    drawBuffers $= [FBOColorAttachment 0,FBOColorAttachment 1]
    fboStatus <- framebufferStatus Framebuffer
    case fboStatus of
@@ -135,14 +135,15 @@ resizeFBOTO2 (fboName,(toOld1,toOld2)) xsize ysize mmfilt inFormat1 inFormat2 =
    return (fboName, (toName1,toName2))

 resizeFBOTO
-    :: (FramebufferObject , TextureObject)
+    :: (FBO , TextureObject)
    -> Int
    -> Int
    -> ((TextureFilter, Maybe TextureFilter),TextureFilter)
    -> GLenum   -- ^ internal color format
-    -> IO (FramebufferObject, TextureObject)
+    -> IO (FBO, TextureObject)
 resizeFBOTO (fboName,toOld) xsize ysize mmfilt inFormat = do
-    bindFramebuffer Framebuffer $= fboName
+    --bindFramebuffer Framebuffer $= fboName
+    glBindFramebuffer GL_FRAMEBUFFER (_unFBO fboName)
    let xsize' = fromIntegral xsize
        ysize' = fromIntegral ysize
    deleteObjectName toOld
@@ -150,7 +151,8 @@ resizeFBOTO (fboName,toOld) xsize ysize mmfilt inFormat = do
    textureBinding Texture2D $= Just toName
    glTexStorage2D GL_TEXTURE_2D 1 inFormat xsize' ysize'
    textureFilter Texture2D $= mmfilt
-    framebufferTexture2D Framebuffer (ColorAttachment 0) Texture2D toName 0
+    glNamedFramebufferTexture (_unFBO fboName) GL_COLOR_ATTACHMENT0 (unTexture toName) 0
+    --framebufferTexture2D Framebuffer (ColorAttachment 0) Texture2D toName 0
    fboStatus <- framebufferStatus Framebuffer
    case fboStatus of
        Complete -> return ()