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

Remove polymorphism of shader type

Browse Source
This commit is contained in:
jgk
2021-06-11 19:41:17 +02:00
parent 0e0d8f4e99
commit 7b6521587d
6 changed files with 61 additions and 52 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Render.hs
+3 -2
View File
@@ -16,6 +16,7 @@ import Geometry
--import Picture
import Picture.Render
import Picture.Preload
import Picture.Data
import Shader
import MatrixHelper
@@ -135,7 +136,7 @@ renderBlankWalls
-> GLmatrix GLfloat
-> IO ()
renderBlankWalls pdata wps pmat = do
n <- F.foldM (pokeShader $ _wallBlankShader pdata) wps
n <- F.foldM (pokeShader $ _wallBlankShader pdata) (map Render22x4 wps)
bindShaderBuffers [_wallBlankShader pdata] [n]
currentProgram $= Just (_shaderProgram $ _wallBlankShader pdata)
uniform (_shaderMatrixUniform $ _wallBlankShader pdata) $= pmat
@@ -149,7 +150,7 @@ renderTextureWalls
-> GLmatrix GLfloat
-> IO ()
renderTextureWalls pdata wps pmat = do
n <- F.foldM (pokeShader $ _wallTextureShader pdata) wps
n <- F.foldM (pokeShader $ _wallTextureShader pdata) (map Render22x4 wps)
bindShaderBuffers [_wallTextureShader pdata] [n]
currentProgram $= Just (_shaderProgram $ _wallTextureShader pdata)
uniform (_shaderMatrixUniform $ _wallTextureShader pdata) $= pmat
src/Picture/Data.hs
+5
View File
@@ -20,6 +20,11 @@ data RenderType
| RenderArc (Point3,Point4,Point4)
| RenderLine [(Point3,Point4)]
| RenderEllipse [(Point3,Point4)]
| RenderConst
| Render1111 {_unRender1111 :: (Float,Float,Float,Float)}
| Render22 {_unRender22 :: (Point2,Point2)}
| Render22x4 {_unRender22x4 :: ((Point2,Point2),Point4)}
| Render3x2 {_unRender3x2 :: (Point3,Point2)}
type RGBA = (Float,Float,Float,Float)
type Color = (Float,Float,Float,Float)
src/Picture/Preload.hs
+28 -28
View File
@@ -16,17 +16,17 @@ import Foreign
import qualified Control.Foldl as F
data RenderData = RenderData
{ _lightingFloorShader :: FullShader (Float,Float,Float,Float)
, _lightingOccludeShader :: FullShader (Point2,Point2)
, _lightingWallShader :: FullShader (Point2,Point2)
, _wallBlankShader :: FullShader ((Point2,Point2),Point4)
, _wallTextureShader :: FullShader ((Point2,Point2),Point4)
, _backgroundShader :: FullShader (Point2,Point2,Point2,Point2)
, _textureShader :: FullShader (Point3,Point2)
, _fullscreenShader :: FullShader ()
, _boxBlurShader :: FullShader ()
, _grayscaleShader :: FullShader ()
, _pictureShaders :: [FullShader RenderType]
{ _lightingFloorShader :: FullShader
, _lightingOccludeShader :: FullShader
, _lightingWallShader :: FullShader
, _wallBlankShader :: FullShader
, _wallTextureShader :: FullShader
, _backgroundShader :: FullShader
--, _textureShader :: FullShader (Point3,Point2)
, _fullscreenShader :: FullShader
, _boxBlurShader :: FullShader
, _grayscaleShader :: FullShader
, _pictureShaders :: [FullShader]
, _spareFBO :: FramebufferObject
, _fboTexture :: TextureObject
, _fboRenderbufferObject :: RenderbufferObject
@@ -38,8 +38,8 @@ makeLenses ''RenderData
preloadRender :: IO RenderData
preloadRender = do
-- lighting shaders
lsShad <- makeShader "lighting/floor" [vert,geom,frag] [(0,4)] Points
(return . return . flat4)
lightningFloorShad <- makeShader "lighting/floor" [vert,geom,frag] [(0,4)] Points
(return . return . flat4 . _unRender1111)
wsShad <- makeShader "lighting/occlude" [vert,geom,frag] [(0,4)] Points pokeWPStrat
>>= addUniforms ["lightPos"]
wlLightShad
@@ -62,21 +62,21 @@ preloadRender = do
,[[-1,-1],[0,0]]
,[[ 1,-1],[1,0]]
]
_ <- F.foldM (pokeShader fsShad) [()] -- fix fullscreen vertex positions now
_ <- F.foldM (pokeShader fsShad) [RenderConst] -- fix fullscreen vertex positions now
boxBlurShad <- makeShader "texture/boxBlur" [vert,frag] [(0,2),(1,2)] TriangleStrip $ const
[[[-1, 1],[0,1]]
,[[ 1, 1],[1,1]]
,[[-1,-1],[0,0]]
,[[ 1,-1],[1,0]]
]
_ <- F.foldM (pokeShader boxBlurShad) [()] -- fix fullscreen vertex positions now
_ <- F.foldM (pokeShader boxBlurShad) [RenderConst] -- fix fullscreen vertex positions now
grayscaleShad <- makeShader "texture/grayscale" [vert,frag] [(0,2),(1,2)] TriangleStrip $ const
[[[-1, 1],[0,1]]
,[[ 1, 1],[1,1]]
,[[-1,-1],[0,0]]
,[[ 1,-1],[1,0]]
]
_ <- F.foldM (pokeShader grayscaleShad) [()] -- fix fullscreen vertex positions now
_ <- F.foldM (pokeShader grayscaleShad) [RenderConst] -- fix fullscreen vertex positions now
-- background shader
bgShad <- makeShader "background" [vert,geom,frag] [(0,4),(1,2)] Points pokeBGStrat
>>= addTexture "data/texture/marbleSlabs.png"
@@ -87,9 +87,9 @@ preloadRender = do
wlTexture <- makeShader "wall/texture" [vert,geom,frag] [(0,4),(1,4)] Points pokeWPColStrat
>>= addTexture "data/texture/grayscaleDirt.png"
-- texture shader
textShad <- makeShader "texture/simpleWorld" [vert,frag] [(0,3),(1,2)] Triangles poke32
>>= addTexture "data/texture/ayene_wooden_floor.png"
---- texture shader
-- textShad <- makeShader "texture/simpleWorld" [vert,frag] [(0,3),(1,2)] Triangles poke32
-- >>= addTexture "data/texture/ayene_wooden_floor.png"
-- framebuffer for lighting
(fbo,fboTO,fboRBO) <- setupFramebufferWithStencil
@@ -99,12 +99,12 @@ preloadRender = do
bindFramebuffer Framebuffer $= defaultFramebufferObject
return $ RenderData
{ _pictureShaders = [bslist,lslist,cslist,aslist,eslist,bezierQuadShader]
, _lightingFloorShader = lsShad
, _lightingFloorShader = lightningFloorShad
, _lightingOccludeShader = wsShad
, _lightingWallShader = wlLightShad
, _wallBlankShader = wlBlank
, _wallTextureShader = wlTexture
, _textureShader = textShad
--, _textureShader = textShad
, _backgroundShader = bgShad
, _fullscreenShader = fsShad
, _boxBlurShader = boxBlurShad
@@ -190,13 +190,13 @@ pokeBezQStrat _ = []
{-# INLINE pokeTriStrat #-}
pokeTriStrat,pokeCharStrat,pokeArcStrat,pokeLineStrat,pokeEllStrat :: RenderType -> [[[Float]]]
pokeTriStrat (RenderPoly vs) = fmap (\((x,y,z),(r,g,b,a)) -> [[x,y,z],[r,g,b,a]]) vs
pokeTriStrat (RenderPoly vs) = fmap (\(p,co) -> [flat3 p,flat4 co]) vs
pokeTriStrat _ = []
pokeCharStrat (RenderText vs) = fmap (\(a,b,c) -> flat3 (flat3 a, flat4 b, flat3 c)) vs
pokeCharStrat (RenderText vs) = fmap (\(a,b,c) -> [flat3 a, flat4 b, flat3 c]) vs
pokeCharStrat _ = []
pokeArcStrat (RenderArc (a,b,c)) = [flat3 (flat3 a, flat4 b, flat4 c)]
pokeArcStrat (RenderArc (a,b,c)) = [[flat3 a, flat4 b, flat4 c]]
pokeArcStrat _ = []
pokeLineStrat (RenderLine vs) = fmap (\((x,y,z),(r,g,b,a)) -> [[x,y,z],[r,g,b,a]]) vs
@@ -210,11 +210,11 @@ vert = VertexShader
geom = GeometryShader
frag = FragmentShader
pokeWPStrat :: (Point2,Point2) -> [[[Float]]]
pokeWPStrat ((x,y),(z,w)) = [[[x,y,z,w]]]
pokeWPStrat :: RenderType -> [[[Float]]]
pokeWPStrat Render22{_unRender22 = ((x,y),(z,w))} = [[[x,y,z,w]]]
pokeWPColStrat :: ((Point2,Point2),Point4) -> [[[Float]]]
pokeWPColStrat (((x,y),(z,w)),(r,g,b,a)) = [[[x,y,z,w],[r,g,b,a]]]
pokeWPColStrat :: RenderType -> [[[Float]]]
pokeWPColStrat Render22x4{_unRender22x4=(((x,y),(z,w)),(r,g,b,a))} = [[[x,y,z,w],[r,g,b,a]]]
poke32 :: (Point3,Point2) -> [[[Float]]]
poke32 ((x,y,z),(a,b)) = [[[x,y,z],[a,b]]]
src/Picture/Render.hs
+6 -6
View File
@@ -34,7 +34,7 @@ setWallDepth
setWallDepth pdata wallPoints (viewFromx,viewFromy) _ = do
startTicks <- SDL.ticks
colorMask $= Color4 Disabled Disabled Disabled Disabled
nWalls <- F.foldM (pokeShader $ _lightingOccludeShader pdata) wallPoints
nWalls <- F.foldM (pokeShader $ _lightingOccludeShader pdata) (map Render22 wallPoints)
bindShaderBuffers [_lightingOccludeShader pdata] [nWalls]
currentProgram $= Just (_shaderProgram $ _lightingOccludeShader pdata)
@@ -76,9 +76,9 @@ createLightMap pdata resDiv wallPoints lightPoints (viewFromx,viewFromy) pmat _
bindFramebuffer Framebuffer $= _spareFBO pdata
-- store wall and light positions into buffer
nWallLights <- F.foldM (pokeShader $ _lightingWallShader pdata) wallPoints
nWallLights <- F.foldM (pokeShader $ _lightingWallShader pdata) (map Render22 wallPoints)
bindShaderBuffers [_lightingWallShader pdata] [nWallLights]
nWalls <- F.foldM (pokeShader $ _lightingOccludeShader pdata) wallPoints
nWalls <- F.foldM (pokeShader $ _lightingOccludeShader pdata) (map Render22 wallPoints)
bindShaderBuffers [_lightingOccludeShader pdata] [nWalls]
-- set uniforms for shader that draws lights
currentProgram $= Just (_shaderProgram $ _lightingWallShader pdata)
@@ -237,14 +237,14 @@ setIsoMatrixUniforms pdata rot camZoom (tranx,trany) (winx,winy) = do
setShaderUniforms rot camZoom (tranx,trany) (winx,winy)
( extractProgAndUnis (_lightingFloorShader pdata)
: extractProgAndUnis (_backgroundShader pdata)
: extractProgAndUnis (_textureShader pdata)
-- : extractProgAndUnis (_textureShader pdata)
: map extractProgAndUnis (_pictureShaders pdata)
)
renderShader
:: Foldable f
=> FullShader a
-> f a
=> FullShader
-> f RenderType
-> IO Word32
renderShader shad dat = do
sticks <- SDL.ticks
src/Shader.hs
+15 -14
View File
@@ -23,6 +23,7 @@ module Shader
import Geometry
import Shader.Data
import MatrixHelper
import Picture.Data
import Foreign
import Codec.Picture
@@ -36,20 +37,20 @@ import Graphics.Rendering.OpenGL hiding (Point,translate,scale,imageHeight)
import Linear.Matrix
import Linear.V4
extractProgAndUnis :: FullShader a -> (Program,UniformLocation)
extractProgAndUnis :: FullShader -> (Program,UniformLocation)
extractProgAndUnis s = (_shaderProgram s, _shaderMatrixUniform s)
pokeShaders :: [FullShader a] -> F.FoldM IO a [Int]
pokeShaders :: [FullShader] -> F.FoldM IO RenderType [Int]
pokeShaders = traverse pokeShader
pokeShader :: FullShader a -> F.FoldM IO a Int
pokeShader :: FullShader -> F.FoldM IO RenderType Int
pokeShader fs = F.FoldM (pokeRender fls (zip ptrs nAtss)) (return 0) return
where
(_,ptrs,nAtss) = unzip3 $ _vaoBufferTargets $ _shaderVAO fs
fls = _shaderPokeStrategy fs
pokeRender :: (a -> [[[Float]]])
-> [(Ptr Float,Int)] -> Int -> a -> IO Int
pokeRender :: (RenderType -> [[[Float]]])
-> [(Ptr Float,Int)] -> Int -> RenderType -> IO Int
pokeRender toFs ptrs n rt = pokeList ptrs n (toFs rt)
pokeList :: [(Ptr Float,Int)] -> Int -> [[[Float]]] -> IO Int
@@ -72,15 +73,15 @@ bindArrayBuffers numVs ps = do
bindBuffer ArrayBuffer $= Just bo
bufferData ArrayBuffer $= (fromIntegral $ floatSize * numVs * i, ptr, DynamicDraw)
bindShaderBuffers :: [FullShader a] -> [Int] -> IO ()
bindShaderBuffers :: [FullShader] -> [Int] -> IO ()
bindShaderBuffers = zipWithM_ f
where
f fs i = bindArrayBuffers i $ _vaoBufferTargets $ _shaderVAO fs
drawShaders :: [FullShader a] -> [Int] -> IO ()
drawShaders :: [FullShader] -> [Int] -> IO ()
drawShaders = zipWithM_ drawShader
drawShader :: FullShader a -> Int -> IO ()
drawShader :: FullShader -> Int -> IO ()
{-# INLINE drawShader #-}
drawShader fs i = do
currentProgram $= Just (_shaderProgram fs)
@@ -93,7 +94,7 @@ drawShader fs i = do
-- I am not sure if this assumes that the shader is constructed directly before
-- the texture is added...
addTexture :: String -> FullShader a -> IO (FullShader a)
addTexture :: String -> FullShader -> IO (FullShader)
addTexture texturePath shad = do
Right cmap <- readImage texturePath
let tex = convertRGBA8 cmap
@@ -118,8 +119,8 @@ makeShader
-> [ShaderType] -- ^ Filetype extensions
-> [(GLuint,Int)] -- ^ The shaders input vertices (location, size)
-> PrimitiveMode
-> (a -> [[[Float]]]) -- ^ Poke strategy: method for creating a list of vertex data to be bound
-> IO (FullShader a)
-> (RenderType -> [[[Float]]]) -- ^ Poke strategy: method for creating a list of vertex data to be bound
-> IO (FullShader)
makeShader s shaderlist alocs pm renStrat = do
(prog,unis) <- makeSourcedShader s shaderlist
vaob <- setupVAO alocs
@@ -215,7 +216,7 @@ makeSourcedShader s sts = do
uniformLocations <- uniformLocation prog "worldMat"
return (prog,uniformLocations)
addUniforms :: [String] -> FullShader a -> IO (FullShader a)
addUniforms :: [String] -> FullShader -> IO (FullShader)
addUniforms uniStrings shad = do
uniLocs <- mapM (uniformLocation $ _shaderProgram shad) uniStrings
return $ shad & shaderCustomUnis %~ (++ uniLocs)
@@ -286,7 +287,7 @@ setPerpMatUniform
-> Point2 -- ^ translation
-> Point2 -- ^ window size
-> Point2 -- ^ viewfrom point
-> FullShader a
-> FullShader
-> IO ()
setPerpMatUniform rot czoom trans wins vFrom shad = do
pmat <- (newMatrix RowMajor $ perspectiveMatrix rot czoom trans wins vFrom) :: IO (GLmatrix GLfloat)
@@ -294,7 +295,7 @@ setPerpMatUniform rot czoom trans wins vFrom shad = do
uniform (_shaderMatrixUniform shad) $= pmat
return ()
freeShaderPointers :: FullShader a -> IO ()
freeShaderPointers :: FullShader -> IO ()
freeShaderPointers fs = do
forM_ (_vaoBufferTargets $ _shaderVAO fs) $ \(_,ptr,_) ->
free ptr
src/Shader/Data.hs
+4 -2
View File
@@ -21,6 +21,8 @@ module Shader.Data
-- , textureObject
) where
import Picture.Data
import Graphics.Rendering.OpenGL
import Foreign
import Control.Lens
@@ -42,11 +44,11 @@ data VBO = VBO
}
{- | Datatype containing the necessary information for a single shader. -}
data FullShader a = FullShader
data FullShader = FullShader
{ _shaderProgram :: Program
, _shaderMatrixUniform :: UniformLocation
, _shaderVAO :: VAO
, _shaderPokeStrategy :: a -> [[[Float]]]-- -> F.FoldM IO RenderType Int
, _shaderPokeStrategy :: RenderType -> [[[Float]]]-- -> F.FoldM IO RenderType Int
, _shaderDrawPrimitive :: PrimitiveMode
, _shaderTexture :: Maybe ShaderTexture
, _shaderCustomUnis :: [UniformLocation]