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