--{-# LANGUAGE Strict #-} {-# LANGUAGE DeriveFoldable, StandaloneDeriving #-} module Picture.Render ( renderPicture' , renderFoldable , picToLTree ) where import Shader import MatrixHelper import Control.Lens import Control.Monad import qualified Control.Foldl as F import Picture.Preload import Picture.Data import Picture.Tree import Geometry 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 as SDL renderPicture' :: RenderData -> Float -> Float -> (Float,Float) -> (Float,Float) -> [(Point2,Point2)] -> [Point4] -> (Float,Float) -> Picture -> IO (Word32,Word32) renderPicture' pdata rot zoom (tranx,trany) (winx,winy) wallPoints lightPoints (viewFromx,viewFromy) pic = do wallPokeStart <- SDL.ticks -- setting the depth function to less, instead of lequal, -- seems to stop a lot of unecessary drawing -- of wall shadows when creating the light map depthFunc $= Just Less -- set common uniforms setShaderUniforms rot zoom (tranx,trany) (winx,winy) ( (extractProgAndUnis $ _lightSourceShader pdata) : (extractProgAndUnis $ _wallShadowShader pdata) : (extractProgAndUnis $ _wallLightShader pdata) : (extractProgAndUnis $ _wallShader pdata) : (extractProgAndUnis $ _backgroundShader pdata) : (map extractProgAndUnis $ _listShaders pdata) ) -- draw lightmap bindFramebuffer Framebuffer $= (_spareFBO pdata) clearColor $= Color4 0 0.5 0 1 depthFunc $= Just Less clearDepth $= 1 clear [ColorBuffer,DepthBuffer] -- calculate perspective matrix pmat <- (newMatrix RowMajor $ perspectiveMatrix rot zoom (tranx,trany) (winx,winy) (viewFromx,viewFromy) ) :: IO (GLmatrix GLfloat) nWallLights <- F.foldM (pokeShader $ _wallLightShader pdata) wallPoints bindShaderBuffers [_wallLightShader pdata] [nWallLights] currentProgram $= Just (_shaderProgram $ _wallLightShader pdata) uniform ( (fromJust $ _shaderCustomUnis $ _wallLightShader pdata) !! 1) $= pmat nWalls <- F.foldM (pokeShader $ _wallShadowShader pdata) wallPoints bindShaderBuffers [_wallShadowShader pdata] [nWalls] 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 cullFace $= Nothing drawShader (_wallShadowShader pdata) nWalls depthMask $= Disabled blendFunc $= (Zero, OneMinusSrcAlpha) -- blendFuncSeparate $= ((Zero,Zero),(Zero, OneMinusSrcAlpha)) stencilTest $= Enabled forM_ lightPoints $ \(x,y,r,lum) -> do -- depthFunc $= Just Less colorMask $= (Color4 Disabled Disabled Disabled Disabled) clear [StencilBuffer] cullFace $= Just Back -- stencilOp $= (OpKeep,OpKeep,OpReplace) stencilOp $= (OpKeep,OpKeep,OpIncr) stencilFunc $= (Always, 0, 255) -- currentProgram does get called twice: here and inside drawShader below currentProgram $= Just (_shaderProgram $ _wallShadowShader pdata) uniform (head $ fromJust $ _shaderCustomUnis $ _wallShadowShader pdata) $= Vector2 x y -- blendFunc $= (Zero,One) drawShader (_wallShadowShader pdata) nWalls cullFace $= Just Front stencilOp $= (OpKeep,OpKeep,OpDecr) drawShader (_wallShadowShader pdata) nWalls cullFace $= Nothing colorMask $= (Color4 Enabled Enabled Enabled Enabled) 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) bindShaderBuffers [_lightSourceShader pdata] [1] stencilFunc $= (Equal, 0, 255) drawShader (_lightSourceShader pdata) 1 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 startWallTicks <- SDL.ticks wallPokeEnd <- SDL.ticks ticksS <- SDL.ticks ticksAfterL <- SDL.ticks blend $= Disabled -- blendFunc $= (Zero,One) bindFramebuffer Framebuffer $= defaultFramebufferObject -- -- blendFunc $= (SrcAlpha, OneMinusSrcAlpha) bindShaderBuffers [_fullscreenShader pdata] [4] textureBinding Texture2D $= Just (_fboTexture pdata) -- blendFunc $= (One, Zero) drawShader (_fullscreenShader pdata) 4 blend $= Enabled -- draw picture on top of light/shadow map -- set drawing for on top blendFuncSeparate $= ((SrcAlphaSaturate, OneMinusSrcAlpha), (Zero,One)) clear [DepthBuffer] -- draw background bindArrayBuffers 1 $ _vaoBufferTargets $ _shaderVAO $ _backgroundShader pdata depthFunc $= Just Less 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 $= (fmap _textureObject $ _shaderTexture $ _backgroundShader pdata) drawArrays Points (fromIntegral 0) (fromIntegral 1) depthFunc $= Just Lequal -- draw layer 0 ticks2 <- renderFoldable pdata rot zoom (tranx,trany) (winx,winy) $ picToLTree (Just 0) pic --((picToAlt 0 pic) :: [RenderType]) -- reset blend so that light map doesn't apply blendFunc $= (SrcAlpha,OneMinusSrcAlpha) ticks3 <- renderFoldable pdata rot zoom (tranx,trany) (winx,winy) $ picToLTree (Just 1) pic -- set drawing for on top aticks <- SDL.ticks blendFuncSeparate $= ((SrcAlphaSaturate, OneMinusSrcAlpha), (Zero,One)) ticks4 <- renderFoldable pdata rot zoom (tranx,trany) (winx,winy) $ picToLTree (Just 2) pic bticks <- SDL.ticks resetShaderUniforms (map extractProgAndUnis $ _listShaders pdata) endWallTicks <- SDL.ticks --return (ticksAfterL, ticks2+ticks3+ticks4, endWallTicks - startWallTicks) ticksE <- SDL.ticks --return (ticksAfterL, ticksE - ticksS) --return (ticksAfterL, ticks2 + ticks3 + ticks4) return (ticksAfterL, wallPokeEnd - wallPokeStart) ----------------end renderPicture' renderFoldable :: Foldable f => RenderData -> Float -> Float -> (Float,Float) -> (Float,Float) -> f RenderType -> IO Word32 renderFoldable pdata rot zoom (tranx,trany) (winx,winy) 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 mkShadFromWall :: (Point2,Point2,Point2,Point2) -> Point4 -> [(Point3,Point4)] {-# INLINE mkShadFromWall #-} mkShadFromWall (wla,wlb,_,_) (x,y,r,_) = makeHexahedron $ prismQuad (f wla ,f wlb ,f $ wla +.+ r *.* normalizeV (wla -.- ls) ,f $ wlb +.+ r *.* normalizeV (wlb -.- ls) ) where f (x,y) = (x,y,0) ls = (x,y) prismQuad :: (Point3,Point3,Point3,Point3) -> (Point3,Point3,Point3,Point3 ,Point3,Point3,Point3,Point3) {-# INLINE prismQuad #-} prismQuad (a,b,c,d) = (a,b,c,d,f a,f b,f d,f c) where f (x,y,z) = (x,y,z-0.5) -- note this doubles the first and last points, assumes these points will be -- input as part of a triangle strip makeHexahedron :: (Point3,Point3,Point3,Point3 ,Point3,Point3,Point3,Point3) -> [(Point3,Point4)] {-# INLINE makeHexahedron #-} makeHexahedron (a1,a2,a3,a4,a5,a6,a7,a8) = [cr a4 ,cr a4 ,cr a3 ,cr a7 ,cr a8 ,cr a5 ,cr a3 ,cb a1 ,cb a4 ,cr a2 ,cr a7 ,cr a6 ,cr a5 ,cr a2 ,cr a1 ,cr a1 ] where col = (1,0,1,0.1) cr a = (a,(1,0,0,0.1)) cg a = (a,(0,1,0,0.1)) cb a = (a,(0,0,1,0.1))