From 6c378659b24411e535dd8598e726ba6247dc5b52 Mon Sep 17 00:00:00 2001 From: jgk Date: Thu, 11 Mar 2021 01:16:42 +0100 Subject: [PATCH] Refactor light source and wall shadow shaders --- app/Main.hs | 2 +- src/Picture/Preload.hs | 19 ++++-- src/Picture/Render.hs | 139 +++++++++++------------------------------ src/Picture/Tree.hs | 32 ++++++++++ 4 files changed, 83 insertions(+), 109 deletions(-) diff --git a/app/Main.hs b/app/Main.hs index 1fc1eded5..deaca14ae 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -60,7 +60,7 @@ main = do (lightsForGloom' w) (worldPictures w) 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) --(picToLTree (Just 1) $ fixedCoordPictures w) (picToLTree Nothing $ fixedCoordPictures w) diff --git a/src/Picture/Preload.hs b/src/Picture/Preload.hs index 4baec8e53..c81ff6cc3 100644 --- a/src/Picture/Preload.hs +++ b/src/Picture/Preload.hs @@ -15,14 +15,17 @@ import Control.Lens --import Control.Monad import Foreign - import Shader +import Geometry (Point2) + data RenderData = RenderData { _textures :: [TextureObject] , _backShader :: (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] , _backVAO :: VAO , _wallVAO :: VAO @@ -56,14 +59,20 @@ vert = VertexShader geom = GeometryShader 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 = do -- compile shader programs 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] 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" bslist <- makeShader "basic" [vert,frag] [(0,3),(1,4)] Triangles pokeTriStrat @@ -103,7 +112,7 @@ preloadRender = do return $ RenderData { _textures = [dirttex,dirttex] , _listShaders = [bslist,lslist,cslist,aslist,eslist] - , _lightmapCircleShader = fcs +-- , _lightmapCircleShader = fcs , _backShader = bgs , _wallShadowShader = wss , _backVAO = backgroundvao @@ -112,6 +121,8 @@ preloadRender = do , _dummyVBO = dummyvbo , _dummyPtr = dummyptr , _wssLightPos = wssLightPosUniLoc + , _lightSourceShader = lsShad + , _wlShadShader = wsShad } vaoPointers :: VAO -> [Ptr Float] diff --git a/src/Picture/Render.hs b/src/Picture/Render.hs index cc266905e..f613f178c 100644 --- a/src/Picture/Render.hs +++ b/src/Picture/Render.hs @@ -37,6 +37,8 @@ import qualified Graphics.Rendering.OpenGL as GL import Data.Foldable import Data.List +import Data.Maybe (fromJust) + --import qualified Data.Vector.Storable as V import qualified Data.IntMap as IM --import qualified Data.DList as DL @@ -45,39 +47,6 @@ import qualified Data.IntMap as IM 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 () {-# INLINE pokeTwoOff #-} 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+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) -> [(Point2,Point2,Point2,Point2)] -> [Point4] -> Picture -> IO (Word32,Word32) 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) -- 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 - ,_backShader pdata + forM_ [--lightmapCircleShader pdata + _backShader pdata ,_wallShadowShader pdata ] $ \shad -> do currentProgram $= Just (fst shad) @@ -172,32 +115,31 @@ renderPicture' pdata rot zoom (tranx,trany) (winx,winy) wallPoints lightPoints p uniform (snd shad !! 4) $= wmata -- draw lightmap - bindVertexArrayObject $= Just (_vao $ _wallVAO pdata) - let wallPtr = (\(_,x,_) -> x) $ head $ _vaoBufferTargets $ _wallVAO pdata - wallPtr2 = (\(_,x,_) -> x) $ (_vaoBufferTargets $ _wallVAO pdata) !! 1 - 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 + + nWalls <- F.foldM (pokeShader (_wlShadShader pdata)) wallPoints + bindShaderBuffers [_wlShadShader pdata] [nWalls] forM_ lightPoints $ \(x,y,r,lum) -> do cullFace $= Just Front clear [DepthBuffer] - currentProgram $= Just (fst $ _wallShadowShader pdata) - bindVertexArrayObject $= Just (_vao $ _wallVAO pdata) - uniform (_wssLightPos pdata) $= Vector2 (x) (y) + +-- currentProgram does get called twice: here and inside drawShader below + currentProgram $= Just (_shaderProgram $ _wlShadShader pdata) + uniform (head $ fromJust $ _shaderCustomUnis $ _wlShadShader pdata) + $= Vector2 (x) (y) blendFunc $= (Zero,One) - drawArrays Points (fromIntegral 0) (fromIntegral $ nWalls) + drawShader (_wlShadShader pdata) nWalls + cullFace $= Nothing - currentProgram $= Just (fst $ _lightmapCircleShader pdata) - bindVertexArrayObject $= Just (_vao $ _fadeCircVAO pdata) - let fadeCircPtr = (\(_,ptr,_) -> ptr) $ head $ _vaoBufferTargets $ _fadeCircVAO pdata - pokeFourOff fadeCircPtr 0 (x,y,r,lum) - bindArrayBuffers (1) $ _vaoBufferTargets $ _fadeCircVAO pdata + + let lightPtr = (\(_,ptr,_) -> ptr) $ head + $ _vaoBufferTargets $ _shaderVAO $ _lightSourceShader pdata + pokeFourOff lightPtr 0 (x,y,r,lum) + bindShaderBuffers [_lightSourceShader pdata] [1] + blendFuncSeparate $= ((Zero,Zero),(Zero, OneMinusSrcAlpha)) - drawArrays Points (fromIntegral 0) (fromIntegral 1) + drawShader (_lightSourceShader pdata) 1 + startWallTicks <- SDL.ticks wallPokeEnd <- SDL.ticks ticksS <- SDL.ticks @@ -222,30 +164,19 @@ renderPicture' pdata rot zoom (tranx,trany) (winx,winy) wallPoints lightPoints p depthFunc $= Just Lequal -- 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]) -- reset blend so that light map doesn't apply 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 aticks <- SDL.ticks 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 --- reset uniforms (hacky for now) - idmat <- (newMatrix RowMajor [1,0,0,0 - ,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 + + resetShaderUniforms (map extractProgAndUnis $ _listShaders pdata) + endWallTicks <- SDL.ticks --return (ticksAfterL, ticks2+ticks3+ticks4, endWallTicks - startWallTicks) 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 = 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 -renderTree' pdata rot zoom (tranx,trany) (winx,winy) tree = do +renderFoldable pdata rot zoom (tranx,trany) (winx,winy) tree = do pokeStartTicks <- SDL.ticks let slist = _listShaders pdata diff --git a/src/Picture/Tree.hs b/src/Picture/Tree.hs index 0234f970a..a3224ca2f 100644 --- a/src/Picture/Tree.hs +++ b/src/Picture/Tree.hs @@ -138,3 +138,35 @@ rotate3 :: Float -> Point3 -> Point3 rotate3 a (x,y,z) = (x',y',z) 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 + +