diff --git a/src/Framebuffer/Update.hs b/src/Framebuffer/Update.hs index 6c900cd27..3b40adc12 100644 --- a/src/Framebuffer/Update.hs +++ b/src/Framebuffer/Update.hs @@ -1,176 +1,177 @@ {-# LANGUAGE NoMonomorphismRestriction #-} -{-| Concerns resizing framebuffers on the fly. - - Seems to need to be called at least once. - -} -module Framebuffer.Update - ( sizeFBOs - ) -where -import Data.Preload.Render -import GLHelp -import Unsafe.Coerce -import Foreign.Marshal.Array -import Graphics.Rendering.OpenGL -import Graphics.GL.Core45 ---import Foreign +{- | Concerns resizing framebuffers on the fly. + - Seems to need to be called at least once. +-} +module Framebuffer.Update ( + sizeFBOs, +) where + import Control.Lens import Control.Monad +import Data.Preload.Render +import Foreign.Marshal.Array +import GLHelp +import Graphics.GL.Core45 +import Unsafe.Coerce -sizeFBOs - :: Int -- ^ Scaled width - -> Int -- ^ Scaled height - -> Int -- ^ Full width - -> Int -- ^ Full height - -> RenderData - -> IO RenderData +sizeFBOs :: + -- | Scaled width + Int -> + -- | Scaled height + Int -> + -- | Full width + Int -> + -- | Full height + Int -> + RenderData -> + IO RenderData sizeFBOs xsize ysize xfull yfull rdata = do resizeRBO (_rboBaseBloom rdata) xsize ysize - rdata' <- foldM (updateFBOTO2 xsize ysize GL_NEAREST GL_NEAREST GL_RGBA8 GL_RGBA16F) rdata [fboBase,fboCloud] - >>= flip (foldM (updateFBOTO xsize ysize GL_NEAREST GL_NEAREST GL_RGBA8)) - [fboColor,fboLighting,fboLightingHigh] - rdata'' <- foldM (updateFBOTO xsize ysize GL_LINEAR_MIPMAP_LINEAR GL_LINEAR GL_RGBA16F) rdata' - [fboBloom, fboPos] - rdata''' <- foldM (updateFBOTO xfull yfull GL_NEAREST GL_NEAREST GL_RGBA8) rdata'' - [fbo2, fbo3] - rdata4 <- foldM (updateFBOTO (xsize `div` 2) (ysize `div` 2) GL_LINEAR_MIPMAP_LINEAR GL_LINEAR GL_RGBA16F) rdata''' - [fboHalf1,fboHalf2,fboHalf3] + rdata' <- + foldM (updateFBOTO2 xsize ysize GL_NEAREST GL_NEAREST GL_RGBA8 GL_RGBA16F) rdata [fboBase, fboCloud] + >>= flip + (foldM (updateFBOTO xsize ysize GL_NEAREST GL_NEAREST GL_RGBA8)) + [fboColor, fboLighting, fboLightingHigh] + rdata'' <- + foldM + (updateFBOTO xsize ysize GL_LINEAR_MIPMAP_LINEAR GL_LINEAR GL_RGBA16F) + rdata' + [fboBloom, fboPos] + rdata''' <- + foldM + (updateFBOTO xfull yfull GL_NEAREST GL_NEAREST GL_RGBA8) + rdata'' + [fbo2, fbo3] + rdata4 <- + foldM + (updateFBOTO (xsize `div` 2) (ysize `div` 2) GL_LINEAR_MIPMAP_LINEAR GL_LINEAR GL_RGBA16F) + rdata''' + [fboHalf1, fboHalf2, fboHalf3] newShadowFBO <- resizeShadowFBO (rdata ^. fboShadow) xsize ysize return $ rdata4 & fboShadow .~ newShadowFBO --- return rdata4 -resizeRBO - :: GLuint -- RenderbufferObject - -> Int - -> Int - -> IO () +resizeRBO :: + GLuint -> -- RenderbufferObject + Int -> + Int -> + IO () resizeRBO rboName xsize ysize = do let xsize' = fromIntegral xsize ysize' = fromIntegral ysize - glNamedRenderbufferStorage + glNamedRenderbufferStorage rboName GL_DEPTH24_STENCIL8 xsize' ysize' -updateFBOTO - :: Int - -> Int - -> GLenum -- ^ minification filter - -> GLenum -- ^ magnification filter - -> GLenum -- ^ internal color format - -> RenderData - -> ALens' RenderData (FBO, TO) - -> IO RenderData + +updateFBOTO :: + Int -> + Int -> + -- | minification filter + GLenum -> + -- | magnification filter + GLenum -> + -- | internal color format + GLenum -> + RenderData -> + ALens' RenderData (FBO, TO) -> + IO RenderData updateFBOTO xsize ysize minfilt magfilt inFormat pdata target = do newfbo2 <- resizeFBOTO (pdata ^# target) xsize ysize minfilt magfilt inFormat return $ storing target newfbo2 pdata -updateFBOTO2 - :: Int - -> Int - -> GLenum -- ^ minification filter - -> GLenum -- ^ magnification filter - -> GLenum -- ^ internal color format texture1 - -> GLenum -- ^ internal color format texture2 - -> RenderData - -> ALens' RenderData (FBO, (TO,TO)) - -> IO RenderData +updateFBOTO2 :: + Int -> + Int -> + -- | minification filter + GLenum -> + -- | magnification filter + GLenum -> + -- | internal color format texture1 + GLenum -> + -- | internal color format texture2 + GLenum -> + RenderData -> + ALens' RenderData (FBO, (TO, TO)) -> + IO RenderData updateFBOTO2 xsize ysize minfilt magfilt inFormat1 inFormat2 pdata target = do newfbo2 <- resizeFBOTO2 (pdata ^# target) xsize ysize minfilt magfilt inFormat1 inFormat2 return $ storing target newfbo2 pdata -- note we only really "change" the texture objects -resizeShadowFBO :: (FBO, (TO,TO)) - -> Int -> Int -> IO (FBO, (TO,TO)) -resizeShadowFBO (fboname,(oldto1,oldto2)) xsize ysize = do +resizeShadowFBO :: + (FBO, (TO, TO)) -> + Int -> + Int -> + IO (FBO, (TO, TO)) +resizeShadowFBO (fboname, (oldto1, oldto2)) xsize ysize = do let xsize' = fromIntegral xsize ysize' = fromIntegral ysize - --bindFramebuffer Framebuffer $= fboname glBindFramebuffer GL_FRAMEBUFFER (_unFBO fboname) mglDelete glDeleteTextures $ _unTO oldto1 mglDelete glDeleteTextures $ _unTO oldto2 - --deleteObjectName oldto1 - --deleteObjectName oldto2 - --to1 <- genObjectName - --to2 <- genObjectName to1 <- mglCreate (glCreateTextures GL_TEXTURE_2D_ARRAY) to2 <- mglCreate (glCreateTextures GL_TEXTURE_2D_ARRAY) - --textureBinding Texture2DArray $= Just to1 glTextureStorage3D to1 1 GL_RGBA8 xsize' ysize' 10 glTextureParameteri to1 GL_TEXTURE_MIN_FILTER (unsafeCoerce GL_NEAREST) glTextureParameteri to1 GL_TEXTURE_MAG_FILTER (unsafeCoerce GL_NEAREST) - --textureFilter Texture2DArray $= minMagFilter glNamedFramebufferTexture (_unFBO fboname) GL_COLOR_ATTACHMENT0 to1 0 - --textureBinding Texture2DArray $= Just to2 glTextureStorage3D to2 1 GL_DEPTH24_STENCIL8 xsize' ysize' 10 glTextureParameteri to1 GL_TEXTURE_MIN_FILTER (unsafeCoerce GL_NEAREST) glTextureParameteri to1 GL_TEXTURE_MAG_FILTER (unsafeCoerce GL_NEAREST) - --textureFilter Texture2DArray $= minMagFilter glNamedFramebufferTexture (_unFBO fboname) GL_DEPTH_STENCIL_ATTACHMENT to2 0 - fboStatus <- framebufferStatus Framebuffer - case fboStatus of - Complete -> return () - _ -> error $ "after resize, resizeFBOTO2 framebuffer status:" ++ show fboStatus - return (fboname,(TO to1,TO to2)) + checkFBO fboname + return (fboname, (TO to1, TO to2)) -- this currently has one mipmap level? -resizeFBOTO2 - :: (FBO , (TO,TO)) - -> Int - -> Int - -> GLenum -- ^ minification filter - -> GLenum -- ^ magnification filter - -> GLenum -- ^ internal color format1 - -> GLenum -- ^ internal color format2 - -> IO (FBO, (TO,TO)) -resizeFBOTO2 (fboName,(toOld1,toOld2)) xsize ysize minfilt magfilt inFormat1 inFormat2 = do - --bindFramebuffer Framebuffer $= fboName - glBindFramebuffer GL_FRAMEBUFFER (_unFBO fboName) +resizeFBOTO2 :: + (FBO, (TO, TO)) -> + Int -> + Int -> + -- | minification filter + GLenum -> + -- | magnification filter + GLenum -> + -- | internal color format1 + GLenum -> + -- | internal color format2 + GLenum -> + IO (FBO, (TO, TO)) +resizeFBOTO2 (fboname, (toOld1, toOld2)) xsize ysize minfilt magfilt inFormat1 inFormat2 = do + glBindFramebuffer GL_FRAMEBUFFER (_unFBO fboname) let xsize' = fromIntegral xsize ysize' = fromIntegral ysize mglDelete glDeleteTextures $ _unTO toOld1 mglDelete glDeleteTextures $ _unTO toOld2 --- deleteObjectName toOld1 --- deleteObjectName toOld2 to1 <- mglCreate (glCreateTextures GL_TEXTURE_2D) to2 <- mglCreate (glCreateTextures GL_TEXTURE_2D) - --toName1 <- genObjectName - --textureBinding Texture2D $= Just toName1 - --glTexStorage2D GL_TEXTURE_2D 1 inFormat1 xsize' ysize' glTextureStorage2D to1 1 inFormat1 xsize' ysize' glTextureParameteri to1 GL_TEXTURE_MIN_FILTER (unsafeCoerce minfilt) glTextureParameteri to1 GL_TEXTURE_MAG_FILTER (unsafeCoerce magfilt) - --textureFilter Texture2D $= mmfilt - glNamedFramebufferTexture (_unFBO fboName) GL_COLOR_ATTACHMENT0 to1 0 - --framebufferTexture2D Framebuffer (ColorAttachment 0) Texture2D toName1 0 + glNamedFramebufferTexture (_unFBO fboname) GL_COLOR_ATTACHMENT0 to1 0 glTextureStorage2D to2 1 inFormat2 xsize' ysize' glTextureParameteri to2 GL_TEXTURE_MIN_FILTER (unsafeCoerce minfilt) glTextureParameteri to2 GL_TEXTURE_MAG_FILTER (unsafeCoerce magfilt) - --toName2 <- genObjectName - --textureBinding Texture2D $= Just toName2 - --glTexStorage2D GL_TEXTURE_2D 1 inFormat2 xsize' ysize' - --textureFilter Texture2D $= mmfilt - --framebufferTexture2D Framebuffer (ColorAttachment 1) Texture2D toName2 0 - glNamedFramebufferTexture (_unFBO fboName) GL_COLOR_ATTACHMENT1 to2 0 - withArray [GL_COLOR_ATTACHMENT0,GL_COLOR_ATTACHMENT1] $ \ptr -> - glNamedFramebufferDrawBuffers (_unFBO fboName) 2 ptr - --drawBuffers $= [FBOColorAttachment 0,FBOColorAttachment 1] - fboStatus <- framebufferStatus Framebuffer - case fboStatus of - Complete -> return () - _ -> error $ "after resize, resizeFBOTO2 framebuffer status:" ++ show fboStatus - return (fboName, (TO to1,TO to2)) + glNamedFramebufferTexture (_unFBO fboname) GL_COLOR_ATTACHMENT1 to2 0 + withArray [GL_COLOR_ATTACHMENT0, GL_COLOR_ATTACHMENT1] $ \ptr -> + glNamedFramebufferDrawBuffers (_unFBO fboname) 2 ptr + checkFBO fboname + return (fboname, (TO to1, TO to2)) -resizeFBOTO - :: (FBO , TO) - -> Int - -> Int - -> GLenum -- ^ minification filter - -> GLenum -- ^ magnification filter - -> GLenum -- ^ internal color format - -> IO (FBO, TO) -resizeFBOTO (fboName,oldto) xsize ysize minfilt magfilt inFormat = do - glBindFramebuffer GL_FRAMEBUFFER (_unFBO fboName) +resizeFBOTO :: + (FBO, TO) -> + Int -> + Int -> + -- | minification filter + GLenum -> + -- | magnification filter + GLenum -> + -- | internal color format + GLenum -> + IO (FBO, TO) +resizeFBOTO (fboname, oldto) xsize ysize minfilt magfilt inFormat = do + glBindFramebuffer GL_FRAMEBUFFER (_unFBO fboname) let xsize' = fromIntegral xsize ysize' = fromIntegral ysize mglDelete glDeleteTextures $ _unTO oldto @@ -178,9 +179,24 @@ resizeFBOTO (fboName,oldto) xsize ysize minfilt magfilt inFormat = do glTextureStorage2D to1 1 inFormat xsize' ysize' glTextureParameteri to1 GL_TEXTURE_MIN_FILTER (unsafeCoerce minfilt) glTextureParameteri to1 GL_TEXTURE_MAG_FILTER (unsafeCoerce magfilt) - glNamedFramebufferTexture (_unFBO fboName) GL_COLOR_ATTACHMENT0 to1 0 - fboStatus <- framebufferStatus Framebuffer + glNamedFramebufferTexture (_unFBO fboname) GL_COLOR_ATTACHMENT0 to1 0 + checkFBO fboname + return (fboname, TO to1) + +initializeTexture2D :: Int -> Int -> GLenum -> GLenum -> GLenum -> IO GLuint +initializeTexture2D x y minfilt magfilt informat = do + let xsize' = fromIntegral x + ysize' = fromIntegral y + to1 <- mglCreate (glCreateTextures GL_TEXTURE_2D) + glTextureStorage2D to1 1 informat xsize' ysize' + glTextureParameteri to1 GL_TEXTURE_MIN_FILTER (unsafeCoerce minfilt) + glTextureParameteri to1 GL_TEXTURE_MAG_FILTER (unsafeCoerce magfilt) + return to1 + + +checkFBO :: FBO -> IO () +checkFBO fbo = do + fboStatus <- glCheckNamedFramebufferStatus (_unFBO fbo) GL_FRAMEBUFFER case fboStatus of - Complete -> return () + 36053 -> return () _ -> error $ "after resize, resizeFBOTO framebuffer status:" ++ show fboStatus - return (fboName, TO to1)