justin/loop
1
0
Fork 0
Code Issues Pull Requests 1 Packages Projects Releases Wiki Activity

Refactor light source and wall shadow shaders

Browse Source
This commit is contained in:
justin
2021-03-11 01:16:42 +01:00
parent e2c35b21bc
commit 6c378659b2
4 changed files with 83 additions and 109 deletions
Download Patch File Download Diff File Expand all files Collapse all files
app/Main.hs
+1 -1
View File
@@ -60,7 +60,7 @@ main = do
(lightsForGloom' w) (lightsForGloom' w)
(worldPictures w) (worldPictures w)
blendFunc $= (SrcAlpha,OneMinusSrcAlpha) blendFunc $= (SrcAlpha,OneMinusSrcAlpha)
renderTree' (_renderData preData) (_cameraRot w) (_cameraZoom w) (_cameraPos w) renderFoldable (_renderData preData) (_cameraRot w) (_cameraZoom w) (_cameraPos w)
(_windowX w,_windowY w) (_windowX w,_windowY w)
--(picToLTree (Just 1) $ fixedCoordPictures w) --(picToLTree (Just 1) $ fixedCoordPictures w)
(picToLTree Nothing $ fixedCoordPictures w) (picToLTree Nothing $ fixedCoordPictures w)
src/Picture/Preload.hs
+15 -4
View File
@@ -15,14 +15,17 @@ import Control.Lens
--import Control.Monad --import Control.Monad
import Foreign import Foreign
import Shader import Shader
import Geometry (Point2)
data RenderData = RenderData data RenderData = RenderData
{ _textures :: [TextureObject] { _textures :: [TextureObject]
, _backShader :: (Program, [UniformLocation]) , _backShader :: (Program, [UniformLocation])
, _wallShadowShader :: (Program, [UniformLocation]) , _wallShadowShader :: (Program, [UniformLocation])
, _lightmapCircleShader :: (Program, [UniformLocation]) -- , _lightmapCircleShader :: (Program, [UniformLocation])
, _lightSourceShader :: FullShader (Float,Float,Float,Float)
, _wlShadShader :: FullShader (Point2,Point2,Point2,Point2)
, _listShaders :: [FullShader RenderType] , _listShaders :: [FullShader RenderType]
, _backVAO :: VAO , _backVAO :: VAO
, _wallVAO :: VAO , _wallVAO :: VAO
@@ -56,14 +59,20 @@ vert = VertexShader
geom = GeometryShader geom = GeometryShader
frag = FragmentShader frag = FragmentShader
pokeWPStrat :: (Point2,Point2,Point2,Point2) -> [[[Float]]]
pokeWPStrat ((x,y),(z,w),(a,b),(c,d)) = [[[x,y,z,w],[a,b,c,d]]]
preloadRender :: IO RenderData preloadRender :: IO RenderData
preloadRender = do preloadRender = do
-- compile shader programs -- compile shader programs
lsShad <- makeShader "lightmapCircle" [vert,geom,frag] [(0,4)] Points (return . return . flat4) lsShad <- makeShader "lightmapCircle" [vert,geom,frag] [(0,4)] Points (return . return . flat4)
fcs <- makeSourcedShader "lightmapCircle" [VertexShader,GeometryShader,FragmentShader] -- fcs <- makeSourcedShader "lightmapCircle" [VertexShader,GeometryShader,FragmentShader]
bgs <- makeSourcedShader "background" [VertexShader,GeometryShader,FragmentShader] bgs <- makeSourcedShader "background" [VertexShader,GeometryShader,FragmentShader]
wss <- makeSourcedShader "wallShadow" [VertexShader,GeometryShader,FragmentShader] wss <- makeSourcedShader "wallShadow" [VertexShader,GeometryShader,FragmentShader]
wsShad <- makeShaderCustomUnis "wallShadow" [vert,geom,frag] [(0,4),(1,4)] Points pokeWPStrat
["lightPos"]
wssLightPosUniLoc <- GL.uniformLocation (fst wss) "lightPos" wssLightPosUniLoc <- GL.uniformLocation (fst wss) "lightPos"
bslist <- makeShader "basic" [vert,frag] [(0,3),(1,4)] Triangles pokeTriStrat bslist <- makeShader "basic" [vert,frag] [(0,3),(1,4)] Triangles pokeTriStrat
@@ -103,7 +112,7 @@ preloadRender = do
return $ RenderData return $ RenderData
{ _textures = [dirttex,dirttex] { _textures = [dirttex,dirttex]
, _listShaders = [bslist,lslist,cslist,aslist,eslist] , _listShaders = [bslist,lslist,cslist,aslist,eslist]
, _lightmapCircleShader = fcs -- , _lightmapCircleShader = fcs
, _backShader = bgs , _backShader = bgs
, _wallShadowShader = wss , _wallShadowShader = wss
, _backVAO = backgroundvao , _backVAO = backgroundvao
@@ -112,6 +121,8 @@ preloadRender = do
, _dummyVBO = dummyvbo , _dummyVBO = dummyvbo
, _dummyPtr = dummyptr , _dummyPtr = dummyptr
, _wssLightPos = wssLightPosUniLoc , _wssLightPos = wssLightPosUniLoc
, _lightSourceShader = lsShad
, _wlShadShader = wsShad
} }
vaoPointers :: VAO -> [Ptr Float] vaoPointers :: VAO -> [Ptr Float]
src/Picture/Render.hs
+35 -104
View File
@@ -37,6 +37,8 @@ import qualified Graphics.Rendering.OpenGL as GL
import Data.Foldable import Data.Foldable
import Data.List import Data.List
import Data.Maybe (fromJust)
--import qualified Data.Vector.Storable as V --import qualified Data.Vector.Storable as V
import qualified Data.IntMap as IM import qualified Data.IntMap as IM
--import qualified Data.DList as DL --import qualified Data.DList as DL
@@ -45,39 +47,6 @@ import qualified Data.IntMap as IM
import qualified SDL as SDL import qualified SDL as SDL
--picToAlt :: (Ap.Alternative f, Monoid (f RenderType)) => Int -> Picture -> f RenderType
--{-# INLINE picToAlt #-}
--picToAlt x (Polygon i ps)
-- | i == x = Ap.pure $ RenderPoly $ zip (map zeroZ $ polyToTris ps) $ repeat black
-- | otherwise = Ap.empty
--picToAlt x (PolygonCol i vs)
-- | i /= x = Ap.empty
-- | otherwise =
-- let (ps,cs) = unzip vs
-- in Ap.pure $ RenderPoly $ zip (map zeroZ $ polyToTris ps) $ polyToTris cs
--picToAlt x (Circle i r)
-- | i == x = Ap.pure $ RenderCirc $ ((0,0,0),black,r)
-- | otherwise = Ap.empty
--picToAlt x (Ellipse i (ax,ay) (bx,by) r)
-- | i == x = Ap.pure $ RenderEllipse [((ax,ay+r,0),black)
-- ,((ax,ay-r,0),black)
-- ,((bx,by-r,0),black)
-- ]
-- | otherwise = Ap.empty
--picToAlt x (ThickArc i startA endA rad wdth)
-- | i == x = Ap.pure $ RenderArc $ ((0,0,0),black,(startA,endA,rad,wdth))
-- | otherwise = Ap.empty
--picToAlt x (Line i ps)
-- | i == x = Ap.pure $ RenderLine $ zip (map zeroZ $ doubleLine ps) $ repeat white
-- | otherwise = Ap.empty
--picToAlt x (Text i s)
-- | i == x = Ap.pure $ RenderText $ stringToList s
-- | otherwise = Ap.empty
--picToAlt j Blank = Ap.empty
--picToAlt j (Pictures pics) = mconcat $ fmap (picToAlt j) pics
pokeTwoOff :: Ptr Float -> Int -> (Float,Float) -> IO () pokeTwoOff :: Ptr Float -> Int -> (Float,Float) -> IO ()
{-# INLINE pokeTwoOff #-} {-# INLINE pokeTwoOff #-}
pokeTwoOff ptr n (x,y) = do pokeTwoOff ptr n (x,y) = do
@@ -97,36 +66,6 @@ pokeFourOff ptr n (x,y,z,w) = do
pokeElemOff ptr (4*n+2) z pokeElemOff ptr (4*n+2) z
pokeElemOff ptr (4*n+3) w pokeElemOff ptr (4*n+3) w
setShaderUniforms :: Float -> Float -> Point2 -> Point2 -> [FullShader RenderType] -> IO ()
setShaderUniforms rot zoom (tranx,trany) (winx,winy) fss = do
let scalMat = Linear.Matrix.transpose $
V4 (V4 (2*zoom/winx) 0 0 (0::GLfloat))
(V4 0 (2*zoom/winy) 0 0)
(V4 0 0 1 0)
(V4 0 0 0 1)
let rotMat = Linear.Matrix.transpose $
V4 (V4 (cos rot) (sin (-rot)) 0 0)
(V4 (sin rot) (cos rot) 0 0)
(V4 0 0 1 0)
(V4 0 0 0 1)
let tranMat = Linear.Matrix.transpose $
V4 (V4 1 0 0 0)
(V4 0 1 0 0)
(V4 0 0 1 0)
(V4 (-tranx) (-trany) 0 1)
let wmat = scalMat !*! rotMat !*! tranMat
vToL (V4 a b c d) = [a,b,c,d]
wmata <- (newMatrix RowMajor $ concatMap vToL $ vToL wmat) :: IO (GLmatrix GLfloat)
-- set common uniforms
forM_ fss $ \shad -> do
currentProgram $= Just (_shaderProgram shad)
uniform (_shaderUniforms shad !! 0) $= Vector2 winx winy
uniform (_shaderUniforms shad !! 1) $= zoom
uniform (_shaderUniforms shad !! 2) $= rot
uniform (_shaderUniforms shad !! 3) $= Vector2 tranx trany
uniform (_shaderUniforms shad !! 4) $= wmata
renderPicture' :: RenderData -> Float -> Float -> (Float,Float) -> (Float,Float) -> renderPicture' :: RenderData -> Float -> Float -> (Float,Float) -> (Float,Float) ->
[(Point2,Point2,Point2,Point2)] -> [Point4] -> Picture -> IO (Word32,Word32) [(Point2,Point2,Point2,Point2)] -> [Point4] -> Picture -> IO (Word32,Word32)
renderPicture' pdata rot zoom (tranx,trany) (winx,winy) wallPoints lightPoints pic = do renderPicture' pdata rot zoom (tranx,trany) (winx,winy) wallPoints lightPoints pic = do
@@ -158,10 +97,14 @@ renderPicture' pdata rot zoom (tranx,trany) (winx,winy) wallPoints lightPoints p
wmata <- (newMatrix RowMajor $ concatMap vToL $ vToL wmat) :: IO (GLmatrix GLfloat) wmata <- (newMatrix RowMajor $ concatMap vToL $ vToL wmat) :: IO (GLmatrix GLfloat)
-- set common uniforms -- set common uniforms
setShaderUniforms rot zoom (tranx,trany) (winx,winy) (_listShaders pdata) setShaderUniforms rot zoom (tranx,trany) (winx,winy)
( (extractProgAndUnis $ _lightSourceShader pdata)
: (extractProgAndUnis $ _wlShadShader pdata)
: (map extractProgAndUnis $ _listShaders pdata)
)
forM_ [_lightmapCircleShader pdata forM_ [--lightmapCircleShader pdata
,_backShader pdata _backShader pdata
,_wallShadowShader pdata ,_wallShadowShader pdata
] $ \shad -> do ] $ \shad -> do
currentProgram $= Just (fst shad) currentProgram $= Just (fst shad)
@@ -172,32 +115,31 @@ renderPicture' pdata rot zoom (tranx,trany) (winx,winy) wallPoints lightPoints p
uniform (snd shad !! 4) $= wmata uniform (snd shad !! 4) $= wmata
-- draw lightmap -- draw lightmap
bindVertexArrayObject $= Just (_vao $ _wallVAO pdata)
let wallPtr = (\(_,x,_) -> x) $ head $ _vaoBufferTargets $ _wallVAO pdata nWalls <- F.foldM (pokeShader (_wlShadShader pdata)) wallPoints
wallPtr2 = (\(_,x,_) -> x) $ (_vaoBufferTargets $ _wallVAO pdata) !! 1 bindShaderBuffers [_wlShadShader pdata] [nWalls]
foldWalls n ((x,y),(z,w),(a,b),(c,d)) = do
pokeFourOff wallPtr n (x,y,z,w)
pokeFourOff wallPtr2 n (a,b,c,d)
return $ n+1
nWalls <- foldM foldWalls 0 wallPoints
bindArrayBuffers (length wallPoints) $ _vaoBufferTargets $ _wallVAO pdata
forM_ lightPoints $ \(x,y,r,lum) -> do forM_ lightPoints $ \(x,y,r,lum) -> do
cullFace $= Just Front cullFace $= Just Front
clear [DepthBuffer] clear [DepthBuffer]
currentProgram $= Just (fst $ _wallShadowShader pdata)
bindVertexArrayObject $= Just (_vao $ _wallVAO pdata) -- currentProgram does get called twice: here and inside drawShader below
uniform (_wssLightPos pdata) $= Vector2 (x) (y) currentProgram $= Just (_shaderProgram $ _wlShadShader pdata)
uniform (head $ fromJust $ _shaderCustomUnis $ _wlShadShader pdata)
$= Vector2 (x) (y)
blendFunc $= (Zero,One) blendFunc $= (Zero,One)
drawArrays Points (fromIntegral 0) (fromIntegral $ nWalls) drawShader (_wlShadShader pdata) nWalls
cullFace $= Nothing cullFace $= Nothing
currentProgram $= Just (fst $ _lightmapCircleShader pdata)
bindVertexArrayObject $= Just (_vao $ _fadeCircVAO pdata) let lightPtr = (\(_,ptr,_) -> ptr) $ head
let fadeCircPtr = (\(_,ptr,_) -> ptr) $ head $ _vaoBufferTargets $ _fadeCircVAO pdata $ _vaoBufferTargets $ _shaderVAO $ _lightSourceShader pdata
pokeFourOff fadeCircPtr 0 (x,y,r,lum) pokeFourOff lightPtr 0 (x,y,r,lum)
bindArrayBuffers (1) $ _vaoBufferTargets $ _fadeCircVAO pdata bindShaderBuffers [_lightSourceShader pdata] [1]
blendFuncSeparate $= ((Zero,Zero),(Zero, OneMinusSrcAlpha)) blendFuncSeparate $= ((Zero,Zero),(Zero, OneMinusSrcAlpha))
drawArrays Points (fromIntegral 0) (fromIntegral 1) drawShader (_lightSourceShader pdata) 1
startWallTicks <- SDL.ticks startWallTicks <- SDL.ticks
wallPokeEnd <- SDL.ticks wallPokeEnd <- SDL.ticks
ticksS <- SDL.ticks ticksS <- SDL.ticks
@@ -222,30 +164,19 @@ renderPicture' pdata rot zoom (tranx,trany) (winx,winy) wallPoints lightPoints p
depthFunc $= Just Lequal depthFunc $= Just Lequal
-- draw layer 0 -- draw layer 0
ticks2 <- renderTree' pdata rot zoom (tranx,trany) (winx,winy) $ picToLTree (Just 0) pic ticks2 <- renderFoldable pdata rot zoom (tranx,trany) (winx,winy) $ picToLTree (Just 0) pic
--((picToAlt 0 pic) :: [RenderType]) --((picToAlt 0 pic) :: [RenderType])
-- reset blend so that light map doesn't apply -- reset blend so that light map doesn't apply
blendFunc $= (SrcAlpha,OneMinusSrcAlpha) blendFunc $= (SrcAlpha,OneMinusSrcAlpha)
ticks3 <- renderTree' pdata rot zoom (tranx,trany) (winx,winy) $ picToLTree (Just 1) pic ticks3 <- renderFoldable pdata rot zoom (tranx,trany) (winx,winy) $ picToLTree (Just 1) pic
-- set drawing for on top -- set drawing for on top
aticks <- SDL.ticks aticks <- SDL.ticks
blendFuncSeparate $= ((SrcAlphaSaturate, OneMinusSrcAlpha), (Zero,One)) blendFuncSeparate $= ((SrcAlphaSaturate, OneMinusSrcAlpha), (Zero,One))
ticks4 <- renderTree' pdata rot zoom (tranx,trany) (winx,winy) $ picToLTree (Just 2) pic ticks4 <- renderFoldable pdata rot zoom (tranx,trany) (winx,winy) $ picToLTree (Just 2) pic
bticks <- SDL.ticks bticks <- SDL.ticks
-- reset uniforms (hacky for now)
idmat <- (newMatrix RowMajor [1,0,0,0 resetShaderUniforms (map extractProgAndUnis $ _listShaders pdata)
,0,1,0,0
,0,0,1,0
,0,0,0,1
]
) :: IO (GLmatrix GLfloat)
forM_ (_listShaders pdata) $ \shad -> do
currentProgram $= Just (_shaderProgram shad)
uniform (_shaderUniforms shad !! 0) $= Vector2 (2::Float) 2
uniform (_shaderUniforms shad !! 1) $= (1::Float)
uniform (_shaderUniforms shad !! 2) $= (0::Float)
uniform (_shaderUniforms shad !! 3) $= Vector2 (0::Float) 0
uniform (_shaderUniforms shad !! 4) $= idmat
endWallTicks <- SDL.ticks endWallTicks <- SDL.ticks
--return (ticksAfterL, ticks2+ticks3+ticks4, endWallTicks - startWallTicks) --return (ticksAfterL, ticks2+ticks3+ticks4, endWallTicks - startWallTicks)
ticksE <- SDL.ticks ticksE <- SDL.ticks
@@ -256,9 +187,9 @@ renderPicture' pdata rot zoom (tranx,trany) (winx,winy) wallPoints lightPoints p
bufferOffset :: Integral a => a -> Ptr b bufferOffset :: Integral a => a -> Ptr b
bufferOffset = plusPtr nullPtr . fromIntegral bufferOffset = plusPtr nullPtr . fromIntegral
renderTree' :: Foldable f => RenderData -> Float -> Float -> (Float,Float) -> (Float,Float) renderFoldable :: Foldable f => RenderData -> Float -> Float -> (Float,Float) -> (Float,Float)
-> f RenderType -> IO Word32 -> f RenderType -> IO Word32
renderTree' pdata rot zoom (tranx,trany) (winx,winy) tree = do renderFoldable pdata rot zoom (tranx,trany) (winx,winy) tree = do
pokeStartTicks <- SDL.ticks pokeStartTicks <- SDL.ticks
let slist = _listShaders pdata let slist = _listShaders pdata
src/Picture/Tree.hs
+32
View File
@@ -138,3 +138,35 @@ rotate3 :: Float -> Point3 -> Point3
rotate3 a (x,y,z) = (x',y',z) rotate3 a (x,y,z) = (x',y',z)
where (x',y') = rotateV a (x,y) where (x',y') = rotateV a (x,y)
--picToAlt :: (Ap.Alternative f, Monoid (f RenderType)) => Int -> Picture -> f RenderType
--{-# INLINE picToAlt #-}
--picToAlt x (Polygon i ps)
-- | i == x = Ap.pure $ RenderPoly $ zip (map zeroZ $ polyToTris ps) $ repeat black
-- | otherwise = Ap.empty
--picToAlt x (PolygonCol i vs)
-- | i /= x = Ap.empty
-- | otherwise =
-- let (ps,cs) = unzip vs
-- in Ap.pure $ RenderPoly $ zip (map zeroZ $ polyToTris ps) $ polyToTris cs
--picToAlt x (Circle i r)
-- | i == x = Ap.pure $ RenderCirc $ ((0,0,0),black,r)
-- | otherwise = Ap.empty
--picToAlt x (Ellipse i (ax,ay) (bx,by) r)
-- | i == x = Ap.pure $ RenderEllipse [((ax,ay+r,0),black)
-- ,((ax,ay-r,0),black)
-- ,((bx,by-r,0),black)
-- ]
-- | otherwise = Ap.empty
--picToAlt x (ThickArc i startA endA rad wdth)
-- | i == x = Ap.pure $ RenderArc $ ((0,0,0),black,(startA,endA,rad,wdth))
-- | otherwise = Ap.empty
--picToAlt x (Line i ps)
-- | i == x = Ap.pure $ RenderLine $ zip (map zeroZ $ doubleLine ps) $ repeat white
-- | otherwise = Ap.empty
--picToAlt x (Text i s)
-- | i == x = Ap.pure $ RenderText $ stringToList s
-- | otherwise = Ap.empty
--picToAlt j Blank = Ap.empty
--picToAlt j (Pictures pics) = mconcat $ fmap (picToAlt j) pics