--{-# LANGUAGE DeriveFoldable, StandaloneDeriving #-} {- Rendering of a picture. -} module Picture.Render ( module Picture.Render , picToLTree ) where import Shader import MatrixHelper import Picture.Preload import Picture.Data import Picture.Tree import Geometry 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,imageWidth,Polygon,Color,T) import Data.Foldable import Data.Maybe (fromJust) import qualified Data.IntMap.Strict as IM import qualified SDL renderPicture :: RenderData -- ^ Preloaded render data -> Float -- ^ Rotation -> Float -- ^ Zoom -> Point2 -- ^ Translation -> Point2 -- ^ Window size -> [((Point2,Point2),Point4)] -- ^ Wall data -> [((Point2,Point2),Point4)] -- ^ Window data -> [Point4] -- ^ Lights data -> (Float,Float) -- ^ View from point -> Picture -- ^ Picture -> IO Word32 -- ^ Time taken according to SDL.ticks renderPicture pdata rot zoom trans@(tranx,trany) wins@(winx,winy) wallPointsCol windowPoints lightPoints viewFroms@(viewFromx,viewFromy) pic = do startTicks <- SDL.ticks let wallPoints = map fst wallPointsCol setCommonUniforms pdata rot zoom trans wins depthFunc $= Just Less pmat <- (newMatrix RowMajor $ perspectiveMatrix rot zoom (tranx,trany) (winx,winy) (viewFromx,viewFromy) ) :: IO (GLmatrix GLfloat) createLightMap pdata rot zoom trans wins wallPoints lightPoints viewFroms pmat renderBackground pdata rot zoom trans wins renderWalls pdata wallPointsCol pmat setWallDepth pdata wallPoints (viewFromx,viewFromy) pmat depthFunc $= Just Lequal renderFoldable pdata $ picToLTree (Just 0) pic -- reset blend so that light map doesn't apply -- blendFunc $= (SrcAlpha,OneMinusSrcAlpha) blendFuncSeparate $= ((SrcAlpha,OneMinusSrcAlpha) , (Zero,One)) -- blendFunc $= (SrcAlpha,OneMinusSrcAlpha) renderFoldable pdata $ picToLTree (Just 1) pic -- set drawing for on top blendFuncSeparate $= ((SrcAlphaSaturate, OneMinusSrcAlpha), (Zero,One)) renderFoldable pdata $ picToLTree (Just 2) pic depthMask $= Disabled renderWalls pdata windowPoints pmat depthMask $= Enabled resetShaderUniforms (map extractProgAndUnis $ _listShaders pdata) endTicks <- SDL.ticks return (endTicks - startTicks) renderWalls :: RenderData -> [((Point2,Point2),Point4)] -> GLmatrix GLfloat -> IO () renderWalls pdata wps pmat = do n <- F.foldM (pokeShader $ _wallFaceShader pdata) wps bindShaderBuffers [_wallFaceShader pdata] [n] currentProgram $= Just (_shaderProgram $ _wallFaceShader pdata) uniform (head (fromJust $ _shaderCustomUnis $ _wallFaceShader pdata) ) $= pmat drawShader (_wallFaceShader pdata) n setWallDepth :: RenderData -> [(Point2,Point2)] -> (Float,Float) -> GLmatrix GLfloat -> IO Word32 setWallDepth pdata wallPoints (viewFromx,viewFromy) pmat = do startTicks <- SDL.ticks colorMask $= Color4 Disabled Disabled Disabled Disabled nWalls <- F.foldM (pokeShader $ _wallShadowShader pdata) wallPoints bindShaderBuffers [_wallShadowShader pdata] [nWalls] currentProgram $= Just (_shaderProgram $ _wallShadowShader pdata) uniform (head $ fromJust $ _shaderCustomUnis $ _wallShadowShader pdata) $= Vector2 viewFromx viewFromy uniform ( fromJust (_shaderCustomUnis $ _wallShadowShader pdata) !! 1) $= pmat uniform ( fromJust (_shaderCustomUnis $ _wallShadowShader pdata) !! 2) $= (0 :: Float) -- cullFace $= Just Front drawShader (_wallShadowShader pdata) nWalls colorMask $= Color4 Enabled Enabled Enabled Enabled endTicks <- SDL.ticks return $ endTicks - startTicks createLightMap :: RenderData -> Float -> Float -> (Float,Float) -> (Float,Float) -> [(Point2,Point2)] -> [Point4] -> (Float,Float) -> GLmatrix GLfloat -> IO () createLightMap pdata rot zoom (tranx,trany) (winx,winy) wallPoints lightPoints (viewFromx,viewFromy) pmat = do bindFramebuffer Framebuffer $= _spareFBO pdata -- clear buffer to full alpha and furthest depth clearColor $= Color4 0 0 0 1 clearDepth $= 1 clear [ColorBuffer,DepthBuffer] depthFunc $= Just Less -- store wall and light positions into buffer nWallLights <- F.foldM (pokeShader $ _wallLightShader pdata) wallPoints bindShaderBuffers [_wallLightShader pdata] [nWallLights] nWalls <- F.foldM (pokeShader $ _wallShadowShader pdata) wallPoints bindShaderBuffers [_wallShadowShader pdata] [nWalls] -- set uniforms for shader that draws lights currentProgram $= Just (_shaderProgram $ _wallLightShader pdata) uniform ( fromJust (_shaderCustomUnis $ _wallLightShader pdata) !! 1) $= pmat -- draw walls from your point of view in order to set z buffer colorMask $= Color4 Disabled Disabled Disabled Disabled let (tx,ty) = (tranx,trany) -.- (viewFromx,viewFromy) currentProgram $= Just (_shaderProgram $ _wallShadowShader pdata) uniform (head $ fromJust $ _shaderCustomUnis $ _wallShadowShader pdata) $= Vector2 viewFromx viewFromy uniform ( fromJust (_shaderCustomUnis $ _wallShadowShader pdata) !! 1) $= pmat uniform ( fromJust (_shaderCustomUnis $ _wallShadowShader pdata) !! 2) $= (0 :: Float) cullFace $= Just Back drawShader (_wallShadowShader pdata) nWalls -- 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 = (\(_,ptr,_) -> ptr) $ head $ _vaoBufferTargets $ _shaderVAO $ _lightSourceShader pdata (x',y') = zTran $ rotateV (0 - rot) $ (x,y) -.- (tranx,trany) zTran (a,b) = (a*2*zoom / winx, b*2*zoom / winy) 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 $ _wallShadowShader pdata) uniform (head $ fromJust $ _shaderCustomUnis $ _wallShadowShader pdata) $= Vector2 x y drawShader (_wallShadowShader pdata) nWalls cullFace $= Just Front stencilOp $= (OpKeep,OpKeep,OpDecr) drawShader (_wallShadowShader pdata) nWalls -- draw floor light circles cullFace $= Nothing colorMask $= Color4 Disabled Disabled Disabled Enabled bindShaderBuffers [_lightSourceShader pdata] [1] stencilFunc $= (Equal, 0, 255) drawShader (_lightSourceShader pdata) 1 -- draw wall light "circles" currentProgram $= Just (_shaderProgram $ _wallLightShader pdata) uniform (head $ fromJust $ _shaderCustomUnis $ _wallLightShader pdata) $= Vector2 x y uniform (fromJust (_shaderCustomUnis $ _wallLightShader pdata) !! 2) $= Vector2 r lum drawShader (_wallLightShader pdata) nWallLights depthMask $= Enabled cullFace $= Nothing stencilTest $= Disabled blend $= Disabled bindFramebuffer Framebuffer $= defaultFramebufferObject colorMask $= Color4 Disabled Disabled Disabled Enabled bindShaderBuffers [_fullscreenShader pdata] [4] textureBinding Texture2D $= Just (_fboTexture pdata) drawShader (_fullscreenShader pdata) 4 colorMask $= Color4 Enabled Enabled Enabled Enabled blend $= Enabled renderBackground :: RenderData -> Float -> Float -> (Float,Float) -> (Float,Float) -> IO () renderBackground pdata rot zoom (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 currentProgram $= Just (_shaderProgram $ _backgroundShader pdata) bindVertexArrayObject $= Just (_vao $ _shaderVAO $ _backgroundShader pdata) let backPtr = (\(_,x,_) -> x) $ head $ _vaoBufferTargets $ _shaderVAO $ _backgroundShader pdata backPtr2 = (\(_,x,_) -> x) $ _vaoBufferTargets (_shaderVAO $ _backgroundShader pdata) !! 1 pokeFourOff backPtr 0 (tranx,trany,rot,zoom) pokeTwoOff backPtr2 0 (winx,winy) textureBinding Texture2D $= _textureObject <$> _shaderTexture (_backgroundShader pdata) drawArrays Points 0 1 setCommonUniforms :: RenderData -> Float -> Float -> (Float,Float) -> (Float,Float) -> IO () setCommonUniforms pdata rot zoom (tranx,trany) (winx,winy) = do setShaderUniforms rot zoom (tranx,trany) (winx,winy) ( extractProgAndUnis (_lightSourceShader pdata) : extractProgAndUnis (_wallShadowShader pdata) : extractProgAndUnis (_wallLightShader pdata) : extractProgAndUnis (_backgroundShader pdata) : map extractProgAndUnis (_listShaders pdata) ) renderFoldable :: Foldable f => RenderData -> f RenderType -> IO Word32 renderFoldable pdata tree = do pokeStartTicks <- SDL.ticks let slist = _listShaders pdata -- poke data, returns list of number of vertices for each shader is <- F.foldM (pokeShaders slist) tree -- the idea of doing as binding of 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