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

Add picture shader container datatype

Browse Source
This commit is contained in:
jgk
2021-07-28 20:14:54 +02:00
parent a2b94965d7
commit ee553c6e49
9 changed files with 201 additions and 78 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Data/Preload/Render.hs
+1 -1
View File
@@ -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)
src/Dodge/Render.hs
+16 -20
View File
@@ -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
src/Picture.hs
+5 -5
View File
@@ -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}
src/Preload/Render.hs
+10 -3
View File
@@ -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
src/Render.hs
+28 -18
View File
@@ -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
src/Shader.hs
+21 -11
View File
@@ -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
src/Shader/Compile.hs
+2
View File
@@ -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
src/Shader/Data.hs
+74
View File
@@ -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
src/Shader/Poke.hs
+44 -20
View File
@@ -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))