From ee553c6e4921011893325c0a926450f2c80861e6 Mon Sep 17 00:00:00 2001 From: jgk Date: Wed, 28 Jul 2021 20:14:54 +0200 Subject: [PATCH] Add picture shader container datatype --- src/Data/Preload/Render.hs | 2 +- src/Dodge/Render.hs | 36 +++++++++---------- src/Picture.hs | 10 +++--- src/Preload/Render.hs | 13 +++++-- src/Render.hs | 46 ++++++++++++++---------- src/Shader.hs | 32 +++++++++++------ src/Shader/Compile.hs | 2 ++ src/Shader/Data.hs | 74 ++++++++++++++++++++++++++++++++++++++ src/Shader/Poke.hs | 64 ++++++++++++++++++++++----------- 9 files changed, 201 insertions(+), 78 deletions(-) diff --git a/src/Data/Preload/Render.hs b/src/Data/Preload/Render.hs index fb3047191..40229c50f 100644 --- a/src/Data/Preload/Render.hs +++ b/src/Data/Preload/Render.hs @@ -21,7 +21,7 @@ data RenderData = RenderData , _colorBlurShader :: FullShader , _barrelShader :: FullShader , _grayscaleShader :: FullShader - , _pictureShaders :: [VShader] + , _pictureShaders :: PicShads VShader , _fbo2 :: (FramebufferObject, TextureObject) , _fbo3 :: (FramebufferObject, TextureObject) , _fboFourth1 :: (FramebufferObject, TextureObject) diff --git a/src/Dodge/Render.hs b/src/Dodge/Render.hs index e1920f7f0..29dde0e26 100644 --- a/src/Dodge/Render.hs +++ b/src/Dodge/Render.hs @@ -77,32 +77,30 @@ doDrawing pdata w = do if w ^. config . wall_textured then renderTextureWalls pdata nWalls else renderBlankWalls pdata nWalls - --_ <- renderFoldable pdata $ (picToAlt (Just 0) (polysToPic $ foregroundPics w) :: [RenderType]) - --_ <- renderFoldable pdata $ (picToAlt (Just 0) pic :: [RenderType]) ---FIXME _ <- renderFoldable pdata $ polysToPic $ foregroundPics w - vfore <- pokeBindFoldableLayer pdata $ polysToPic $ foregroundPics w - mapM_ (uncurry $ drawShaderLay 0) (vfore IM.! 0) - --_ <- renderFoldable pdata $ map snd $ filter ((==0).fst) pic + _ <- renderFoldable pdata $ polysToPic $ foregroundPics w + vnums <- pokeBindFoldableLayer pdata $ pic - mapM_ (uncurry $ drawShaderLay 0) (vnums IM.! 0) + let shads = _pictureShaders pdata + --mapM_ (uncurry $ drawShaderLay 0) ((,) <$> shads <*> count) + renderLayer 0 shads vnums _ <- renderShader (_textureArrayShader pdata) (_floorTiles w) bindFramebuffer Framebuffer $= fst (_fboBloom pdata) clear [ColorBuffer] blendFunc $= (SrcAlpha,OneMinusSrcAlpha) - --_ <- renderFoldable pdata $ map snd $ filter ((==1).fst) pic - mapM_ (uncurry $ drawShaderLay 1) (vnums IM.! 1) + --mapM_ (uncurry $ drawShaderLay 1) (vnums IM.! 1) + renderLayer 1 shads vnums bindFramebuffer Framebuffer $= fst (_fboColor pdata) clear [ColorBuffer] depthMask $= Disabled - mapM_ (uncurry $ drawShaderLay 3) (vnums IM.! 3) - mapM_ (uncurry $ drawShaderLay 4) (vnums IM.! 4) - mapM_ (uncurry $ drawShaderLay 5) (vnums IM.! 5) - --_ <- renderFoldable pdata $ map snd $ filter ((==3).fst) pic - --_ <- renderFoldable pdata $ map snd $ filter ((==4).fst) pic - --_ <- renderFoldable pdata $ map snd $ filter ((==5).fst) pic + --mapM_ (uncurry $ drawShaderLay 3) (vnums IM.! 3) + --mapM_ (uncurry $ drawShaderLay 4) (vnums IM.! 4) + --mapM_ (uncurry $ drawShaderLay 5) (vnums IM.! 5) + renderLayer 3 shads vnums + renderLayer 4 shads vnums + renderLayer 5 shads vnums depthMask $= Enabled bindFramebuffer Framebuffer $= fst (_fboFourth1 pdata) @@ -145,8 +143,8 @@ doDrawing pdata w = do drawShader (_fullscreenShader pdata) 4 depthFunc $= Just Lequal - --_ <- renderFoldable pdata $ map snd $ filter ((==2).fst) pic - mapM_ (uncurry $ drawShaderLay 2) (vnums IM.! 2) + --mapM_ (uncurry $ drawShaderLay 2) (vnums IM.! 2) + renderLayer 2 shads vnums renderWindows pdata windowPoints depthFunc $= Just Always @@ -178,9 +176,7 @@ doDrawing pdata w = do blend $= Enabled blendFunc $= (SrcAlpha,OneMinusSrcAlpha) - vovers <- pokeBindFoldableLayer pdata $ fixedCoordPictures w - mapM_ (uncurry $ drawShaderLay 0) (vovers IM.! 0) ---FIXME _ <- renderFoldable pdata $ fixedCoordPictures w + _ <- renderFoldable pdata $ fixedCoordPictures w depthMask $= Enabled eTicks <- SDL.ticks diff --git a/src/Picture.hs b/src/Picture.hs index 242c0dc7f..e9bef1c2e 100644 --- a/src/Picture.hs +++ b/src/Picture.hs @@ -55,8 +55,8 @@ import Geometry.Vector3D import Geometry.Data import Picture.Data -import Data.List -import Data.Bifunctor +--import Data.List +--import Data.Bifunctor --import qualified Data.DList as DL --import Graphics.Rendering.OpenGL (lineWidth, ($=)) import Control.Lens @@ -64,8 +64,8 @@ import Control.Lens black :: RGBA black = (0,0,0,1) -zl :: RenderType -> [(Int,RenderType)] -zl rt = [(0,rt)] +--zl :: RenderType -> [(Int,RenderType)] +--zl rt = [(0,rt)] polygon :: [Point2] -> Picture {-# INLINE polygon #-} @@ -175,7 +175,7 @@ addDepth d = map $ overPos (\(x,y,z) -> (x,y,z+d)) setLayer :: Int -> Picture -> Picture {-# INLINE setLayer #-} -setLayer i = map $ f +setLayer i = map f where f v = v {_vxLayer = i} diff --git a/src/Preload/Render.hs b/src/Preload/Render.hs index 405764225..5490d373c 100644 --- a/src/Preload/Render.hs +++ b/src/Preload/Render.hs @@ -38,7 +38,7 @@ preloadRender = do , nullPtr , DynamicDraw ) - let wpVBO = VBO {_vbo = wpVBOname, _vboPointer = wpVBOptr, _vboAttribSizes = [4,4]} + let wpVBO = VBO {_vbo = wpVBOname, _vboPointer = wpVBOptr, _vboAttribSizes = [4,4], _vboStride = 8} wpVAOname <- genObjectName bindVertexArrayObject $= Just wpVAOname bindBuffer ArrayBuffer $= Just wpVBOname @@ -119,8 +119,14 @@ preloadRender = do clearColor $= Color4 0 0 0 1 return $ RenderData - { _pictureShaders = - [bslist,cslist,aslist,eslist,bezierQuadShader,basicTweakZShad] + { _pictureShaders = PicShads + { _psPoly = bslist + , _psText = cslist + , _psArc = aslist + , _psEll = eslist + , _psBez = bezierQuadShader + , _psPolyz = basicTweakZShad + } , _lightingSurfaceShader = lightingSurfaceShad , _lightingLineShadowShader = lightingLineShadowShad , _lightingOccludeShader = wsShad {_shaderVAO = wpVAO} @@ -238,6 +244,7 @@ poke33 :: RenderType -> [[Float]] poke33 Render3x3{_unRender3x3=((x,y,z),(a,b,c))} = [[x,y,z,a,b,c]] poke33 _ = undefined +isPolyV, isArcV, isEllV, isTextV, isBezV, isPolyzV :: VertexType -> Bool isPolyV PolyV = True isPolyV _ = False isArcV (ArcV _) = True diff --git a/src/Render.hs b/src/Render.hs index 9d596bc71..55998b987 100644 --- a/src/Render.hs +++ b/src/Render.hs @@ -153,20 +153,33 @@ renderShader shad dat = do eticks <- SDL.ticks return $ eticks - sticks +pokeBindFoldable + :: Foldable f + => RenderData + -> f Verx + -> IO (PicShads Int) +pokeBindFoldable pdata m = do + let shads = _pictureShaders pdata + counts = zeroCounts + elist <- foldM (pokeVX' shads) counts m + bindShader shads elist + return elist + +zeroCounts :: PicShads Int +zeroCounts = PicShads 0 0 0 0 0 0 + pokeBindFoldableLayer :: Foldable f => RenderData -> f Verx - -> IO (IM.IntMap [(VShader,Int)]) + -> IO (IM.IntMap (PicShads Int)) pokeBindFoldableLayer pdata m = do - let slist = (,) <$> [0..6] <*> _pictureShaders pdata - slist' = IM.fromListWith (++) ((,) <$> [0..6] <*> map ((:[]) . (, 0)) (_pictureShaders pdata)) + let shads = _pictureShaders pdata + slist' = (IM.fromList ((,) <$> [0..6] <*> [zeroCounts])) :: IM.IntMap (PicShads Int) + + slist'' <- foldM (pokeVX shads) slist' m + bindShaderLay shads slist'' --- is <- F.foldM (traverse pokeShaderLayer slist) m --- bindShaderLayer slist is - slist'' <- foldM pokeVX slist' m - bindShaderLay slist'' - --return $ IM.fromListWith (++) $ zipWith (\(i,fs) n -> (i,[(fs,n)])) slist is return slist'' renderFoldable @@ -177,22 +190,19 @@ renderFoldable renderFoldable pdata struct = do pokeStartTicks <- SDL.ticks - let slist = (,) <$> [0..6] <*> _pictureShaders pdata + count <- pokeBindFoldable pdata struct + let shads = _pictureShaders pdata --- poke data, returns list buffer sizes for each shader - is <- F.foldM (traverse pokeShaderLayer 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 - bindShaderLayer slist is - - zipWithM_ (uncurry drawShaderLay) slist is + mapM_ (uncurry (drawShaderLay 0)) ((,) <$> shads <*> count) pokeEndTicks <- SDL.ticks return $ pokeEndTicks - pokeStartTicks ------------------------------end renderFoldable +renderLayer :: Int -> PicShads VShader -> IM.IntMap (PicShads Int) -> IO () +renderLayer i shads counts = + mapM_ (uncurry $ drawShaderLay i) ((,) <$> shads <*> counts IM.! i) + pokeTwoOff :: Ptr Float -> Int diff --git a/src/Shader.hs b/src/Shader.hs index e540bcffb..c96fd7f55 100644 --- a/src/Shader.hs +++ b/src/Shader.hs @@ -2,6 +2,7 @@ module Shader ( bindShaderLayer , bindShaderLay , bindShaderBuffers + , bindShader , bindArrayBuffers , drawShader , freeShaderPointers @@ -18,6 +19,7 @@ import Control.Monad import Graphics.Rendering.OpenGL hiding (Point,translate,scale,imageHeight) import Graphics.GL.Core43 import qualified Data.IntMap.Strict as IM +import Data.Bifunctor --import Text.RawString.QQ --import Linear.Matrix --import Linear.V4 @@ -32,6 +34,18 @@ bindArrayBuffers numVs theVBO = do (fromIntegral $ floatSize * numVs * sum (_vboAttribSizes theVBO)) (_vboPointer theVBO) +bindArrayBuffersLayer' :: Int -> Int -> VBO -> IO () +bindArrayBuffersLayer' lay numVs theVBO = do + bindBuffer ArrayBuffer $= Just (_vbo theVBO) + bufferSubData + ArrayBuffer + WriteToBuffer + (fromIntegral $ floatSize * stride * numSubElements * lay) + (fromIntegral $ floatSize * numVs * stride) + (_vboPointer theVBO `plusPtr` (floatSize * stride * numSubElements * lay)) + where + stride = sum $ _vboAttribSizes theVBO + bindArrayBuffersLayer :: Int -> Int -> VBO -> IO () bindArrayBuffersLayer numVs lay theVBO = do bindBuffer ArrayBuffer $= Just (_vbo theVBO) @@ -44,11 +58,14 @@ bindArrayBuffersLayer numVs lay theVBO = do where stride = sum $ _vboAttribSizes theVBO -bindShaderLay :: IM.IntMap [(VShader,Int)] -> IO () -bindShaderLay = mapM_ f . IM.toList +bindShaderLay :: PicShads VShader -> IM.IntMap (PicShads Int) -> IO () +bindShaderLay shads = mapM_ f . IM.toList where - f (lay,ps) = mapM_ (g lay) ps - g l (fs,i) = bindArrayBuffersLayer i l $ _vaoVBO $ _vshaderVAO fs + f (lay,counts) = sequence_ $ bindArrayBuffersLayer' lay <$> counts <*> (_vaoVBO . _vshaderVAO <$> shads) + +bindShader :: PicShads VShader -> PicShads Int -> IO () +bindShader shads counts = sequence_ $ bindArrayBuffers <$> counts <*> (_vaoVBO . _vshaderVAO <$> shads) +--bindShader = mapM_ (uncurry (flip bindArrayBuffers) . first (_vaoVBO . _vshaderVAO)) bindShaderLayer :: [(Int,VShader)] -> [Int] -> IO () bindShaderLayer = zipWithM_ f @@ -60,13 +77,6 @@ bindShaderBuffers = zipWithM_ f where f fs i = bindArrayBuffers i $ _vaoVBO $ _shaderVAO fs -drawShaderLays :: IM.IntMap [(VShader,Int)] -> IO () -{-# INLINE drawShaderLays #-} -drawShaderLays = mapM_ f . IM.toList - where - f (lay,ps) = mapM_ (g lay) ps - g lay (shad,i) = drawShaderLay lay shad i - drawShaderLay :: Int -> VShader -> Int -> IO () {-# INLINE drawShaderLay #-} drawShaderLay l fs i = do diff --git a/src/Shader/Compile.hs b/src/Shader/Compile.hs index d36edb7bc..2301e0602 100644 --- a/src/Shader/Compile.hs +++ b/src/Shader/Compile.hs @@ -151,6 +151,7 @@ setupVBO sizes = do { _vbo = vboName , _vboPointer = thePtr , _vboAttribSizes = sizes + , _vboStride = sum sizes } where strd = sum sizes @@ -173,6 +174,7 @@ setupVBOSized sizes ndraw = do { _vbo = vboName , _vboPointer = thePtr , _vboAttribSizes = sizes + , _vboStride = sum sizes } where strd = sum sizes diff --git a/src/Shader/Data.hs b/src/Shader/Data.hs index 93a50ac95..b6f93732d 100644 --- a/src/Shader/Data.hs +++ b/src/Shader/Data.hs @@ -9,6 +9,7 @@ module Shader.Data , VShader (..) , ShaderTexture (..) , EPrimitiveMode (..) + , PicShads (..) -- | Lens functions , vao , vaoVBO @@ -27,6 +28,14 @@ module Shader.Data , vshaderCustomUnis , vshaderPokeTest + , psPoly + , psPolyz + , psBez + , psText + , psArc + , psEll + +-- TODO make lenses for VBO object -- , textureObject ) where import Picture.Data @@ -49,6 +58,7 @@ data VBO = VBO { _vbo :: BufferObject , _vboPointer :: Ptr Float , _vboAttribSizes :: [Int] -- ^ It is not clear to me if this is necessary to store or not + , _vboStride :: Int } data VShader = VShader { _vshaderProgram :: Program @@ -58,6 +68,69 @@ data VShader = VShader , _vshaderCustomUnis :: [UniformLocation] , _vshaderPokeTest :: VertexType -> Bool } +data PicShads a = PicShads + { _psPoly :: a + , _psPolyz :: a + , _psBez :: a + , _psText :: a + , _psArc :: a + , _psEll :: a + } +-- boilerplate folows +instance Functor PicShads where + fmap f PicShads + { _psPoly = thePoly + , _psPolyz = thePolyz + , _psBez = theBez + , _psText = theText + , _psArc = theArc + , _psEll = theEll + } + = PicShads + { _psPoly = f thePoly + , _psPolyz = f thePolyz + , _psBez = f theBez + , _psText = f theText + , _psArc = f theArc + , _psEll = f theEll + } +instance Applicative PicShads where + pure a = PicShads a a a a a a + (<*>) PicShads + { _psPoly = fPoly + , _psPolyz = fPolyz + , _psBez = fBez + , _psText = fText + , _psArc = fArc + , _psEll = fEll + } + PicShads + { _psPoly = thePoly + , _psPolyz = thePolyz + , _psBez = theBez + , _psText = theText + , _psArc = theArc + , _psEll = theEll + } + = PicShads + { _psPoly = fPoly thePoly + , _psPolyz = fPolyz thePolyz + , _psBez = fBez theBez + , _psText = fText theText + , _psArc = fArc theArc + , _psEll = fEll theEll + } +instance Foldable PicShads where + foldr f x PicShads + { _psPoly = thePoly + , _psPolyz = thePolyz + , _psBez = theBez + , _psText = theText + , _psArc = theArc + , _psEll = theEll + } + = f thePoly . f thePolyz . f theBez . f theText . f theArc $ f theEll x + {- | Datatype containing the necessary information for a single shader. -} data FullShader = FullShader @@ -89,3 +162,4 @@ data EPrimitiveMode makeLenses ''VAO makeLenses ''FullShader makeLenses ''VShader +makeLenses ''PicShads diff --git a/src/Shader/Poke.hs b/src/Shader/Poke.hs index d6451a5f0..2bc92092c 100644 --- a/src/Shader/Poke.hs +++ b/src/Shader/Poke.hs @@ -1,9 +1,10 @@ -{-# LANGUAGE TupleSections #-} +--{-# LANGUAGE TupleSections #-} module Shader.Poke ( pokeArrayOff , pokeShader , pokeShaderLayer , pokeVX + , pokeVX' ) where import Shader.Data import Shader.Parameters @@ -22,11 +23,9 @@ pokeShader fs = F.FoldM (pokeVertices fls ptr stride) (return 0) return where theVBO = _vaoVBO $ _shaderVAO fs ptr = _vboPointer theVBO - stride = sum $ _vboAttribSizes theVBO + stride = _vboStride theVBO fls = _shaderPokeStrategy fs - - pokeVertices :: (RenderType -> [[Float]]) -> Ptr Float @@ -36,23 +35,47 @@ pokeVertices -> IO Int pokeVertices toFs ptr stride n rt = foldM (pokeVertex ptr stride) n (toFs rt) -pokeSL :: [(Int,[VShader])] -> [Verx] -> IO (IM.IntMap [(VShader,Int)]) -pokeSL vslist vxs = do - foldM pokeVX (f vslist) vxs - where - f = IM.map (map (, 0)) . IM.fromList +getterPicShad :: VertexType -> Getting a (PicShads a) a +getterPicShad PolyV = psPoly +getterPicShad PolyzV{} = psPolyz +getterPicShad BezV{} = psBez +getterPicShad TextV{} = psText +getterPicShad ArcV{} = psArc +getterPicShad EllV = psEll -pokeVX :: IM.IntMap [(VShader,Int)] -> Verx -> IO (IM.IntMap [(VShader,Int)]) -pokeVX count vx = do - let offset = _vxLayer vx - lshads = count IM.! offset - (vshad,n) = fromJust $ find (\(s,_) -> _vshaderPokeTest s $ _vxType vx) lshads - i = fromJust $ findIndex (\(s,_) -> _vshaderPokeTest s $ _vxType vx) lshads +--setterPicShad :: VertexType -> ASetter +setterPicShad PolyV = psPoly +setterPicShad PolyzV{} = psPolyz +setterPicShad BezV{} = psBez +setterPicShad TextV{} = psText +setterPicShad ArcV{} = psArc +setterPicShad EllV = psEll + +pokeVX' :: PicShads VShader -> PicShads Int -> Verx -> IO (PicShads Int) +pokeVX' shads count vx = do + let f = setterPicShad (_vxType vx) + g = getterPicShad (_vxType vx) + vshad = shads ^. g + n = count ^. g theVBO = _vaoVBO $ _vshaderVAO vshad ptr = _vboPointer theVBO - stride = sum $ _vboAttribSizes theVBO + stride = _vboStride theVBO + pokeArrayOff ptr (stride * n) (toFls' vx) + return $ count & f +~ 1 + +pokeVX :: PicShads VShader -> IM.IntMap (PicShads Int) -> Verx -> IO (IM.IntMap (PicShads Int)) +pokeVX shads laycounts vx = do + let theType = _vxType vx + offset = _vxLayer vx + counts = laycounts IM.! offset + getF = getterPicShad theType + vshad = shads ^. getF + n = counts ^. getF + theVBO = _vaoVBO $ _vshaderVAO vshad + ptr = _vboPointer theVBO + stride = _vboStride theVBO pokeArrayOff ptr (stride * (n+offset * numSubElements)) (toFls' vx) - return $ count & ix offset . ix i . _2 +~ 1 + return $ laycounts & ix offset . setterPicShad theType +~ 1 pokeShaderLayer :: (Int,VShader) -> F.FoldM IO Verx Int @@ -60,7 +83,7 @@ pokeShaderLayer (l,fs) = F.FoldM (pokeVerticesOff ptr (_vshaderPokeTest fs) stri where theVBO = _vaoVBO $ _vshaderVAO fs ptr = _vboPointer theVBO - stride = sum $ _vboAttribSizes theVBO + stride = _vboStride theVBO pokeVerticesOff :: Ptr Float @@ -108,5 +131,6 @@ pokeVertex ptr stride n fs = do return $ n + 1 pokeArrayOff :: Storable a => Ptr a -> Int -> [a] -> IO () -{-# INLINE pokeArrayOff #-} -pokeArrayOff ptr i = zipWithM_ (pokeElemOff ptr) [i..] +--{-# INLINE pokeArrayOff #-} +--pokeArrayOff ptr i = zipWithM_ (pokeElemOff ptr) [i..] +pokeArrayOff ptr i = pokeArray (plusPtr ptr (floatSize * i))