Start modularising shader code

src/Picture/Preload.hs

@@ -8,6 +8,8 @@ module Picture.Preload
     where
 import Picture.Data
 import Shader
+import Shader.Compile
+import Shader.AuxAddition
 import Geometry.Data
 
 import Graphics.Rendering.OpenGL hiding (Point,translate,scale,imageHeight)

src/Shader.hs

@@ -1,18 +1,9 @@
 module Shader
-    ( makeShader
+    ( pokeShaders
-    , addTexture
-    , addUniforms
-    , pokeShaders
     , pokeArrayOff
-    --, pokeShader
     , pokeShader'
-    --, bindArrayBuffers
     , bindArrayBuffers'
     , bindShaderBuffers
-    , makeSourcedShader
-    , setupVAO
-    , floatSize
-    , numDrawableElements
     , drawShader
     , drawShaders
     , setShaderUniforms
@@ -25,15 +16,12 @@ module Shader
   where
 import Geometry
 import Shader.Data
+import Shader.Parameters
 import MatrixHelper
 import Picture.Data
 
 import Foreign
-import Codec.Picture
+import Control.Monad
-import qualified Data.ByteString as BS
-import qualified Data.Vector.Storable as V
-import Control.Monad (unless, forM, zipWithM_, forM_, foldM)
-import Control.Lens
 import qualified Control.Foldl as F
 import Graphics.Rendering.OpenGL hiding (Point,translate,scale,imageHeight)
 --import Text.RawString.QQ
@@ -55,13 +43,8 @@ pokeShader' fs = F.FoldM (pokeRender' fls ptr stride)  (return 0) return
     stride = sum $ _vboAttribSizes theVBO
     fls = _shaderPokeStrategy fs
 
-pokeRender :: (RenderType -> [[[Float]]])
-                -> [(Ptr Float,Int)] -> Int -> RenderType -> IO Int
-pokeRender toFs ptrs n rt = pokeList ptrs n (toFs rt)
-
 pokeRender' 
-    :: (RenderType 
+    :: (RenderType -> [[[Float]]])
-    -> [[[Float]]])
     -> Ptr Float
     -> Int  -- ^ stride
     -> Int 
@@ -69,9 +52,6 @@ pokeRender'
     -> IO Int
 pokeRender' toFs ptr stride n rt = pokeList' ptr stride n (toFs rt)
 
-pokeList :: [(Ptr Float,Int)] -> Int -> [[[Float]]] -> IO Int
-pokeList ptrs = foldM (pokePtrs ptrs)
-
 pokeList' :: Ptr Float -> Int -> Int -> [[[Float]]] -> IO Int
 pokeList' ptr stride = foldM (pokePtrs' ptr stride)
 
@@ -80,23 +60,9 @@ pokePtrs' ptr stride n fss = do
     pokeArrayOff ptr (stride * n) (concat fss)
     return $ n + 1
 
-pokePtrs :: [(Ptr Float,Int)] -> Int -> [[Float]] -> IO Int
-pokePtrs ptrIs n fss = do
-    zipWithM_ f ptrIs fss
-    return $ n + 1
-  where 
-    f (ptr,i) fs = pokeArrayOff ptr (i*n) fs
-
 pokeArrayOff :: Storable a => Ptr a -> Int -> [a] -> IO ()
 pokeArrayOff ptr i = zipWithM_ (pokeElemOff ptr) [i..]
 
-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 $ floatSize * numVs * i, ptr, DynamicDraw)
-
 bindArrayBuffers' :: Int -> VBO -> IO ()
 bindArrayBuffers' numVs theVBO = do
     bindBuffer ArrayBuffer $= Just (_vbo theVBO)
@@ -123,164 +89,7 @@ drawShader fs i = do
         _   -> return ()
     drawArrays (_shaderDrawPrimitive fs) 0 (fromIntegral i)
 
--- 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}
 
-{- | 
-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 = []
-                        }
-floatSize :: Int
-floatSize = sizeOf (0.5 :: GLfloat)
-{-# INLINE floatSize #-}
-
-bufferOffset :: Integral a => a -> Ptr b
-bufferOffset = plusPtr nullPtr . (* floatSize) . fromIntegral
-
-numDrawableElements :: Int
-{-# INLINE numDrawableElements #-}
-numDrawableElements = 50000
-
-setupVAO :: [Int] -> IO VAO
-setupVAO sizes = do
-    theVAO <- genObjectName
-    bindVertexArrayObject $= Just theVAO
-    vbos <- forM (zip (map fromIntegral [(0::Int)..]) sizes) setupArrayBuffer
-    ptrs <- forM (zip vbos sizes) setupVBOPointers
-    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
-
-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::Int))
-        )
-    vertexAttribArray (AttribLocation aloc) $= Enabled
-    return vbo
-
--- | 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)
-
-addUniforms :: [String] -> FullShader -> IO (FullShader)
-addUniforms uniStrings shad = do
-    uniLocs <- mapM (uniformLocation $ _shaderProgram shad) uniStrings
-    return $ shad & shaderCustomUnis %~ (++ uniLocs)
-
-shaderTypeExt :: ShaderType -> String
-shaderTypeExt VertexShader   = ".vert"
-shaderTypeExt GeometryShader = ".geom"
-shaderTypeExt FragmentShader = ".frag"
-shaderTypeExt _ = undefined
-
-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
 
 resetShaderUniforms :: [(Program, UniformLocation)] -> IO ()
 {-# INLINE resetShaderUniforms #-}

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
+