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 Control.Lens
import Control.Monad
import Data.Preload.Render
import Dodge.Data.Config
import Dodge.WindowSize
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 _gr_world_res cfig)
        >> foldM
            ( uncurry
                updateFBOTO3
                (getWindowSize _gr_world_res 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
                _gr_world_res
                GL_NEAREST
                GL_NEAREST
                GL_RGBA8
                [fboLighting]
            >>= foldUpdateFBOTO
                _gr_world_res
                GL_LINEAR_MIPMAP_LINEAR
                GL_LINEAR
                GL_RGBA16F
                [fboBloom, fboPos]
            >>= foldUpdateFBOTO
                _gr_distortion_res
                GL_LINEAR
                GL_NEAREST
                GL_RGBA8
                [fbo2, fbo3]
            >>= foldUpdateFBOTO
                _gr_downsize_res
                GL_LINEAR_MIPMAP_LINEAR
                GL_LINEAR
                GL_RGBA16F
                [fboHalf1, fboHalf2]
            >>= flip (uncurry updateFBOTO2
                (getWindowSize _gr_world_res cfig)
                GL_NEAREST
                GL_NEAREST
                GL_RGBA8
                GL_RGBA16F)
                fboWindow
  where
    updateFBOTO' f = uncurry updateFBOTO (getWindowSize f cfig)
    foldUpdateFBOTO f minfilt magfilt form =
        ffoldM (updateFBOTO' f minfilt magfilt form)

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

resizeRBO :: GLuint -> 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 form pdata target = do
    newfbo2 <- resizeFBOTO (pdata ^# target) xsize ysize minfilt magfilt form
    return $ storing target newfbo2 pdata

-- note that the ordering of arguments is different to the other update
-- functions... this all needs rethinking
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 form1 form2 pdata target = do
    newfbo2 <- resizeFBOTO2 (pdata ^# target) xsize ysize minfilt magfilt form1 form2
    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 form1 form2 form3 pdata target = do
    newfbo2 <- resizeFBOTO3 (pdata ^# target) xsize ysize minfilt magfilt form1 form2 form3
    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, (told1, told2)) xsize ysize minfilt magfilt form1 form2 = do
    glBindFramebuffer GL_FRAMEBUFFER (_unFBO fbo)
    mglDelete glDeleteTextures $ _unTO told1
    mglDelete glDeleteTextures $ _unTO told2
    to1 <- initializeTexture2D fbo GL_COLOR_ATTACHMENT0 xsize ysize minfilt magfilt form1
    to2 <- initializeTexture2D fbo GL_COLOR_ATTACHMENT1 xsize ysize minfilt magfilt form2
    withArray [GL_COLOR_ATTACHMENT0, GL_COLOR_ATTACHMENT1] $
        glNamedFramebufferDrawBuffers (_unFBO fbo) 2
    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, (told1, told2, told3)) xsize ysize minfilt magfilt form1 form2 form3 = do
    glBindFramebuffer GL_FRAMEBUFFER (_unFBO fbo)
    mglDelete glDeleteTextures $ _unTO told1
    mglDelete glDeleteTextures $ _unTO told2
    mglDelete glDeleteTextures $ _unTO told3
    to1 <- initializeTexture2D fbo GL_COLOR_ATTACHMENT0 xsize ysize minfilt magfilt form1
    to2 <- initializeTexture2D fbo GL_COLOR_ATTACHMENT1 xsize ysize minfilt magfilt form2
    to3 <- initializeTexture2D fbo GL_COLOR_ATTACHMENT2 xsize ysize minfilt magfilt form3
    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 form = do
    glBindFramebuffer GL_FRAMEBUFFER (_unFBO fbo)
    mglDelete glDeleteTextures $ _unTO oldto
    to1 <- initializeTexture2D fbo GL_COLOR_ATTACHMENT0 xsize ysize minfilt magfilt form
    checkFBO fbo
    return (fbo, TO to1)

initializeTexture2D 
    :: FBO -> GLenum -> Int -> Int -> GLenum -> GLenum -> GLenum -> IO GLuint
initializeTexture2D fbo attachpoint x y minfilt magfilt form = do
    let xsize' = fromIntegral x
        ysize' = fromIntegral y
    to1 <- mglCreate (glCreateTextures GL_TEXTURE_2D)
    glTextureStorage2D to1 1 form 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