From 5dfebd221d7dbe0a6e171b0f9fd2a76fa3635722 Mon Sep 17 00:00:00 2001 From: jgk Date: Mon, 26 Jul 2021 00:53:35 +0200 Subject: [PATCH] Broken binding of central picture in one pass --- package.yaml | 4 +++ src/Dodge/Render.hs | 25 ++++++++++++------ src/Picture.hs | 4 +-- src/Preload/Render.hs | 11 +++++--- src/Render.hs | 14 +++++++++- src/Shader.hs | 34 ++++++++++++++++++++++++- src/Shader/Compile.hs | 55 ++++++++++++++++++++++++++++++++++++++++ src/Shader/Parameters.hs | 6 ++++- src/Shader/Poke.hs | 29 +++++++++++++++++++++ 9 files changed, 165 insertions(+), 17 deletions(-) diff --git a/package.yaml b/package.yaml index 0bfbb2f1c..5994a021b 100644 --- a/package.yaml +++ b/package.yaml @@ -51,6 +51,8 @@ dependencies: library: source-dirs: src + # ghc-options: -fwrite-ide-info + # -hiedir=.hie executables: # loop-exe: @@ -69,6 +71,8 @@ executables: - -funfolding-keeness-factor1000 - -fllvm - -optlo-O3 +# - -fwrite-ide-info +# - -hiedir=.hie dependencies: - loop diff --git a/src/Dodge/Render.hs b/src/Dodge/Render.hs index d94ed48f2..e06c489a4 100644 --- a/src/Dodge/Render.hs +++ b/src/Dodge/Render.hs @@ -34,7 +34,7 @@ import qualified Control.Foldl as F --import Data.List --import Data.Bifunctor --import Data.Function ---import qualified Data.IntMap.Strict as IM +import qualified Data.IntMap.Strict as IM --import qualified Data.Map as M --import qualified Data.Set as S import Graphics.Rendering.OpenGL hiding (color,scale,translate,rotate) @@ -60,7 +60,7 @@ doDrawing pdata w = do -- poke foreground geometry and floor let addC (xx,yy) = (xx,yy,0) nsurfVs <- F.foldM (pokeShader (_lightingSurfaceShader pdata)) - $ (Render3 $ polyToTris $ map addC $ screenPolygon w) + $ Render3 (polyToTris $ map addC $ screenPolygon w) : concatMap polyToGeoRender (foregroundPics w) -- bind wall points, silhouette data, surface geometry uncurry bindShaderBuffers $ unzip @@ -80,19 +80,27 @@ doDrawing pdata w = do --_ <- renderFoldable pdata $ (picToAlt (Just 0) (polysToPic $ foregroundPics w) :: [RenderType]) --_ <- renderFoldable pdata $ (picToAlt (Just 0) pic :: [RenderType]) _ <- renderFoldable pdata $ map snd (polysToPic $ foregroundPics w) - _ <- renderFoldable pdata $ map snd $ filter ((==0).fst) pic + + --_ <- renderFoldable pdata $ map snd $ filter ((==0).fst) pic + vnums <- pokeBindFoldableLayer pdata $ pic + mapM_ (uncurry $ drawShaderLay 0) (vnums IM.! 0) + _ <- renderShader (_textureArrayShader pdata) (_floorTiles w) bindFramebuffer Framebuffer $= fst (_fboBloom pdata) clear [ColorBuffer] blendFunc $= (SrcAlpha,OneMinusSrcAlpha) - _ <- renderFoldable pdata $ map snd $ filter ((==1).fst) pic + --_ <- renderFoldable pdata $ map snd $ filter ((==1).fst) pic + mapM_ (uncurry $ drawShaderLay 1) (vnums IM.! 1) bindFramebuffer Framebuffer $= fst (_fboColor pdata) clear [ColorBuffer] depthMask $= Disabled - _ <- 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) + --_ <- renderFoldable pdata $ map snd $ filter ((==3).fst) pic + --_ <- renderFoldable pdata $ map snd $ filter ((==4).fst) pic + --_ <- renderFoldable pdata $ map snd $ filter ((==5).fst) pic depthMask $= Enabled bindFramebuffer Framebuffer $= fst (_fboFourth1 pdata) @@ -135,7 +143,8 @@ doDrawing pdata w = do drawShader (_fullscreenShader pdata) 4 depthFunc $= Just Lequal - _ <- renderFoldable pdata $ map snd $ filter ((==2).fst) pic + --_ <- renderFoldable pdata $ map snd $ filter ((==2).fst) pic + mapM_ (uncurry $ drawShaderLay 2) (vnums IM.! 2) renderWindows pdata windowPoints depthFunc $= Just Always diff --git a/src/Picture.hs b/src/Picture.hs index 91ee59335..39fef412c 100644 --- a/src/Picture.hs +++ b/src/Picture.hs @@ -176,11 +176,11 @@ scale3 a b (x,y,z) = (x*a,y*b,z) scale :: Float -> Float -> Picture -> Picture {-# INLINE scale #-} -scale x y = map $ second $ overPos $ (scale3 x y) +scale x y = map . second . overPos $ scale3 x y rotate :: Float -> Picture -> Picture {-# INLINE rotate #-} -rotate a = map $ second $ overPos $ (rotate3 a) +rotate a = map . second . overPos $ rotate3 a pictures :: [Picture] -> Picture {-# INLINE pictures #-} diff --git a/src/Preload/Render.hs b/src/Preload/Render.hs index 72a4e467e..a821ad568 100644 --- a/src/Preload/Render.hs +++ b/src/Preload/Render.hs @@ -19,6 +19,9 @@ import Graphics.GL.Core43 --import Control.Monad import Foreign +numDrawableWalls :: Int +numDrawableWalls = 5000 + preloadRender :: IO RenderData preloadRender = do -- set up uniform buffer object @@ -28,10 +31,10 @@ preloadRender = do bindBufferBase IndexedUniformBuffer 0 $= Just theUBO -- setup wall points VBO, VAOs and shaders wpVBOname <- genObjectName - wpVBOptr <- mallocArray (8 * numDrawableElements) + wpVBOptr <- mallocArray (8 * numDrawableWalls) bindBuffer ArrayBuffer $= Just wpVBOname bufferData ArrayBuffer $= - (fromIntegral $ floatSize * numDrawableElements * 8 + (fromIntegral $ floatSize * numDrawableWalls * 8 , nullPtr , DynamicDraw ) @@ -69,11 +72,11 @@ preloadRender = do -- this should really be a 2d texture array basicTweakZShad <- makeShader "twoD/basicTweakZ" [vert,frag] [4,4] ETriangles pokeTriTweakZ -- fullscreen shaders - fullscreenAlphaHalveShad <- makeShader "fullscreen/alphaHalve" [vert,frag] [2] ETriangleStrip $ + fullscreenAlphaHalveShad <- makeShaderSized "fullscreen/alphaHalve" [vert,frag] [2] 4 ETriangleStrip $ const cornerListNoCoord pokeArray (_vboPointer $ _vaoVBO $ _shaderVAO fullscreenAlphaHalveShad) $ concat cornerListNoCoord -- texture shaders, no textures attached - fsShad <- makeShader "texture/simple" [vert,frag] [2,2] ETriangleStrip $ const cornerList + fsShad <- makeShaderSized "texture/simple" [vert,frag] [2,2] 4 ETriangleStrip $ const cornerList -- note we directly poke the shader vertex data here pokeArray (_vboPointer $ _vaoVBO $ _shaderVAO fsShad) $ concat cornerList bloomBlurShad <- makeShaderUsingShaderVAO "texture/bloomBlur" [vert,frag] ETriangleStrip fsShad diff --git a/src/Render.hs b/src/Render.hs index 127bf72d2..0d721a1eb 100644 --- a/src/Render.hs +++ b/src/Render.hs @@ -19,7 +19,7 @@ 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 Data.IntMap.Strict as IM import qualified SDL divideSize :: Int -> Size -> Size @@ -152,6 +152,18 @@ renderShader shad dat = do eticks <- SDL.ticks return $ eticks - sticks +pokeBindFoldableLayer + :: Foldable f + => RenderData + -> f (Int,RenderType) + -> IO (IM.IntMap [(FullShader,Int)]) +pokeBindFoldableLayer pdata m = do + let slist = (,) <$> [0..6] <*> _pictureShaders pdata + + is <- F.foldM (traverse pokeShaderLayer slist) m + bindShaderLayer slist is + return $ IM.fromListWith (++) $ zipWith (\(i,fs) n -> (i,[(fs,n)])) slist is + renderFoldable :: Foldable f => RenderData diff --git a/src/Shader.hs b/src/Shader.hs index 300331a23..ec35ea48a 100644 --- a/src/Shader.hs +++ b/src/Shader.hs @@ -1,8 +1,10 @@ module Shader - ( bindArrayBuffers + ( bindShaderLayer , bindShaderBuffers + , bindArrayBuffers , drawShader , freeShaderPointers + , drawShaderLay ) where --import Geometry.Data import Shader.Data @@ -28,11 +30,41 @@ bindArrayBuffers numVs theVBO = do (fromIntegral $ floatSize * numVs * sum (_vboAttribSizes theVBO)) (_vboPointer theVBO) +bindArrayBuffersLayer :: Int -> Int -> VBO -> IO () +bindArrayBuffersLayer numVs lay theVBO = do + bindBuffer ArrayBuffer $= Just (_vbo theVBO) + bufferSubData + ArrayBuffer + WriteToBuffer + (fromIntegral $ floatSize * stride * numSubElements * lay) + (fromIntegral $ floatSize * numVs * stride) + (_vboPointer theVBO) + where + stride = sum $ _vboAttribSizes theVBO + +bindShaderLayer :: [(Int,FullShader)] -> [Int] -> IO () +bindShaderLayer = zipWithM_ f + where + f (l,fs) i = bindArrayBuffersLayer i l $ _vaoVBO $ _shaderVAO fs + bindShaderBuffers :: [FullShader] -> [Int] -> IO () bindShaderBuffers = zipWithM_ f where f fs i = bindArrayBuffers i $ _vaoVBO $ _shaderVAO fs +drawShaderLay :: Int -> FullShader -> Int -> IO () +{-# INLINE drawShaderLay #-} +drawShaderLay l fs i = do + currentProgram $= Just (_shaderProgram fs) + bindVertexArrayObject $= Just (_vao $ _shaderVAO fs) + case _shaderTexture fs of + Just ShaderTexture{_textureObject = txo} + -> textureBinding Texture2D $= Just txo + _ -> return () + glDrawArrays (marshalEPrimitiveMode $ _shaderDrawPrimitive fs) (fromIntegral $ l*stride*floatSize) (fromIntegral i) + where + stride = sum $ _vboAttribSizes $ _vaoVBO $ _shaderVAO fs + drawShader :: FullShader -> Int -> IO () {-# INLINE drawShader #-} drawShader fs i = do diff --git a/src/Shader/Compile.hs b/src/Shader/Compile.hs index 76559a861..86f21214d 100644 --- a/src/Shader/Compile.hs +++ b/src/Shader/Compile.hs @@ -1,5 +1,6 @@ module Shader.Compile ( makeShader + , makeShaderSized , makeShaderUsingShaderVAO , makeSourcedShader , setupVAO @@ -52,6 +53,29 @@ makeShader s shaderlist sizes pm renStrat = do , _shaderTexture = Nothing , _shaderCustomUnis = [] } +{- | +Compiles a full shader found within the shader directory. +The shader is made up of files begining with the inputted string with extensions .vert, .geom etc. +-} +makeShaderSized + :: String -- ^ First part of the name of the shader + -> [ShaderType] -- ^ Filetype extensions + -> [Int] -- ^ The input vertex sizes + -> Int -- ^ Number of vertexes that can be poked + -> EPrimitiveMode + -> (RenderType -> [[Float]]) -- ^ Poke strategy: method for creating a list of vertex data to be bound + -> IO FullShader +makeShaderSized s shaderlist sizes ndraw pm renStrat = do + prog <- makeSourcedShader s shaderlist + vaob <- setupVAOSized sizes ndraw + return $ FullShader + { _shaderProgram = prog + , _shaderVAO = vaob + , _shaderPokeStrategy = renStrat + , _shaderDrawPrimitive = pm + , _shaderTexture = Nothing + , _shaderCustomUnis = [] + } -- | Compile shader and get its uniform locations. -- supposes the shader code is in the shader folder, with the string names @@ -76,6 +100,15 @@ setupVAO sizes = do { _vao = theVAO , _vaoVBO = theVBO } +setupVAOSized :: [Int] -> Int -> IO VAO +setupVAOSized sizes ndraw = do + theVAO <- genObjectName + bindVertexArrayObject $= Just theVAO + theVBO <- setupVBOSized sizes ndraw + return $ VAO + { _vao = theVAO + , _vaoVBO = theVBO + } setupVBO :: [Int] -> IO VBO setupVBO sizes = do @@ -98,6 +131,28 @@ setupVBO sizes = do where strd = sum sizes offs = scanl (+) 0 sizes + +setupVBOSized :: [Int] -> Int -> IO VBO +setupVBOSized sizes ndraw = do + vboName <- genObjectName + bindBuffer ArrayBuffer $= Just vboName + forM_ (zip3 [0..] sizes offs) $ \(loc,siz,off) -> do + setupVertexAttribPointer loc siz strd off + thePtr <- mallocArray (strd * ndraw) + -- Allocate space + bufferData ArrayBuffer $= + (fromIntegral $ floatSize * ndraw * strd + , nullPtr + , DynamicDraw + ) + return $ VBO + { _vbo = vboName + , _vboPointer = thePtr + , _vboAttribSizes = sizes + } + where + strd = sum sizes + offs = scanl (+) 0 sizes {- | Assumes the correct VBO is bound -} setupVertexAttribPointer diff --git a/src/Shader/Parameters.hs b/src/Shader/Parameters.hs index d608a08e0..c7c1ea299 100644 --- a/src/Shader/Parameters.hs +++ b/src/Shader/Parameters.hs @@ -1,6 +1,7 @@ module Shader.Parameters ( floatSize , numDrawableElements + , numSubElements ) where import Graphics.Rendering.OpenGL hiding (Point,translate,scale,imageHeight) import Foreign @@ -11,5 +12,8 @@ floatSize = sizeOf (0.5 :: GLfloat) numDrawableElements :: Int {-# INLINE numDrawableElements #-} -numDrawableElements = 50000 +numDrawableElements = 70000 +numSubElements :: Int +{-# INLINE numSubElements #-} +numSubElements = 10000 diff --git a/src/Shader/Poke.hs b/src/Shader/Poke.hs index 4194b3019..5f4520615 100644 --- a/src/Shader/Poke.hs +++ b/src/Shader/Poke.hs @@ -1,8 +1,10 @@ module Shader.Poke ( pokeArrayOff , pokeShader + , pokeShaderLayer ) where import Shader.Data +import Shader.Parameters import Picture.Data import Foreign @@ -17,6 +19,15 @@ pokeShader fs = F.FoldM (pokeVertices fls ptr stride) (return 0) return stride = sum $ _vboAttribSizes theVBO fls = _shaderPokeStrategy fs +pokeShaderLayer :: (Int,FullShader) -> F.FoldM IO (Int,RenderType) Int +pokeShaderLayer (l,fs) = F.FoldM (pokeVerticesOff fls ptr stride l) (return 0) return + where + theVBO = _vaoVBO $ _shaderVAO fs + ptr = _vboPointer theVBO + stride = sum $ _vboAttribSizes theVBO + fls = _shaderPokeStrategy fs + + pokeVertices :: (RenderType -> [[Float]]) -> Ptr Float @@ -26,6 +37,24 @@ pokeVertices -> IO Int pokeVertices toFs ptr stride n rt = foldM (pokeVertex ptr stride) n (toFs rt) +pokeVerticesOff + :: (RenderType -> [[Float]]) + -> Ptr Float + -> Int -- ^ stride + -> Int -- ^ offset + -> Int -- ^ number of vertices already poked + -> (Int,RenderType) + -> IO Int +pokeVerticesOff toFs ptr stride offset n (i,rt) + | offset == i = foldM (pokeVertexOff ptr stride offset) n (toFs rt) + | otherwise = return n + +pokeVertexOff :: Ptr Float -> Int -> Int -> Int -> [Float] -> IO Int +pokeVertexOff ptr stride offset n fs = do + pokeArrayOff ptr (stride * (n + offset * numSubElements)) fs + return $ n + 1 + + pokeVertex :: Ptr Float -> Int -> Int -> [Float] -> IO Int pokeVertex ptr stride n fs = do pokeArrayOff ptr (stride * n) fs