Cleanup

src/Framebuffer/Update.hs

@@ -1,49 +1,61 @@
 {-# 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
+{- | Concerns resizing framebuffers on the fly.
-import Graphics.GL.Core45
+ - Seems to need to be called at least once.
---import Foreign
+-}
+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 
+sizeFBOs ::
-    :: Int  -- ^ Scaled width
+    -- | Scaled width
-    -> Int  -- ^ Scaled height
+    Int ->
-    -> Int  -- ^ Full width
+    -- | Scaled height
-    -> Int  -- ^ Full height
+    Int ->
-    -> RenderData
+    -- | Full width
-    -> IO RenderData
+    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]
+    rdata' <-
-        >>= flip (foldM (updateFBOTO xsize ysize GL_NEAREST GL_NEAREST GL_RGBA8))
+        foldM (updateFBOTO2 xsize ysize GL_NEAREST GL_NEAREST GL_RGBA8 GL_RGBA16F) rdata [fboBase, fboCloud]
-            [fboColor,fboLighting,fboLightingHigh]
+            >>= flip
-    rdata'' <- foldM (updateFBOTO xsize ysize GL_LINEAR_MIPMAP_LINEAR GL_LINEAR GL_RGBA16F) rdata' 
+                (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'' 
+    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''' 
+    rdata4 <-
-        [fboHalf1,fboHalf2,fboHalf3]
+        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
+resizeRBO ::
-    :: GLuint -- RenderbufferObject
+    GLuint -> -- RenderbufferObject
-    -> Int
+    Int ->
-    -> Int
+    Int ->
-    -> IO ()
+    IO ()
 resizeRBO rboName xsize ysize = do
     let xsize' = fromIntegral xsize
         ysize' = fromIntegral ysize
@@ -52,125 +64,114 @@ resizeRBO rboName xsize ysize = do
         GL_DEPTH24_STENCIL8
         xsize'
         ysize'
-updateFBOTO
+
-    :: Int
+updateFBOTO ::
-    -> Int
+    Int ->
-    -> GLenum -- ^ minification filter
+    Int ->
-    -> GLenum -- ^ magnification filter
+    -- | minification filter
-    -> GLenum   -- ^ internal color format
+    GLenum ->
-    -> RenderData
+    -- | magnification filter
-    -> ALens' RenderData (FBO, TO)
+    GLenum ->
-    -> IO RenderData
+    -- | 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
+updateFBOTO2 ::
-    :: Int
+    Int ->
-    -> Int
+    Int ->
-    -> GLenum -- ^ minification filter
+    -- | minification filter
-    -> GLenum -- ^ magnification filter
+    GLenum ->
-    -> GLenum   -- ^ internal color format texture1
+    -- | magnification filter
-    -> GLenum   -- ^ internal color format texture2
+    GLenum ->
-    -> RenderData
+    -- | internal color format texture1
-    -> ALens' RenderData (FBO, (TO,TO))
+    GLenum ->
-    -> IO RenderData
+    -- | 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))
+resizeShadowFBO ::
-    -> Int -> Int -> IO (FBO, (TO,TO))
+    (FBO, (TO, TO)) ->
-resizeShadowFBO (fboname,(oldto1,oldto2)) xsize ysize = do
+    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
+    checkFBO fboname
-    case fboStatus of
+    return (fboname, (TO to1, TO to2))
-        Complete -> return ()
-        _ -> error $ "after resize, resizeFBOTO2 framebuffer status:" ++ show fboStatus
-    return (fboname,(TO to1,TO to2))
 
 -- this currently has one mipmap level?
-resizeFBOTO2
+resizeFBOTO2 ::
-    :: (FBO , (TO,TO))
+    (FBO, (TO, TO)) ->
-    -> Int
+    Int ->
-    -> Int
+    Int ->
-    -> GLenum -- ^ minification filter
+    -- | minification filter
-    -> GLenum -- ^ magnification filter
+    GLenum ->
-    -> GLenum   -- ^ internal color format1
+    -- | magnification filter
-    -> GLenum   -- ^ internal color format2
+    GLenum ->
-    -> IO (FBO, (TO,TO))
+    -- | internal color format1
-resizeFBOTO2 (fboName,(toOld1,toOld2)) xsize ysize minfilt magfilt inFormat1 inFormat2 = do
+    GLenum ->
-    --bindFramebuffer Framebuffer $= fboName
+    -- | internal color format2
-    glBindFramebuffer GL_FRAMEBUFFER (_unFBO fboName)
+    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
-    glNamedFramebufferTexture (_unFBO fboName) GL_COLOR_ATTACHMENT0 to1 0
-    --framebufferTexture2D Framebuffer (ColorAttachment 0) Texture2D toName1 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
+    glNamedFramebufferTexture (_unFBO fboname) GL_COLOR_ATTACHMENT1 to2 0
-    --textureBinding Texture2D $= Just toName2
+    withArray [GL_COLOR_ATTACHMENT0, GL_COLOR_ATTACHMENT1] $ \ptr ->
-    --glTexStorage2D GL_TEXTURE_2D 1 inFormat2 xsize' ysize'
+        glNamedFramebufferDrawBuffers (_unFBO fboname) 2 ptr
-    --textureFilter Texture2D $= mmfilt
+    checkFBO fboname
-    --framebufferTexture2D Framebuffer (ColorAttachment 1) Texture2D toName2 0
+    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
-    --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))
 
-resizeFBOTO
+resizeFBOTO ::
-    :: (FBO , TO)
+    (FBO, TO) ->
-    -> Int
+    Int ->
-    -> Int
+    Int ->
-    -> GLenum -- ^ minification filter 
+    -- | minification filter
-    -> GLenum -- ^ magnification filter
+    GLenum ->
-    -> GLenum   -- ^ internal color format
+    -- | magnification filter
-    -> IO (FBO, TO)
+    GLenum ->
-resizeFBOTO (fboName,oldto) xsize ysize minfilt magfilt inFormat = do
+    -- | internal color format
-    glBindFramebuffer GL_FRAMEBUFFER (_unFBO fboName)
+    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
+    glNamedFramebufferTexture (_unFBO fboname) GL_COLOR_ATTACHMENT0 to1 0
-    fboStatus <- framebufferStatus Framebuffer
+    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)