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

Broken binding of central picture in one pass

Browse Source
This commit is contained in:
jgk
2021-07-26 00:53:35 +02:00
parent 4f44b748bf
commit 5dfebd221d
9 changed files with 165 additions and 17 deletions
Download Patch File Download Diff File Expand all files Collapse all files
package.yaml
+4
View File
@@ -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
src/Dodge/Render.hs
+17 -8
View File
@@ -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
src/Picture.hs
+2 -2
View File
@@ -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 #-}
src/Preload/Render.hs
+7 -4
View File
@@ -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
src/Render.hs
+13 -1
View File
@@ -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
src/Shader.hs
+33 -1
View File
@@ -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
src/Shader/Compile.hs
+55
View File
@@ -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
src/Shader/Parameters.hs
+5 -1
View File
@@ -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
src/Shader/Poke.hs
+29
View File
@@ -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