loop/src/Framebuffer/Update.hs

{-# LANGUAGE NoMonomorphismRestriction #-}

{- | Concerns resizing framebuffers on the fly.
 - Seems to need to be called at least once.
-}
module Framebuffer.Update (
    sizeFBOs,
) where

import Dodge.WindowSize
import Control.Lens
import Control.Monad
import Data.Preload.Render
import Dodge.Data.Config
import Foreign.Marshal.Array
import Framebuffer.Check
import GLHelp
import Graphics.GL.Core45
import Shader.Data
import Unsafe.Coerce

sizeFBOs ::
    Config ->
    RenderData ->
    IO RenderData
sizeFBOs cfig rdata =
    uncurry (resizeRBO (_rboBaseBloom rdata)) (getWindowSize _graphics_world_resolution cfig)
        >> foldM
            ( uncurry
                updateFBOTO3
                (getWindowSize _graphics_world_resolution cfig)
                GL_NEAREST
                GL_NEAREST
                GL_RGBA8
                GL_RGBA16F -- i am not sure if this should not be GL_RGBA32F
                GL_RGBA16F
            )
            rdata
            [fboBase, fboCloud]
            >>= foldUpdateFBOTO
                _graphics_world_resolution
                GL_NEAREST
                GL_NEAREST
                GL_RGBA8
                [fboLighting]
            >>= foldUpdateFBOTO
                _graphics_world_resolution
                GL_LINEAR_MIPMAP_LINEAR
                GL_LINEAR
                GL_RGBA16F
                [fboBloom, fboPos]
            >>= foldUpdateFBOTO
                _graphics_distortion_resolution
                GL_LINEAR
                GL_NEAREST
                GL_RGBA8
                [fbo2, fbo3]
            >>= foldUpdateFBOTO
                _graphics_downsize_resolution
                GL_LINEAR_MIPMAP_LINEAR
                GL_LINEAR
                GL_RGBA16F
                [fboHalf1, fboHalf2]
  where
    updateFBOTO' f =
        uncurry
            updateFBOTO
            (getWindowSize f cfig)
    foldUpdateFBOTO f minfilt magfilt format l =
        ffoldM
            ( updateFBOTO'
                f
                minfilt
                magfilt
                format
            )
            l

ffoldM ::
    (Foldable t, Monad m) =>
    (a1 -> a2 -> m a1) ->
    t a2 ->
    a1 ->
    m a1
ffoldM f = flip $ foldM f

resizeRBO ::
    GLuint -> -- RenderbufferObject
    GLsizei ->
    GLsizei ->
    IO ()
resizeRBO rboName =
    glNamedRenderbufferStorage
        rboName
        GL_DEPTH24_STENCIL8

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 ->
--    -- | 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

updateFBOTO3 ::
    Int ->
    Int ->
    -- | minification filter
    GLenum ->
    -- | magnification filter
    GLenum ->
    -- | internal color format texture1
    GLenum ->
    -- | internal color format texture2
    GLenum ->
    -- | internal color format texture3
    GLenum ->
    RenderData ->
    ALens' RenderData (FBO, (TO, TO, TO)) ->
    IO RenderData
updateFBOTO3 xsize ysize minfilt magfilt inFormat1 inFormat2 inFormat3 pdata target = do
    newfbo2 <- resizeFBOTO3 (pdata ^# target) xsize ysize minfilt magfilt inFormat1 inFormat2 inFormat3
    return $ storing target newfbo2 pdata

--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 (fbo, (toOld1, toOld2)) xsize ysize minfilt magfilt inFormat1 inFormat2 = do
--    glBindFramebuffer GL_FRAMEBUFFER (_unFBO fbo)
--    mglDelete glDeleteTextures $ _unTO toOld1
--    mglDelete glDeleteTextures $ _unTO toOld2
--    to1 <- initializeTexture2D fbo GL_COLOR_ATTACHMENT0 xsize ysize minfilt magfilt inFormat1
--    to2 <- initializeTexture2D fbo GL_COLOR_ATTACHMENT1 xsize ysize minfilt magfilt inFormat2
--    withArray [GL_COLOR_ATTACHMENT0, GL_COLOR_ATTACHMENT1] $ \ptr ->
--        glNamedFramebufferDrawBuffers (_unFBO fbo) 2 ptr
--    checkFBO fbo
--    return (fbo, (TO to1, TO to2))

resizeFBOTO3 ::
    (FBO, (TO, TO, TO)) ->
    Int ->
    Int ->
    -- | minification filter
    GLenum ->
    -- | magnification filter
    GLenum ->
    -- | internal color format1
    GLenum ->
    -- | internal color format2
    GLenum ->
    -- | internal color format3
    GLenum ->
    IO (FBO, (TO, TO, TO))
resizeFBOTO3 (fbo, (toOld1, toOld2, told3)) xsize ysize minfilt magfilt inFormat1 inFormat2 inform3 = do
    glBindFramebuffer GL_FRAMEBUFFER (_unFBO fbo)
    mglDelete glDeleteTextures $ _unTO toOld1
    mglDelete glDeleteTextures $ _unTO toOld2
    mglDelete glDeleteTextures $ _unTO told3
    to1 <- initializeTexture2D fbo GL_COLOR_ATTACHMENT0 xsize ysize minfilt magfilt inFormat1
    to2 <- initializeTexture2D fbo GL_COLOR_ATTACHMENT1 xsize ysize minfilt magfilt inFormat2
    to3 <- initializeTexture2D fbo GL_COLOR_ATTACHMENT2 xsize ysize minfilt magfilt inform3
    withArray [GL_COLOR_ATTACHMENT0, GL_COLOR_ATTACHMENT1, GL_COLOR_ATTACHMENT2] $ \ptr ->
        glNamedFramebufferDrawBuffers (_unFBO fbo) 3 ptr
    checkFBO fbo
    return (fbo, (TO to1, TO to2, TO to3))

resizeFBOTO ::
    (FBO, TO) ->
    Int ->
    Int ->
    -- | minification filter
    GLenum ->
    -- | magnification filter
    GLenum ->
    -- | internal color format
    GLenum ->
    IO (FBO, TO)
resizeFBOTO (fbo, oldto) xsize ysize minfilt magfilt inFormat = do
    glBindFramebuffer GL_FRAMEBUFFER (_unFBO fbo)
    mglDelete glDeleteTextures $ _unTO oldto
    to1 <- initializeTexture2D fbo GL_COLOR_ATTACHMENT0 xsize ysize minfilt magfilt inFormat
    checkFBO fbo
    return (fbo, TO to1)

initializeTexture2D :: FBO -> GLenum -> Int -> Int -> GLenum -> GLenum -> GLenum -> IO GLuint
initializeTexture2D fbo attachpoint 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)
    glNamedFramebufferTexture (_unFBO fbo) attachpoint to1 0
    return to1

--getWindowSize :: Integral a => (Config -> ResFactor) -> Config -> (a, a)
--getWindowSize f cfig = (g _windowX, g _windowY)
 -- where
  --  g h = fromIntegral $ h cfig `div` resFactorNum (f cfig)