263 lines
11 KiB
Haskell
263 lines
11 KiB
Haskell
--{-# 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
|