271 lines
9.9 KiB
Haskell
271 lines
9.9 KiB
Haskell
--{-# 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))
|