Start modularising shader code

src/Shader/AuxAddition.hs

@@ -0,0 +1,36 @@
+module Shader.AuxAddition
+    ( addTexture
+    , addUniforms
+    ) where
+import Shader.Data
+
+import Foreign
+import Codec.Picture
+import qualified Data.Vector.Storable as V
+import Control.Lens
+import Graphics.Rendering.OpenGL hiding (Point,translate,scale,imageHeight)
+--import Text.RawString.QQ
+    
+-- I am not sure if this assumes that the shader is constructed directly before
+-- the texture is added...
+addTexture :: String -> FullShader -> IO (FullShader)
+addTexture texturePath shad = do
+    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)
+    return $ shad & shaderTexture ?~ ShaderTexture {_textureObject = textureOb}
+
+
+addUniforms :: [String] -> FullShader -> IO (FullShader)
+addUniforms uniStrings shad = do
+    uniLocs <- mapM (uniformLocation $ _shaderProgram shad) uniStrings
+    return $ shad & shaderCustomUnis %~ (++ uniLocs)

src/Shader/Compile.hs

@@ -0,0 +1,123 @@
+module Shader.Compile
+    ( makeShader
+    , makeSourcedShader
+    , setupVAO
+    ) where
+import Shader.Data
+import Shader.Parameters
+import Picture.Data
+
+import Foreign
+import qualified Data.ByteString as BS
+import Control.Monad
+--import Control.Lens
+import Graphics.Rendering.OpenGL hiding (Point,translate,scale,imageHeight)
+
+{- | 
+Compiles a full shader found within the shader directory.
+The shader is made up of files begining with the inputted string with extensions .vert, .geom etc.
+-}
+makeShader 
+    :: String       -- ^ First part of the name of the shader
+    -> [ShaderType] -- ^ Filetype extensions
+    -> [Int]   -- ^ The input vertex sizes
+    -> PrimitiveMode
+    -> (RenderType -> [[[Float]]])   -- ^ Poke strategy: method for creating a list of vertex data to be bound
+    -> IO (FullShader)
+makeShader s shaderlist sizes pm renStrat = do
+    (prog,unis)  <- makeSourcedShader s shaderlist
+    vaob        <- setupVAO sizes
+    return $ FullShader { _shaderProgram = prog
+                        , _shaderMatrixUniform = unis
+                        , _shaderVAO = vaob
+                        , _shaderPokeStrategy = renStrat
+                        , _shaderDrawPrimitive = pm
+                        , _shaderTexture = Nothing
+                        , _shaderCustomUnis = []
+                        }
+
+-- | 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 <- uniformLocation prog "worldMat"
+    return (prog,uniformLocations)
+
+shaderTypeExt :: ShaderType -> String
+shaderTypeExt VertexShader   = ".vert"
+shaderTypeExt GeometryShader = ".geom"
+shaderTypeExt FragmentShader = ".frag"
+shaderTypeExt _ = undefined
+
+setupVAO :: [Int] -> IO VAO
+setupVAO sizes = do
+    theVAO <- genObjectName
+    bindVertexArrayObject $= Just theVAO
+    theVBO <- setupVBO $ sizes
+    return $ VAO 
+        { _vao = theVAO
+        , _vaoVBO = theVBO
+        }
+
+setupVBO :: [Int] -> IO VBO
+setupVBO sizes = do
+    vboName <- genObjectName
+    bindBuffer ArrayBuffer $= Just vboName
+    forM_ (zip3 [0..] sizes offs) $ \(loc,siz,off) -> do
+        setupVertexAttribPointer loc siz strd off
+    thePtr <- mallocArray (strd * numDrawableElements)
+    return $ VBO
+        { _vbo = vboName
+        , _vboPointer = thePtr
+        , _vboAttribSizes = sizes
+        }
+  where
+    strd = sum sizes
+    offs = scanl (+) 0 sizes
+    
+{- | Assumes the correct VBO is bound -}
+setupVertexAttribPointer 
+    :: Int  -- ^ Atrib location
+    -> Int  -- ^ Size
+    -> Int  -- ^ Stride 
+    -> Int  -- ^ Offset
+    -> IO ()
+setupVertexAttribPointer loc siz strd off = do
+    vertexAttribPointer (AttribLocation (fi loc)) $=
+        (ToFloat, VertexArrayDescriptor (fi' siz) Float (fi'' $ floatSize * strd) (bufferOffset off))
+    vertexAttribArray (AttribLocation (fi loc)) $= Enabled
+  where
+    fi = fromIntegral
+    fi' = fromIntegral
+    fi'' = fromIntegral
+
+makeShaderProgram :: String -> [(ShaderType,BS.ByteString)] -> IO Program
+makeShaderProgram str sources = do
+    theShaderProgram <- createProgram
+    shaders <- mapM (compileAndCheckShader str) sources
+    mapM_ (attachShader theShaderProgram) shaders
+
+    linkProgram theShaderProgram
+    linkingSuccess <- linkStatus theShaderProgram
+    unless linkingSuccess $ do
+        infoLog <- get (programInfoLog theShaderProgram)
+        putStrLn $ str ++ ": Program Linking" ++ infoLog
+    return theShaderProgram
+
+compileAndCheckShader :: String -> (ShaderType,BS.ByteString) -> IO Shader
+compileAndCheckShader str (theShaderType,sourceCode) = do
+    theShader <- createShader theShaderType
+    shaderSourceBS theShader $= sourceCode
+    compileShader theShader
+    success <- compileStatus theShader
+    unless success $ do
+        infoLog <- get (shaderInfoLog theShader)
+        putStrLn $ str ++ ": Shader compile: " ++ show theShaderType ++ " : " ++ show infoLog
+    return theShader
+
+bufferOffset :: Integral a => a -> Ptr b
+bufferOffset = plusPtr nullPtr . (* floatSize) . fromIntegral
+

src/Shader/Parameters.hs

@@ -0,0 +1,15 @@
+module Shader.Parameters
+    ( floatSize
+    , numDrawableElements
+    ) where
+import Graphics.Rendering.OpenGL hiding (Point,translate,scale,imageHeight)
+import Foreign
+
+floatSize :: Int
+floatSize = sizeOf (0.5 :: GLfloat)
+{-# INLINE floatSize #-}
+
+numDrawableElements :: Int
+{-# INLINE numDrawableElements #-}
+numDrawableElements = 50000
+