84 lines
2.8 KiB
Haskell
84 lines
2.8 KiB
Haskell
{-# 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 Graphics.Rendering.OpenGL
|
|
import Graphics.GL.Core43
|
|
--import Foreign
|
|
import Control.Lens
|
|
import Control.Monad
|
|
|
|
sizeFBOs
|
|
:: Int -- ^ Scaled width
|
|
-> Int -- ^ Scaled height
|
|
-> Int -- ^ Full width
|
|
-> Int -- ^ Full height
|
|
-> RenderData
|
|
-> IO RenderData
|
|
sizeFBOs xsize ysize xfull yfull rdata = do
|
|
resizeRBO (_rboBaseBloom rdata) xsize ysize
|
|
rdata' <- foldM (updateFBOTO xsize ysize minMagFilter GL_RGBA8) rdata
|
|
[fboBase, fboColor,fboLighting,fboLightingHigh]
|
|
rdata'' <- foldM (updateFBOTO xsize ysize linMinMagFilter GL_RGBA16F) rdata'
|
|
[fboBloom, fboPos]
|
|
rdata''' <- foldM (updateFBOTO xfull yfull minMagFilter GL_RGBA8) rdata''
|
|
[fbo2, fbo3]
|
|
foldM (updateFBOTO (xsize `div` 2) (ysize `div` 2) linMinMagFilter GL_RGBA16F) rdata'''
|
|
[fboFourth1,fboFourth2]
|
|
|
|
resizeRBO
|
|
:: RenderbufferObject
|
|
-> Int
|
|
-> Int
|
|
-> IO ()
|
|
resizeRBO rboName xsize ysize = do
|
|
let xsize' = fromIntegral xsize
|
|
ysize' = fromIntegral ysize
|
|
bindRenderbuffer Renderbuffer $= rboName
|
|
renderbufferStorage Renderbuffer Depth24Stencil8 (RenderbufferSize xsize' ysize')
|
|
|
|
updateFBOTO
|
|
:: Int
|
|
-> Int
|
|
-> ((TextureFilter, Maybe TextureFilter),TextureFilter)
|
|
-> GLenum -- ^ internal color format
|
|
-> RenderData
|
|
-> ALens' RenderData (FramebufferObject, TextureObject)
|
|
-> IO RenderData
|
|
updateFBOTO xsize ysize mmfilt inFormat pdata target = do
|
|
newfbo2 <- resizeFBOTO (pdata ^# target) xsize ysize mmfilt inFormat
|
|
return $ storing target newfbo2 pdata
|
|
|
|
resizeFBOTO
|
|
:: (FramebufferObject , TextureObject)
|
|
-> Int
|
|
-> Int
|
|
-> ((TextureFilter, Maybe TextureFilter),TextureFilter)
|
|
-> GLenum -- ^ internal color format
|
|
-> IO (FramebufferObject, TextureObject)
|
|
resizeFBOTO (fboName,toOld) xsize ysize mmfilt inFormat = do
|
|
bindFramebuffer Framebuffer $= fboName
|
|
let xsize' = fromIntegral xsize
|
|
ysize' = fromIntegral ysize
|
|
deleteObjectName toOld
|
|
toName <- genObjectName
|
|
textureBinding Texture2D $= Just toName
|
|
glTexStorage2D GL_TEXTURE_2D 1 inFormat xsize' ysize'
|
|
textureFilter Texture2D $= mmfilt
|
|
framebufferTexture2D Framebuffer (ColorAttachment 0) Texture2D toName 0
|
|
fboStatus <- framebufferStatus Framebuffer
|
|
putStrLn $ "after resize, framebuffer status:" ++ show fboStatus
|
|
return (fboName, toName)
|
|
|
|
minMagFilter :: ((TextureFilter, Maybe TextureFilter),TextureFilter)
|
|
minMagFilter = ((Nearest,Nothing),Nearest)
|
|
|
|
linMinMagFilter :: ((TextureFilter, Maybe TextureFilter),TextureFilter)
|
|
linMinMagFilter = ((Linear',Nothing),Linear')
|