288 lines
10 KiB
Haskell
288 lines
10 KiB
Haskell
--{-# LANGUAGE DeriveFoldable, StandaloneDeriving #-}
|
|
{-
|
|
Rendering of a picture.
|
|
-}
|
|
module Picture.Render
|
|
where
|
|
import Shader
|
|
import Shader.Data
|
|
import Shader.Poke
|
|
--import MatrixHelper
|
|
import Data.Preload.Render
|
|
import Picture.Data
|
|
--import Geometry
|
|
import Geometry.Data
|
|
|
|
--import Control.Lens
|
|
import Control.Monad
|
|
import qualified Control.Foldl as F
|
|
import Foreign hiding (rotate)
|
|
import Graphics.Rendering.OpenGL hiding (Line,translate,scale,imageHeight,Polygon,Color,T)
|
|
--import Data.Foldable
|
|
import Data.Tuple.Extra
|
|
--import qualified Data.IntMap.Strict as IM
|
|
import qualified SDL
|
|
|
|
setWallDepth
|
|
:: RenderData
|
|
-> [(Point2,Point2)] -- ^ Wall points
|
|
-> (Float,Float) -- ^ View from point
|
|
-> GLmatrix GLfloat
|
|
-> IO Word32
|
|
setWallDepth pdata wallPoints (viewFromx,viewFromy) _ = do
|
|
startTicks <- SDL.ticks
|
|
colorMask $= Color4 Disabled Disabled Disabled Disabled
|
|
nWalls <- F.foldM (pokeShader $ _lightingOccludeShader pdata) (map Render22 wallPoints)
|
|
bindShaderBuffers [_lightingOccludeShader pdata] [nWalls]
|
|
|
|
currentProgram $= Just (_shaderProgram $ _lightingOccludeShader pdata)
|
|
-- reseting this uniform appears to be necessary
|
|
uniform (head $ _shaderCustomUnis $ _lightingOccludeShader pdata)
|
|
$= Vector2 viewFromx viewFromy
|
|
-- the following uniform, however, was probably already set by
|
|
-- createLightMap
|
|
-- uniform ( (_shaderMatrixUniform $ _lightingOccludeShader pdata))
|
|
-- $= pmat
|
|
-- cullFace $= Just Front
|
|
drawShader (_lightingOccludeShader pdata) nWalls
|
|
colorMask $= Color4 Enabled Enabled Enabled Enabled
|
|
endTicks <- SDL.ticks
|
|
return $ endTicks - startTicks
|
|
|
|
divideSize :: Int -> Size -> Size
|
|
divideSize i (Size x y) = Size (div x $ fromIntegral i) (div y $ fromIntegral i)
|
|
|
|
{- |
|
|
Determine where light is shining in the world.
|
|
Note that this currently (1/5/2021) sets the bound framebuffer to fbo2.
|
|
The lightmap itself is rendered into this buffer. -}
|
|
createLightMap
|
|
:: RenderData
|
|
-> Int -- Resolution division
|
|
-> [(Point2,Point2)] -- Wall pairs
|
|
-> [Point4] -- Lights
|
|
-> (Float,Float) -- View from position
|
|
-> GLmatrix GLfloat -- perspective matrix
|
|
-> Picture -- foreground pictures
|
|
-> IO ()
|
|
createLightMap pdata resDiv wallPoints lightPoints (viewFromx,viewFromy) pmat _ = do
|
|
|
|
-- get viewport size so we can reset it later
|
|
(vppos,vpsize) <- get viewport
|
|
-- set the viewport size to that of the render buffer
|
|
viewport $= (vppos, divideSize resDiv vpsize)
|
|
bindFramebuffer Framebuffer $= _spareFBO pdata
|
|
|
|
-- store wall and light positions into buffer
|
|
nWallLights <- F.foldM (pokeShader $ _lightingWallShader pdata) (map Render22 wallPoints)
|
|
bindShaderBuffers [_lightingWallShader pdata] [nWallLights]
|
|
nWalls <- F.foldM (pokeShader $ _lightingOccludeShader pdata) (map Render22 wallPoints)
|
|
bindShaderBuffers [_lightingOccludeShader pdata] [nWalls]
|
|
-- set uniforms for shader that draws lights
|
|
currentProgram $= Just (_shaderProgram $ _lightingWallShader pdata)
|
|
uniform (_shaderMatrixUniform $ _lightingWallShader pdata)
|
|
$= pmat
|
|
-- clear buffer to full alpha and furthest depth
|
|
clearColor $= Color4 0 0 0 1
|
|
clearDepth $= 1
|
|
clear [ColorBuffer,DepthBuffer]
|
|
depthFunc $= Just Less
|
|
-- draw walls from your point of view in order to set z buffer
|
|
colorMask $= Color4 Disabled Disabled Disabled Disabled
|
|
currentProgram $= Just (_shaderProgram $ _lightingOccludeShader pdata)
|
|
uniform (head $ _shaderCustomUnis $ _lightingOccludeShader pdata)
|
|
$= Vector2 viewFromx viewFromy
|
|
uniform (_shaderMatrixUniform $ _lightingOccludeShader pdata) $= pmat
|
|
cullFace $= Just Back
|
|
drawShader (_lightingOccludeShader pdata) nWalls
|
|
|
|
cullFace $= Nothing
|
|
---- draw foreground elements to set z buffer
|
|
-- forM_ (_pictureShaders pdata) $ \shad -> do
|
|
-- currentProgram $= Just (_shaderProgram shad)
|
|
-- uniform (_shaderUniforms shad !! 4) $= pmat
|
|
-- _ <- renderFoldable pdata $ picToLTree (Just 0) fpics
|
|
|
|
-- for each of the lights:
|
|
-- stencil out the walls from this light's point of view
|
|
-- draw fading lightmap circles on the floor
|
|
-- draw fading lightmaps on the walls
|
|
depthMask $= Disabled
|
|
blendFunc $= (Zero, OneMinusSrcAlpha)
|
|
stencilTest $= Enabled
|
|
forM_ lightPoints $ \(x,y,r,lum) -> do
|
|
-- bind buffer for floor light circle
|
|
let lightPtr = _vboPointer $ _vaoVBO $ _shaderVAO $ _lightingFloorShader pdata
|
|
pokeFourOff lightPtr 0 (x,y,r,lum)
|
|
-- stencil out walls
|
|
colorMask $= Color4 Disabled Disabled Disabled Disabled
|
|
clear [StencilBuffer]
|
|
cullFace $= Just Back
|
|
stencilOp $= (OpKeep,OpKeep,OpIncr)
|
|
stencilFunc $= (Always, 0, 255)
|
|
currentProgram $= Just (_shaderProgram $ _lightingOccludeShader pdata)
|
|
uniform (head $ _shaderCustomUnis $ _lightingOccludeShader pdata)
|
|
$= Vector2 x y
|
|
drawShader (_lightingOccludeShader pdata) nWalls
|
|
cullFace $= Just Front
|
|
stencilOp $= (OpKeep,OpKeep,OpDecr)
|
|
drawShader (_lightingOccludeShader pdata) nWalls
|
|
-- draw floor light circles
|
|
cullFace $= Nothing
|
|
colorMask $= Color4 Disabled Disabled Disabled Enabled
|
|
bindShaderBuffers [_lightingFloorShader pdata] [1]
|
|
stencilFunc $= (Equal, 0, 255)
|
|
drawShader (_lightingFloorShader pdata) 1
|
|
-- draw wall light "circles"
|
|
currentProgram $= Just (_shaderProgram $ _lightingWallShader pdata)
|
|
uniform (head $ _shaderCustomUnis $ _lightingWallShader pdata)
|
|
$= Vector2 x y
|
|
uniform (_shaderCustomUnis (_lightingWallShader pdata) !! 1)
|
|
$= Vector2 r lum
|
|
drawShader (_lightingWallShader pdata) nWallLights
|
|
cullFace $= Nothing
|
|
stencilTest $= Disabled
|
|
blend $= Disabled
|
|
|
|
-- set the viewport size to that of the window
|
|
viewport $= (vppos, vpsize)
|
|
-- disable depth testing for blurring
|
|
depthFunc $= Just Always
|
|
-- draw the lightmap on a full size fbo
|
|
bindFramebuffer Framebuffer $= fst3 (_fbo2 pdata)
|
|
colorMask $= Color4 Disabled Disabled Disabled Enabled
|
|
bindShaderBuffers [_boxBlurShader pdata] [4]
|
|
textureBinding Texture2D $= Just (_fboTexture pdata)
|
|
-- by upscaling the shadowmap texture and using Linear' magnification
|
|
-- interpolation, we get a poor mans blur, not sure about performance
|
|
textureFilter Texture2D $= ((Linear',Just Linear') , Linear')
|
|
generateMipmap' Texture2D
|
|
drawShader (_boxBlurShader pdata) 4
|
|
|
|
-- ping pong blur between '_fbo2' and '_fbo3' as many times as desired
|
|
replicateM_ 3 $ pingPongBlur pdata
|
|
|
|
-- reset drawing parameters ready for drawing on top of the light map
|
|
colorMask $= Color4 Enabled Enabled Enabled Enabled
|
|
depthMask $= Enabled
|
|
blend $= Enabled
|
|
|
|
{- |
|
|
Blur between two framebuffers.
|
|
Assumes no depth testing is done (depthFunc %= Just Always).
|
|
-}
|
|
pingPongBlur :: RenderData -> IO ()
|
|
pingPongBlur pdata = do
|
|
bindFramebuffer Framebuffer $= fst3 (_fbo3 pdata)
|
|
textureBinding Texture2D $= Just (snd3 $ _fbo2 pdata)
|
|
textureFilter Texture2D $= ((Linear',Just Linear') , Linear')
|
|
generateMipmap' Texture2D
|
|
drawShader (_boxBlurShader pdata) 4
|
|
|
|
bindFramebuffer Framebuffer $= fst3 (_fbo2 pdata)
|
|
textureBinding Texture2D $= Just (snd3 $ _fbo3 pdata)
|
|
textureFilter Texture2D $= ((Linear',Just Linear') , Linear')
|
|
generateMipmap' Texture2D
|
|
drawShader (_boxBlurShader pdata) 4
|
|
|
|
renderBackground
|
|
:: RenderData
|
|
-> Float -- Rotation
|
|
-> Float -- Zoom
|
|
-> (Float,Float) -- Translation
|
|
-> (Float,Float) -- Window size
|
|
-> IO ()
|
|
renderBackground pdata rot camZoom (tranx,trany) (winx,winy) = do
|
|
-- depthFunc $= Just Less
|
|
-- set drawing for on top
|
|
--blendFuncSeparate $= ((SrcAlphaSaturate, OneMinusSrcAlpha), (Zero,One))
|
|
-- draw background
|
|
--bindArrayBuffers 1 $ _vaoBufferTargets $ _shaderVAO $ _backgroundShader pdata
|
|
bindArrayBuffers 1 $ _vaoVBO $ _shaderVAO $ _backgroundShader pdata
|
|
currentProgram $= Just (_shaderProgram $ _backgroundShader pdata)
|
|
bindVertexArrayObject $= Just (_vao $ _shaderVAO $ _backgroundShader pdata)
|
|
let backPtr = _vboPointer $ _vaoVBO $ _shaderVAO $ _backgroundShader pdata
|
|
pokeArrayOff backPtr 0 [tranx,trany,rot,camZoom,winx,winy]
|
|
textureBinding Texture2D $= _textureObject <$> _shaderTexture (_backgroundShader pdata)
|
|
drawArrays Points 0 1
|
|
|
|
setPerpMatrixUniforms
|
|
:: RenderData
|
|
-> Float -- ^ Rotation
|
|
-> Float -- ^ Zoom
|
|
-> (Float,Float) -- ^ Translation
|
|
-> (Float,Float) -- ^ Window size
|
|
-> (Float,Float) -- ^ ViewFrom
|
|
-> IO ()
|
|
setPerpMatrixUniforms pdata rot czoom trans wins vfs = mapM_ (setPerpMatUniform rot czoom trans wins vfs)
|
|
$ ( (_lightingFloorShader pdata)
|
|
: (_backgroundShader pdata)
|
|
: (_textureShader pdata)
|
|
: (_textureArrayShader pdata)
|
|
: (_pictureShaders pdata)
|
|
)
|
|
|
|
renderShader
|
|
:: Foldable f
|
|
=> FullShader
|
|
-> f RenderType
|
|
-> IO Word32
|
|
renderShader shad dat = do
|
|
sticks <- SDL.ticks
|
|
i <- F.foldM (pokeShader shad) dat
|
|
bindShaderBuffers [shad] [i]
|
|
drawShader shad i
|
|
eticks <- SDL.ticks
|
|
return $ eticks - sticks
|
|
|
|
renderFoldable
|
|
:: Foldable f
|
|
=> RenderData
|
|
-> f RenderType
|
|
-> IO Word32
|
|
renderFoldable pdata struct = do
|
|
pokeStartTicks <- SDL.ticks
|
|
|
|
let slist = _pictureShaders pdata
|
|
|
|
-- poke data, returns list buffer sizes for each shader
|
|
is <- F.foldM (traverse pokeShader slist) struct
|
|
|
|
-- the idea of binding many buffers at once, rather than interweaving with draw
|
|
-- calls, is to prevent opengl from waiting for a draw call to finish
|
|
-- before it performs another state change
|
|
bindShaderBuffers slist is
|
|
|
|
drawShaders slist is
|
|
|
|
pokeEndTicks <- SDL.ticks
|
|
return $ pokeEndTicks - pokeStartTicks
|
|
------------------------------end renderFoldable
|
|
|
|
pokeTwoOff
|
|
:: Ptr Float
|
|
-> Int
|
|
-> (Float,Float)
|
|
-> IO ()
|
|
{-# INLINE pokeTwoOff #-}
|
|
pokeTwoOff ptr n (x,y) = do
|
|
pokeElemOff ptr (2*n+0) x
|
|
pokeElemOff ptr (2*n+1) y
|
|
pokeThreeOff
|
|
:: Ptr Float
|
|
-> Int
|
|
-> (Float,Float,Float)
|
|
-> IO ()
|
|
{-# INLINE pokeThreeOff #-}
|
|
pokeThreeOff ptr n (x,y,z) = do
|
|
pokeElemOff ptr (3*n+0) x
|
|
pokeElemOff ptr (3*n+1) y
|
|
pokeElemOff ptr (3*n+2) z
|
|
pokeFourOff :: Ptr Float -> Int -> (Float,Float,Float,Float) -> IO ()
|
|
{-# INLINE pokeFourOff #-}
|
|
pokeFourOff ptr n (x,y,z,w) = do
|
|
pokeElemOff ptr (4*n+0) x
|
|
pokeElemOff ptr (4*n+1) y
|
|
pokeElemOff ptr (4*n+2) z
|
|
pokeElemOff ptr (4*n+3) w
|