justin/loop
1
0
Fork 0
Code Issues Pull Requests 1 Packages Projects Releases Wiki Activity
Files
532f491327bdf70c4999447199549de0754a8b82
loop/src/Render.hs
T

255 lines
9.7 KiB
Haskell
Raw Blame History

module Render
where
import Shader
import Shader.Data
import Shader.Poke
--import MatrixHelper
import Data.Preload.Render
import Picture.Data
--import Picture.Tree
import Geometry
import Geometry.Data
import Polyhedra.Data
import Polyhedra
--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
-> 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
-- 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
-> [(Point3,Float,Float)] -- Lights
-> (Float,Float) -- View from position
-> [Polyhedra] -- foreground geometry
-> [Point2]
-> IO ()
createLightMap pdata resDiv wallPoints lightPoints (viewFromx,viewFromy) fpics scPol = 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]
-- store foreground silhouette geometry into buffer
nSils <- F.foldM (pokeShader $ _lightingLineShadowShader pdata) (concatMap polyToRender fpics)
bindShaderBuffers [_lightingLineShadowShader pdata] [nSils]
-- store foreground geometry and floor into buffer
let addC (xx,yy) = (xx,yy,0)
nsurfVs <- F.foldM (pokeShader (_lightingSurfaceShader pdata))
$ [Render3 $ polyToTris $ map addC $ scPol ]
++ concatMap polyToGeoRender (fpics)
bindShaderBuffers [_lightingSurfaceShader pdata] [nsurfVs]
-- clear buffer to full alpha and furthest depth
-- clearColor is specified in preloadRender
clear [ColorBuffer,DepthBuffer]
cullFace $= Just Back
-- draw walls from your point of view in order to set z buffer
currentProgram $= Just (_shaderProgram $ _lightingWallShader pdata)
drawShader (_lightingWallShader pdata) nWallLights
--colorMask $= Color4 Disabled Disabled Disabled Disabled
--currentProgram $= Just (_shaderProgram $ _lightingOccludeShader pdata)
--uniform (head $ _shaderCustomUnis $ _lightingOccludeShader pdata)
-- $= Vector2 viewFromx viewFromy
--drawShader (_lightingOccludeShader pdata) nWalls
---- draw foreground elements to set z buffer
currentProgram $= Just (_shaderProgram $ _lightingSurfaceShader pdata)
drawShader (_lightingSurfaceShader pdata) nsurfVs
-- 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
--cullFace $= Nothing
depthMask $= Disabled
blendFunc $= (Zero, OneMinusSrcAlpha)
stencilTest $= Enabled
--depthFunc $= Just Less
forM_ lightPoints $ \((x,y,z),r,lum) -> do
-- stencil out shadows
--depthFunc $= Just Less
depthFunc $= Just Lequal
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)
$= Vector3 x y z
drawShader (_lightingOccludeShader pdata) nWalls
--cullFace $= Nothing
currentProgram $= Just (_shaderProgram $ _lightingLineShadowShader pdata)
uniform (head $ _shaderCustomUnis $ _lightingLineShadowShader pdata)
$= Vector3 x y z
drawShader (_lightingLineShadowShader pdata) nSils
cullFace $= Just Front
stencilOp $= (OpKeep,OpKeep,OpDecr)
currentProgram $= Just (_shaderProgram $ _lightingOccludeShader pdata)
drawShader (_lightingOccludeShader pdata) nWalls
currentProgram $= Just (_shaderProgram $ _lightingLineShadowShader pdata)
drawShader (_lightingLineShadowShader pdata) nSils
depthFunc $= Just Lequal
-- draw geometry surfaces
cullFace $= Just Back
colorMask $= Color4 Disabled Disabled Disabled Enabled
stencilFunc $= (Equal, 0, 255)
currentProgram $= Just (_shaderProgram $ _lightingSurfaceShader pdata)
uniform (head $ _shaderCustomUnis $ _lightingSurfaceShader pdata)
$= Vector3 x y z
uniform (_shaderCustomUnis (_lightingSurfaceShader pdata) !! 1)
$= Vector2 r lum
drawShader (_lightingSurfaceShader pdata) nsurfVs
-- draw wall light "circles"
--cullFace $= Nothing
currentProgram $= Just (_shaderProgram $ _lightingWallShader pdata)
uniform (head $ _shaderCustomUnis $ _lightingWallShader pdata)
$= Vector3 x y z
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
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
zipWithM_ drawShader 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
Reference in New Issue View Git Blame Copy Permalink