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

Continue refactoring shaders

Browse Source
This commit is contained in:
jgk
2021-03-10 21:22:52 +01:00
parent 4a455cc7c9
commit a2fa713bde
10 changed files with 29 additions and 375 deletions
Download Patch File Download Diff File Expand all files Collapse all files
app/Main.hs
+1 -1
View File
@@ -1,7 +1,7 @@
module Main where
import Loop
import Shaders
import Shader
import Shapes
import Dodge.Prototypes
shader/ellipse.frag
+5 -4
View File
@@ -1,5 +1,6 @@
#version 430 core
in vec4 gColor;
in vec4 gColorC;
in vec4 gColorE;
in vec2 gBoundingBox;
out vec4 fColor;
@@ -7,8 +8,8 @@ out vec4 fColor;
void main()
{
if ( dot(gBoundingBox,gBoundingBox) > 1) { discard; }
fColor = gColor;
// fColor = vec4 (1,1,1,1);
float d = dot(gBoundingBox,gBoundingBox);
if ( d > 1) { discard; }
fColor = mix (gColorE , gColorC, d);
}
//note it is the fragdepth that stops this from being square
shader/ellipse.geom
+4 -2
View File
@@ -2,7 +2,8 @@
layout (triangles) in;
layout (triangle_strip, max_vertices = 4) out;
in vec4 vCol[];
out vec4 gColor;
out vec4 gColorC;
out vec4 gColorE;
out vec2 gBoundingBox;
uniform vec2 winSize;
@@ -13,7 +14,8 @@ void main()
vec3 pa = gl_in[0].gl_Position.xyz;
vec3 pb = gl_in[1].gl_Position.xyz;
vec3 pc = gl_in[2].gl_Position.xyz;
gColor = vCol[0];
gColorC = vCol[0];
gColorE = vCol[1];
gBoundingBox = vec2 (-1,1);
gl_Position = vec4 (pb, 1);
shader/ellipseInterpolate.frag
-15
View File
@@ -1,15 +0,0 @@
#version 430 core
in vec4 gColorC;
in vec4 gColorE;
in vec2 gBoundingBox;
out vec4 fColor;
//out float gl_FragDepth;
void main()
{
float d = dot(gBoundingBox,gBoundingBox);
if ( d > 1) { discard; }
fColor = mix (gColorE , gColorC, d);
}
//note it is the fragdepth that stops this from being square
shader/ellipseInterpolate.geom
-36
View File
@@ -1,36 +0,0 @@
#version 430 core
layout (triangles) in;
layout (triangle_strip, max_vertices = 4) out;
in vec4 vCol[];
out vec4 gColorC;
out vec4 gColorE;
out vec2 gBoundingBox;
uniform vec2 winSize;
uniform float zoom;
void main()
{
vec3 pa = gl_in[0].gl_Position.xyz;
vec3 pb = gl_in[1].gl_Position.xyz;
vec3 pc = gl_in[2].gl_Position.xyz;
gColorC = vCol[0];
gColorE = vCol[1];
gBoundingBox = vec2 (-1,1);
gl_Position = vec4 (pb, 1);
//gl_Position = vec4 (0.5,0,0, 1);
EmitVertex();
gBoundingBox = vec2 (1,1);
gl_Position = vec4 (pa, 1);
EmitVertex();
gBoundingBox = vec2 (-1,-1);
gl_Position = vec4 (pc, 1);
// gl_Position = vec4 (0.5,0.5,0, 1);
EmitVertex();
gBoundingBox = vec2 (1,-1);
gl_Position = vec4 (pa + pc - pb, 1);
EmitVertex();
EndPrimitive();
}
shader/ellipseInterpolate.vert
-16
View File
@@ -1,16 +0,0 @@
#version 430 core
layout (location = 0) in vec3 position;
layout (location = 1) in vec4 col;
out vec4 vCol;
uniform vec2 winSize;
uniform float zoom;
uniform vec2 translation;
uniform float rotation;
uniform mat4 worldMat;
void main()
{
gl_Position = worldMat * vec4(position,1);
vCol = col;
}
src/Picture/Data.hs
+4 -51
View File
@@ -2,6 +2,7 @@
--{-# LANGUAGE Strict #-}
module Picture.Data
where
import Shader.Data
import Data.Monoid
import qualified Data.Foldable as F
import qualified Data.Sequence as Se
@@ -24,63 +25,14 @@ import Data.Traversable
data RenderType
= RenderPoly [(Point3,Point4)]
| RenderText [(Point3,Point4,Point3)]
-- | RenderCirc (Point3,Point4,Float)
| RenderArc (Point3,Point4,Point4)
| RenderLine [(Point3,Point4)]
| RenderEllipse [(Point3,Point4)]
data VAO = VAO
{ _vao :: VertexArrayObject
, _vaoBufferTargets :: [(BufferObject,Ptr Float,Int)]
}
data FullShader = FullShader
{ _shaderProgram :: Program
, _shaderUniforms :: [UniformLocation]
, _shaderVAO :: VAO
, _shaderPokeStrategy :: RenderType -> [[[Float]]]-- -> F.FoldM IO RenderType Int
, _shaderDrawPrimitive :: PrimitiveMode
, _shaderTexture :: Maybe ShaderTexture
}
data ShaderTexture = ShaderTexture
{ _textureObject :: TextureObject }
makeLenses ''VAO
makeLenses ''FullShader
drawShaders :: [FullShader] -> [Int] -> IO ()
drawShaders fss is =
zipWithM_ f fss is
where f fs i = do
currentProgram $= Just (_shaderProgram fs)
bindVertexArrayObject $= (Just (_vao $ _shaderVAO fs))
case _shaderTexture fs of
Just (ShaderTexture {_textureObject = to})
-> textureBinding Texture2D $= Just to
_ -> return ()
drawArrays (_shaderDrawPrimitive fs) 0 (fromIntegral i)
bindShaderBuffers :: [FullShader] -> [Int] -> IO ()
bindShaderBuffers fss is =
zipWithM_ f fss is
where f fs i = bindArrayBuffers i $ _vaoBufferTargets $ _shaderVAO fs
fSize = sizeOf (0 :: Float)
bindArrayBuffers :: Int -> [(BufferObject,Ptr Float,Int)] -> IO ()
{-# INLINE bindArrayBuffers #-}
bindArrayBuffers numVs ps = do
forM_ ps $ \(bo,ptr,i) -> do
bindBuffer ArrayBuffer $= Just bo
bufferData ArrayBuffer $= (fromIntegral $ fSize * numVs * i, ptr, StreamDraw)
pokeShaders :: [FullShader] -> F.FoldM IO RenderType [Int]
pokeShaders :: [FullShader RenderType] -> F.FoldM IO RenderType [Int]
pokeShaders fss = traverse pokeShader fss
pokeShader :: FullShader -> F.FoldM IO RenderType Int
pokeShader :: FullShader RenderType -> F.FoldM IO RenderType Int
pokeShader fs = F.FoldM (pokeRender fls (zip ptrs nAtss)) (return 0) return
where vao = _shaderVAO fs
(_,ptrs,nAtss) = unzip3 $ _vaoBufferTargets $ vao
@@ -104,6 +56,7 @@ pokeArrayOff ptr i xs =
zipWithM_ (pokeElemOff ptr) [i..] xs
type RGBA = (Float,Float,Float,Float)
type Color = (Float,Float,Float,Float)
src/Picture/Preload.hs
+11 -85
View File
@@ -5,10 +5,10 @@ module Picture.Preload
import Picture.Data
import Codec.Picture
import Graphics.Rendering.OpenGL hiding (Point (..),translate,scale,imageHeight,imageWidth)
import qualified Graphics.Rendering.OpenGL as GL
import Codec.Picture
import qualified Data.Vector.Storable as V
import Control.Lens
@@ -16,15 +16,15 @@ import Control.Monad
import Foreign
import Shaders
import Shader
data RenderData = RenderData
{ --_charMap :: Image PixelRGBA8
_textures :: [TextureObject]
, _lightmapCircleShader :: (Program, [UniformLocation])
, _backShader :: (Program, [UniformLocation])
, _wallShadowShader :: (Program, [UniformLocation])
, _listShaders :: [FullShader]
, _lightmapCircleShader :: (Program, [UniformLocation])
, _listShaders :: [FullShader RenderType]
, _backVAO :: VAO
, _wallVAO :: VAO
, _fadeCircVAO :: VAO
@@ -35,46 +35,6 @@ data RenderData = RenderData
makeLenses ''RenderData
makeShader :: String -> [ShaderType] -> [(GLuint,Int)] -> PrimitiveMode -> (RenderType -> [[[Float]]]) -> IO FullShader
makeShader s shaderlist alocs pm renStrat = do
(prog,unis) <- makeSourcedShader s shaderlist
vao <- setupVAO alocs
return $ FullShader { _shaderProgram = prog
, _shaderUniforms = unis
, _shaderVAO = vao
, _shaderPokeStrategy = renStrat
, _shaderDrawPrimitive = pm
, _shaderTexture = Nothing
}
makeTextureShader :: String -> [ShaderType] -> [(GLuint,Int)]
-> PrimitiveMode -> (RenderType -> [[[Float]]])
-> String
-> IO FullShader
makeTextureShader s shaderlist alocs pm renStrat texturePath = do
(prog,unis) <- makeSourcedShader s shaderlist
Right cmap <- readImage texturePath
let tex = convertRGBA8 cmap
textureOb <- genObjectName
textureBinding Texture2D $= Just textureOb
let texData = V.toList $ imageData tex
wtex = fromIntegral $ imageWidth tex
htex = fromIntegral $ imageHeight tex
withArray texData $ \ptr -> do
texImage2D Texture2D NoProxy 0 RGBA8 (TextureSize2D wtex htex) 0
(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}
}
pokeTriStrat (RenderPoly vs) = fmap (\((x,y,z),(r,g,b,a)) -> [[x,y,z],[r,g,b,a]]) vs
pokeTriStrat _ = []
@@ -91,39 +51,6 @@ pokeLineStrat _ = []
pokeEllStrat (RenderEllipse vs) = fmap (\((x,y,z),(r,g,b,a)) -> [[x,y,z],[r,g,b,a]]) vs
pokeEllStrat _ = []
floatSize = sizeOf (0.5 :: GLfloat)
setupVAO :: [(GLuint,Int)] -> IO VAO
setupVAO ps = do
theVAO <- genObjectName
bindVertexArrayObject $= Just theVAO
vbos <- forM ps setupArrayBuffer
ptrs <- forM (zip vbos $ map snd ps) setupVBOPointers
return $ VAO theVAO ptrs
numDrawableElements :: Int
numDrawableElements = 50000
setupVBOPointers :: (BufferObject,Int) -> IO (BufferObject,Ptr Float,Int)
setupVBOPointers (vbo,vsize) = do
thePtr <- mallocArray (vsize * numDrawableElements)
return (vbo,thePtr,vsize)
setupArrayBuffer :: (GLuint,Int) -> IO BufferObject
setupArrayBuffer (aloc,i) = do
vbo <- genObjectName
bindBuffer ArrayBuffer $= Just vbo
vertexAttribPointer (AttribLocation aloc) $=
( ToFloat
, VertexArrayDescriptor (fromIntegral i)
Float
(fromIntegral $ floatSize * i)
(bufferOffset 0)
)
vertexAttribArray (AttribLocation aloc) $= Enabled
return vbo
bufferOffset :: Integral a => a -> Ptr b
bufferOffset = plusPtr nullPtr . fromIntegral
@@ -134,19 +61,20 @@ frag = FragmentShader
preloadRender :: IO RenderData
preloadRender = do
-- compile shader programs
lsShad <- makeShader "lightmapCircle" [vert,geom,frag] [(0,4)] Points (return . return . flat4)
fcs <- makeSourcedShader "lightmapCircle" [VertexShader,GeometryShader,FragmentShader]
bgs <- makeSourcedShader "background" [VertexShader,GeometryShader,FragmentShader]
wss <- makeSourcedShader "wallShadow" [VertexShader,GeometryShader,FragmentShader]
wssLightPosUniLoc <- GL.uniformLocation (fst wss) "lightPos"
bslist <- makeShader "basic" [vert,frag] [(0,3),(1,4)] Triangles pokeTriStrat
lslist <- makeShader "basic" [vert,frag] [(0,3),(1,4)] Lines pokeLineStrat
bslist <- makeShader "basic" [vert,frag] [(0,3),(1,4)] Triangles pokeTriStrat
lslist <- makeShader "basic" [vert,frag] [(0,3),(1,4)] Lines pokeLineStrat
aslist <- makeShader "arc" [vert,geom,frag] [(0,3),(1,4),(2,3)] Points pokeArcStrat
eslist <- makeShader "ellipse" [vert,geom,frag] [(0,3),(1,4)] Triangles pokeEllStrat
cslist <- makeTextureShader "character" [vert,geom,frag]
[(0,3),(1,4),(2,3)] Points pokeCharStrat
"data/texture/charMap.png"
aslist <- makeShader "arc" [vert,geom,frag] [(0,3),(1,4),(2,3)] Points pokeArcStrat
eslist <- makeShader "ellipseInterpolate" [vert,geom,frag] [(0,3),(1,4)] Triangles pokeEllStrat
--the following vbo is set up to contain one fixed vertex
dummyvbo <- genObjectName
@@ -168,13 +96,11 @@ preloadRender = do
generateMipmap' Texture2D
textureFilter Texture2D $= ((Linear',Just Linear') , Nearest)
--textureBinding Texture2D $= Just chartex
-- input a list of (attribute location, attrib length) pairs
-- these will have buffers and pointers created
backgroundvao <- setupVAO [(0,4),(1,2)]
wallvao <- setupVAO [(0,4),(1,4)]
fadecircvao <- setupVAO [(0,4)]
fadevao <- setupVAO [(0,4)]
return $ RenderData
{ -- _charMap = convertRGBA8 cmap
@@ -185,7 +111,7 @@ preloadRender = do
, _wallShadowShader = wss
, _backVAO = backgroundvao
, _wallVAO = wallvao
, _fadeCircVAO = fadecircvao
, _fadeCircVAO = fadevao
, _dummyVBO = dummyvbo
, _dummyPtr = dummyptr
, _wssLightPos = wssLightPosUniLoc
src/Picture/Render.hs
+4 -8
View File
@@ -2,6 +2,9 @@
{-# LANGUAGE DeriveFoldable, StandaloneDeriving #-}
module Picture.Render
where
import Shader
import Control.Lens
import Control.Monad
@@ -284,13 +287,6 @@ pokeLineVert pa pb n (p,c)
pokeCirc :: ThreePtrs -> Int -> RenderType -> IO Int
{-# INLINE pokeCirc #-}
--pokeCirc (pa,pb,pc) n (RenderCirc (p,c,s))
-- | n > 20000 * 2 = return n
-- | otherwise = do
-- pokeThreeOff pa n p
-- pokeFourOff pb n c
-- pokeElemOff pc n s
-- return (n+1)
pokeCirc _ n _ = return n
pokeText :: (Ptr Float, Ptr Float, Ptr Float) -> Int -> RenderType -> IO Int
@@ -342,7 +338,7 @@ threePtrsVAO :: VAO -> (Ptr Float, Ptr Float,Ptr Float)
threePtrsVAO vao = case (\(_,ps,_) -> ps) $ unzip3 $ _vaoBufferTargets vao of
(a:b:c:_) -> (a,b,c)
setShaderUniforms :: Float -> Float -> Point2 -> Point2 -> [FullShader] -> IO ()
setShaderUniforms :: Float -> Float -> Point2 -> Point2 -> [FullShader RenderType] -> IO ()
setShaderUniforms rot zoom (tranx,trany) (winx,winy) fss = do
let scalMat = Linear.Matrix.transpose $
V4 (V4 (2*zoom/winx) 0 0 (0::GLfloat))
src/Shaders.hs
-157
View File
@@ -1,157 +0,0 @@
{-# LANGUAGE QuasiQuotes #-}
module Shaders
(--makeTextureShader
-- ,makeBasicShader
makeFadeShader
,makeCircleShader
,makeArcShader
,makeBackgroundShader
,makeWallShadowShader
,makeSourcedShader
)
where
import Graphics.Rendering.OpenGL
import Control.Monad (when, forM)
import Text.RawString.QQ
import qualified Data.ByteString as BS
-- compile shader and get its uniform locations
-- supposes the shader code is in the shader folder, with the string names
-- followed by .vert/.geom/.frag
makeSourcedShader :: String -> [ShaderType] -> IO (Program, [UniformLocation])
makeSourcedShader s sts = do
sources <- forM sts $ \st -> BS.readFile ("shader/" ++ s ++ shaderTypeExt st)
prog <- makeShaderProgram' s $ zip sts sources
uniformLocations <- forM ["winSize","zoom","rotation","translation","worldMat"]
$ \uniString -> uniformLocation prog uniString
return (prog,uniformLocations)
shaderTypeExt :: ShaderType -> String
shaderTypeExt VertexShader = ".vert"
shaderTypeExt GeometryShader = ".geom"
shaderTypeExt FragmentShader = ".frag"
makeBasicShader :: IO Program
makeBasicShader = do
vsSource <- BS.readFile "shader/basic.vert"
fsSource <- BS.readFile "shader/basic.frag"
makeShaderProgram [(VertexShader, vsSource)
,(FragmentShader, fsSource)
]
makeCircleShader :: IO Program
makeCircleShader = do
vsSource <- BS.readFile "shader/circle.vert"
gsSource <- BS.readFile "shader/circle.geom"
fsSource <- BS.readFile "shader/circle.frag"
makeShaderProgram [(VertexShader, vsSource )
,(GeometryShader, gsSource )
,(FragmentShader, fsSource )
]
makeArcShader :: IO Program
makeArcShader = do
vsSource <- BS.readFile "shader/arc.vert"
gsSource <- BS.readFile "shader/arc.geom"
fsSource <- BS.readFile "shader/arc.frag"
makeShaderProgram [(VertexShader, vsSource )
,(GeometryShader, gsSource )
,(FragmentShader, fsSource )
]
makeFadeShader :: IO Program
makeFadeShader = do
vsSource <- BS.readFile "shader/lightmapCircle.vert"
gsSource <- BS.readFile "shader/lightmapCircle.geom"
fsSource <- BS.readFile "shader/lightmapCircle.frag"
makeShaderProgram [(VertexShader, vsSource )
,(GeometryShader, gsSource )
,(FragmentShader, fsSource )
]
makeBackgroundShader :: IO Program
makeBackgroundShader = do
vsSource <- BS.readFile "shader/background.vert"
gsSource <- BS.readFile "shader/background.geom"
fsSource <- BS.readFile "shader/background.frag"
makeShaderProgram [(VertexShader, vsSource )
,(GeometryShader, gsSource )
,(FragmentShader, fsSource )
]
makeWallShadowShader :: IO Program
makeWallShadowShader = do
vsSource <- BS.readFile "shader/wallShadow.vert"
gsSource <- BS.readFile "shader/wallShadow.geom"
fsSource <- BS.readFile "shader/wallShadow.frag"
makeShaderProgram [(VertexShader, vsSource )
,(GeometryShader, gsSource )
,(FragmentShader, fsSource )
]
makeTextureShader :: IO Program
makeTextureShader = do
vsSource <- BS.readFile "shader/basicTexture.vert"
gsSource <- BS.readFile "shader/basicTexture.geom"
fsSource <- BS.readFile "shader/basicTexture.frag"
makeShaderProgram [(VertexShader, vsSource )
,(GeometryShader, gsSource )
,(FragmentShader, fsSource )
]
makeShaderProgram' :: String -> [(ShaderType,BS.ByteString)] -> IO Program
makeShaderProgram' str sources = do
shaderProgram <- createProgram
shaders <- mapM (compileAndCheckShader' str) sources
mapM_ (attachShader shaderProgram) shaders
linkProgram shaderProgram
linkingSuccess <- linkStatus shaderProgram
when (not linkingSuccess) $ do
infoLog <- get (programInfoLog shaderProgram)
putStrLn $ str ++ ": Program Linking" ++ infoLog
return shaderProgram
makeShaderProgram :: [(ShaderType,BS.ByteString)] -> IO Program
makeShaderProgram sources = do
shaderProgram <- createProgram
shaders <- mapM compileAndCheckShader sources
mapM_ (attachShader shaderProgram) shaders
linkProgram shaderProgram
linkingSuccess <- linkStatus shaderProgram
when (not linkingSuccess) $ do
infoLog <- get (programInfoLog shaderProgram)
putStrLn $ "Program Linking" ++ infoLog
return shaderProgram
compileAndCheckShader :: (ShaderType,BS.ByteString) -> IO Shader
compileAndCheckShader (shaderType,sourceCode) = do
theShader <- createShader shaderType
shaderSourceBS theShader $= sourceCode
compileShader theShader
success <- compileStatus theShader
when (not success) $ do
infoLog <- get (shaderInfoLog theShader)
putStrLn $ "Shader compile: " ++ show shaderType ++ " : " ++ show infoLog
return theShader
compileAndCheckShader' :: String -> (ShaderType,BS.ByteString) -> IO Shader
compileAndCheckShader' str (shaderType,sourceCode) = do
theShader <- createShader shaderType
shaderSourceBS theShader $= sourceCode
compileShader theShader
success <- compileStatus theShader
when (not success) $ do
infoLog <- get (shaderInfoLog theShader)
putStrLn $ str ++ ": Shader compile: " ++ show shaderType ++ " : " ++ show infoLog
return theShader