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:
justin
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/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