From a2fa713bde2d8d15a2851883a0063d1d71b50f26 Mon Sep 17 00:00:00 2001 From: jgk Date: Wed, 10 Mar 2021 21:22:52 +0100 Subject: [PATCH] Continue refactoring shaders --- app/Main.hs | 2 +- shader/ellipse.frag | 9 +- shader/ellipse.geom | 6 +- shader/ellipseInterpolate.frag | 15 ---- shader/ellipseInterpolate.geom | 36 -------- shader/ellipseInterpolate.vert | 16 ---- src/Picture/Data.hs | 55 +----------- src/Picture/Preload.hs | 96 +++----------------- src/Picture/Render.hs | 12 +-- src/Shaders.hs | 157 --------------------------------- 10 files changed, 29 insertions(+), 375 deletions(-) delete mode 100644 shader/ellipseInterpolate.frag delete mode 100644 shader/ellipseInterpolate.geom delete mode 100644 shader/ellipseInterpolate.vert delete mode 100644 src/Shaders.hs diff --git a/app/Main.hs b/app/Main.hs index cc459a896..1fc1eded5 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -1,7 +1,7 @@ module Main where import Loop -import Shaders +import Shader import Shapes import Dodge.Prototypes diff --git a/shader/ellipse.frag b/shader/ellipse.frag index b4ef2a9ed..9f2073c76 100644 --- a/shader/ellipse.frag +++ b/shader/ellipse.frag @@ -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 diff --git a/shader/ellipse.geom b/shader/ellipse.geom index 307dfac3a..9deea4868 100644 --- a/shader/ellipse.geom +++ b/shader/ellipse.geom @@ -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); diff --git a/shader/ellipseInterpolate.frag b/shader/ellipseInterpolate.frag deleted file mode 100644 index 9f2073c76..000000000 --- a/shader/ellipseInterpolate.frag +++ /dev/null @@ -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 diff --git a/shader/ellipseInterpolate.geom b/shader/ellipseInterpolate.geom deleted file mode 100644 index 9deea4868..000000000 --- a/shader/ellipseInterpolate.geom +++ /dev/null @@ -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(); -} diff --git a/shader/ellipseInterpolate.vert b/shader/ellipseInterpolate.vert deleted file mode 100644 index 7abf7b24a..000000000 --- a/shader/ellipseInterpolate.vert +++ /dev/null @@ -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; -} diff --git a/src/Picture/Data.hs b/src/Picture/Data.hs index 507aa588d..aa287b47a 100644 --- a/src/Picture/Data.hs +++ b/src/Picture/Data.hs @@ -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) diff --git a/src/Picture/Preload.hs b/src/Picture/Preload.hs index 8f47d172f..34c55fde5 100644 --- a/src/Picture/Preload.hs +++ b/src/Picture/Preload.hs @@ -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 diff --git a/src/Picture/Render.hs b/src/Picture/Render.hs index 6c4554e2d..e472fc0eb 100644 --- a/src/Picture/Render.hs +++ b/src/Picture/Render.hs @@ -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)) diff --git a/src/Shaders.hs b/src/Shaders.hs deleted file mode 100644 index 12e2e84f4..000000000 --- a/src/Shaders.hs +++ /dev/null @@ -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