Continue refactoring shaders

app/Main.hs

@@ -1,7 +1,7 @@
 module Main where
 
 import Loop
-import Shaders
+import Shader
 import Shapes
 
 import Dodge.Prototypes

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; }
+  float d = dot(gBoundingBox,gBoundingBox);
-  fColor = gColor;
+  if ( d > 1) { discard; }
-//  fColor = vec4 (1,1,1,1);
+  fColor = mix (gColorE , gColorC, d);
 }
 //note it is the fragdepth that stops this from being square

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);

shader/ellipseInterpolate.frag

@@ -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

@@ -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

@@ -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

@@ -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)]
 
-
+pokeShaders :: [FullShader RenderType] -> F.FoldM IO RenderType [Int]
-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 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

@@ -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,6 +61,7 @@ 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]
@@ -142,11 +70,11 @@ preloadRender = do
 
     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

@@ -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

@@ -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