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

Refactor shader creation

Browse Source
This commit is contained in:
jgk
2021-03-21 17:10:10 +01:00
parent 1ecbe2375d
commit 279f928375
4 changed files with 52 additions and 50 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Rendering.hs
+4 -2
View File
@@ -320,14 +320,16 @@ drawWallFace w wall
-- it is not obvious which will be returned
intersectLinefromScreen :: World -> Point2 -> Point2 -> Maybe Point2
intersectLinefromScreen w a b = listToMaybe
. mapMaybe (\(x,y) -> intersectSegLineFrom' x y a b)
. mapMaybe (\(x,y) -> intersectSegLineext x y a b)
. makeLoopPairs
$ screenPolygon w
extendConeToScreenEdge :: World -> Point2 -> (Point2,Point2) -> [Point2]
extendConeToScreenEdge w c (x,y) = orderPolygon $ [x,y] ++ borderPs ++ cornerPs
extendConeToScreenEdge w c (x,y) = orderPolygon $ wallScreenIntersect ++ [x,y] ++ borderPs ++ cornerPs
where borderPs = mapMaybe (intersectLinefromScreen w c) [x,y]
cornerPs = filter (pointIsInCone c (x,y)) $ screenPolygon w
wallScreenIntersect = mapMaybe (uncurry $ intersectSegSeg' x y)
. makeLoopPairs $ screenPolygon w
displayInv :: Int -> World -> Picture
displayInv n w = pictures $ zipWith (translate (15-halfWidth w))
src/Geometry/Intersect.hs
+15
View File
@@ -44,6 +44,21 @@ intersectSegLineFrom' (x1,y1) (x2,y2) (x3,y3) (x4,y4)
t' = (x1-x3)*(y3-y4) - (y1-y3)*(x3-x4)
u' = (y1-y2)*(x1-x3) - (x1-x2)*(y1-y3)
-- this is probably not correct...
intersectSegLineext :: Point2 -> Point2 -> Point2 -> Point2 -> Maybe Point2
{-# INLINE intersectSegLineext #-}
intersectSegLineext (x1,y1) (x2,y2) (x3,y3) (x4,y4)
| den == 0 = Nothing
| den > 0 && ( t' < 0 || u' < den || t' > den )
= Nothing
| den < 0 && ( t' > 0 || u' > - den || t' < den )
= Nothing
| otherwise = Just (x1 + (x2-x1)*t'/den, y1 + (y2-y1)*t'/den)
where
den = (x1-x2)*(y3-y4) - (y1-y2)*(x3-x4)
t' = (x1-x3)*(y3-y4) - (y1-y3)*(x3-x4)
u' = (y1-y2)*(x1-x3) - (x1-x2)*(y1-y3)
intersectSegLine' :: Point2 -> Point2 -> Point2 -> Point2 -> Maybe Point2
{-# INLINE intersectSegLine' #-}
intersectSegLine' (x1,y1) (x2,y2) (x3,y3) (x4,y4)
src/Picture/Preload.hs
+18 -8
View File
@@ -21,6 +21,7 @@ data RenderData = RenderData
{ _lightSourceShader :: FullShader (Float,Float,Float,Float)
, _wallShadowShader :: FullShader (Point2,Point2)
, _wallLightShader :: FullShader (Point2,Point2)
, _wallFaceShader :: FullShader (Point2,Point2,Point4)
, _backgroundShader :: FullShader (Point2,Point2,Point2,Point2)
, _fullscreenShader :: FullShader ()
, _listShaders :: [FullShader RenderType]
@@ -35,11 +36,11 @@ preloadRender = do
-- lighting shaders
lsShad <- makeShader "lighting/lightmapCircle" [vert,geom,frag] [(0,4)] Points
(return . return . flat4)
wsShad <- makeShaderCustomUnis "lighting/wallShadow" [vert,geom,frag] [(0,4)] Points pokeWPStrat
["lightPos","perpMat","facesToDraw"]
wsShad <- makeShader "lighting/wallShadow" [vert,geom,frag] [(0,4)] Points pokeWPStrat
>>= addUniforms ["lightPos","perpMat","facesToDraw"]
wlLightShad
<- makeShaderCustomUnis "lighting/lightmapWall" [vert,geom,frag] [(0,4)] Points pokeWPStrat
["lightPos","perpMat","radLum"]
<- makeShader "lighting/lightmapWall" [vert,geom,frag] [(0,4)] Points pokeWPStrat
>>= addUniforms ["lightPos","perpMat","radLum"]
-- 2D draw shaders
bslist <- makeShader "twoD/basic" [vert,frag] [(0,3),(1,4)] Triangles pokeTriStrat
@@ -48,9 +49,9 @@ preloadRender = do
eslist <- makeShader "twoD/ellipse" [vert,geom,frag] [(0,3),(1,4)] Triangles pokeEllStrat
bezierQuadShader <- makeShader
"twoD/bezierQuad" [vert,frag] [(0,3),(1,4),(2,4)] TriangleStrip pokeBezQStrat
cslist <- makeTextureShader "twoD/character" [vert,geom,frag]
cslist <- makeShader "twoD/character" [vert,geom,frag]
[(0,3),(1,4),(2,3)] Points pokeCharStrat
"data/texture/charMap.png"
>>= addTexture "data/texture/charMap.png"
-- fullscreen shader
fsShad <- makeShader "fullscreen" [vert,frag] [(0,2),(1,2)] TriangleStrip
@@ -63,8 +64,13 @@ preloadRender = do
n <- F.foldM (pokeShader fsShad) [()] -- fix fullscreen vertex positions now
-- background shader
bgShad <- makeTextureShader "background" [vert,geom,frag] [(0,4),(1,2)] Points pokeBGStrat
"data/texture/smudgedDirt.png"
bgShad <- makeShader "background" [vert,geom,frag] [(0,4),(1,2)] Points pokeBGStrat
>>= addTexture "data/texture/smudgedDirt.png"
-- wallShader
wlShad <- makeShader "wallFace" [vert,geom,frag] [(0,4),(1,4)] Points pokeWPColStrat
>>= addTexture "data/texture/smudgedDirt.png"
>>= addUniforms ["perpMat"]
-- framebuffer for lighting
(fbo,fboTO) <- setupFramebuffer
@@ -77,6 +83,7 @@ preloadRender = do
, _lightSourceShader = lsShad
, _wallShadowShader = wsShad
, _wallLightShader = wlLightShad
, _wallFaceShader = wlShad
, _backgroundShader = bgShad
, _fullscreenShader = fsShad
, _spareFBO = fbo
@@ -148,6 +155,9 @@ frag = FragmentShader
pokeWPStrat :: (Point2,Point2) -> [[[Float]]]
pokeWPStrat ((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]]]
pokeBGStrat :: a -> [[[Float]]]
pokeBGStrat = const []
src/Shader.hs
+15 -40
View File
@@ -1,8 +1,8 @@
{-# LANGUAGE QuasiQuotes #-}
module Shader
( makeShader
, makeTextureShader
, makeShaderCustomUnis
, addTexture
, addUniforms
, pokeShaders
, pokeShader
, bindArrayBuffers
@@ -28,6 +28,9 @@ import Codec.Picture
import qualified Data.Vector.Storable as V
import Control.Monad (when, forM, zipWithM_, forM_, foldM)
import Control.Lens
import Data.Maybe (fromMaybe)
import qualified Control.Foldl as F
@@ -97,13 +100,10 @@ drawShader fs i = do
_ -> return ()
drawArrays (_shaderDrawPrimitive fs) 0 (fromIntegral i)
makeTextureShader :: String -> [ShaderType] -> [(GLuint,Int)]
-> PrimitiveMode -> (a -> [[[Float]]])
-> String
-> IO (FullShader a)
makeTextureShader s shaderlist alocs pm renStrat texturePath = do
(prog,unis) <- makeSourcedShader s shaderlist
-- 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 texturePath shad = do
Right cmap <- readImage texturePath
let tex = convertRGBA8 cmap
textureOb <- genObjectName
@@ -116,31 +116,7 @@ makeTextureShader s shaderlist alocs pm renStrat texturePath = do
(PixelData RGBA UnsignedByte ptr)
generateMipmap' Texture2D
textureFilter Texture2D $= ((Linear',Just Linear') , Nearest)
vao <- setupVAO alocs
return $ FullShader { _shaderProgram = prog
, _shaderUniforms = unis
, _shaderVAO = vao
, _shaderPokeStrategy = renStrat
, _shaderDrawPrimitive = pm
, _shaderTexture = Just $ ShaderTexture {_textureObject = textureOb}
, _shaderCustomUnis = Nothing
}
makeShaderCustomUnis :: String -> [ShaderType] -> [(GLuint,Int)] -> PrimitiveMode -> (a -> [[[Float]]])
-> [String] -> IO (FullShader a)
makeShaderCustomUnis s shaderlist alocs pm renStrat uniStrings = do
(prog,unis,unis') <- makeSourcedShaderCustomUnis s shaderlist uniStrings
vao <- setupVAO alocs
return $ FullShader { _shaderProgram = prog
, _shaderUniforms = unis
, _shaderVAO = vao
, _shaderPokeStrategy = renStrat
, _shaderDrawPrimitive = pm
, _shaderTexture = Nothing
, _shaderCustomUnis = Just unis'
}
return $ shad & shaderTexture .~ Just (ShaderTexture {_textureObject = textureOb})
makeShader :: String -> [ShaderType] -> [(GLuint,Int)] -> PrimitiveMode -> (a -> [[[Float]]]) -> IO (FullShader a)
makeShader s shaderlist alocs pm renStrat = do
@@ -203,12 +179,11 @@ makeSourcedShader s sts = do
$ \uniString -> uniformLocation prog uniString
return (prog,uniformLocations)
makeSourcedShaderCustomUnis :: String -> [ShaderType] -> [String]
-> IO (Program, [UniformLocation], [UniformLocation])
makeSourcedShaderCustomUnis s shadTypes uniStrings = do
(prog,unis0) <- makeSourcedShader s shadTypes
unis <- mapM (uniformLocation prog) uniStrings
return (prog,unis0,unis)
addUniforms :: [String] -> FullShader a -> IO (FullShader a)
addUniforms uniStrings shad = do
uniLocs <- mapM (uniformLocation $ _shaderProgram shad) uniStrings
return $ shad & shaderCustomUnis %~ Just . (++ uniLocs) . fromMaybe []
shaderTypeExt :: ShaderType -> String
shaderTypeExt VertexShader = ".vert"