Start cleanup

src/Data/Preload/Render.hs

@@ -26,7 +26,7 @@ data RenderData = RenderData
     , _colorBlurShader          :: FullShader
     , _barrelShader             :: FullShader
     , _grayscaleShader          :: FullShader
-    , _pictureShaders           :: MV.MVector (PrimState IO) VShader
+    , _pictureShaders           :: MV.MVector (PrimState IO) FullShader
     , _fbo2                     :: (FramebufferObject, TextureObject)
     , _fbo3                     :: (FramebufferObject, TextureObject)
     , _fboFourth1 :: (FramebufferObject, TextureObject)

src/Dodge/Render.hs

@@ -82,7 +82,7 @@ doDrawing pdata w = do
 
     layerCounts <- UMV.replicate (6*6) 0
     pokeBindFoldableLayer shadV layerCounts $ worldPictures w
-    renderLayer' 0 shadV layerCounts
+    renderLayer 0 shadV layerCounts
 
     nTextArrayVs <- pokePoint33s (shadVBOptr $ _textureArrayShader pdata) (_floorTiles w)
     bindShaderBuffers [_textureArrayShader pdata] [nTextArrayVs]
@@ -92,14 +92,14 @@ doDrawing pdata w = do
     clear [ColorBuffer]
     blendFunc $= (SrcAlpha,OneMinusSrcAlpha)
 
-    renderLayer' 1 shadV layerCounts
+    renderLayer 1 shadV layerCounts
     bindFramebuffer Framebuffer $= fst (_fboColor pdata)
     clear [ColorBuffer]
     depthMask $= Disabled
 
-    renderLayer' 3 shadV layerCounts
-    renderLayer' 4 shadV layerCounts
-    renderLayer' 5 shadV layerCounts
+    renderLayer 3 shadV layerCounts
+    renderLayer 4 shadV layerCounts
+    renderLayer 5 shadV layerCounts
 
     depthMask $= Enabled
     bindFramebuffer Framebuffer $= fst (_fboFourth1 pdata)
@@ -143,7 +143,7 @@ doDrawing pdata w = do
 
     depthFunc $= Just Lequal
     --mapM_ (uncurry $ drawShaderLay 2) (vnums IM.! 2)
-    renderLayer' 2 shadV layerCounts
+    renderLayer 2 shadV layerCounts
     renderWindows pdata windowPoints
 
     depthFunc $= Just Always

src/Layers.hs

@@ -1,151 +0,0 @@
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE StrictData #-}
-{- |
-Concerns a custom layers datatype that has a fixed number of strict elements.
-Contains helpers that use the structure with indices.
- -}
-module Layers
-    ( Layers (..)
-    , Lay (..)
-    , lay0
-    , lay1
-    , lay2
-    , lay3
-    , lay4
-    , lay5
-    , layIndices
-    , getLay
-    , foldLayersr
-    , sequenceLayers
-    , sequenceLayers_
-    ) where
-import Control.Lens
-
-data Lay = L0 | L1 | L2 | L3 | L4 | L5
-
-getLay :: Int -> Layers a -> a
-{-# INLINE getLay #-}
-getLay 0 = _lay0
-getLay 1 = _lay1
-getLay 2 = _lay2
-getLay 3 = _lay3
-getLay 4 = _lay4
-getLay 5 = _lay5
-getLay _ = undefined
-
-layIndices :: Layers Int
-layIndices = Layers 0 1 2 3 4 5
-
-foldLayersr :: (Int -> a -> b -> b) -> b -> Layers a -> b
-foldLayersr f x Layers
-        { _lay0 = x0 
-        , _lay1 = x1
-        , _lay2 = x2 
-        , _lay3 = x3 
-        , _lay4 = x4 
-        , _lay5 = x5 
-        }
-        = f 0 x0 . f 1 x1 . f 2 x2 . f 3 x3 . f 4 x4 $ f 5 x5 x
-sequenceLayers_ :: (Int -> a -> IO b) -> Layers a -> IO ()
-sequenceLayers_ f lays = sequence_ $ f <$> layIndices <*> lays
---    f Layers
---        { _lay0 = x0 
---        , _lay1 = x1
---        , _lay2 = x2 
---        , _lay3 = x3 
---        , _lay4 = x4 
---        , _lay5 = x5 
---        }
---        = f 0 x0 >> f 1 x1 >> f 2 x2 >> f 3 x3 >> f 4 x4 >> f 5 x5 >> return ()
---foldLayersl' :: (Int -> b -> a -> b) -> b -> Layers a -> b
---foldLayersl' f x Layers
---        { _lay0 = x0 
---        , _lay1 = x1
---        , _lay2 = x2 
---        , _lay3 = x3 
---        , _lay4 = x4 
---        , _lay5 = x5 
---        }
---        = f 0 x0 . f 1 x1 . f 2 x2 . f 3 x3 . f 4 x4 $ f 5 x5 x
-
-sequenceLayers :: (Int -> a -> IO b) -> Layers a -> IO (Layers b)
-sequenceLayers f lays = sequence $ f <$> layIndices <*> lays
-
-data Layers a = Layers
-    { _lay0 :: a
-    , _lay1 :: a
-    , _lay2 :: a
-    , _lay3 :: a
-    , _lay4 :: a
-    , _lay5 :: a
-    }
--- boilerplate folows
-instance Functor Layers where
-    {-# INLINE fmap #-}
-    fmap f Layers
-        { _lay0 = the0
-        , _lay1 = the1
-        , _lay2 = the2
-        , _lay3 = the3
-        , _lay4 = the4
-        , _lay5 = the5
-        }
-        = Layers
-        { _lay0 = f the0
-        , _lay1 = f the1
-        , _lay2 = f the2
-        , _lay3 = f the3
-        , _lay4 = f the4
-        , _lay5 = f the5
-        }
-instance Applicative Layers where
-    {-# INLINE pure #-}
-    pure a = Layers a a a a a a
-    {-# INLINE (<*>) #-}
-    (<*>) Layers
-        { _lay0 = f0
-        , _lay1 = f1
-        , _lay2 = f2
-        , _lay3 = f3
-        , _lay4 = f4
-        , _lay5 = f5
-        }
-        Layers
-        { _lay0 = x0
-        , _lay1 = x1
-        , _lay2 = x2
-        , _lay3 = x3
-        , _lay4 = x4
-        , _lay5 = x5
-        }
-        = Layers
-        { _lay0 = f0 x0
-        , _lay1 = f1 x1
-        , _lay2 = f2 x2
-        , _lay3 = f3 x3
-        , _lay4 = f4 x4
-        , _lay5 = f5 x5
-        }
-instance Foldable Layers where
-    {-# INLINE foldr #-}
-    foldr f x Layers
-        { _lay0 = x0 
-        , _lay1 = x1
-        , _lay2 = x2 
-        , _lay3 = x3 
-        , _lay4 = x4 
-        , _lay5 = x5 
-        }
-        = f x0 . f x1 . f x2 . f x3 . f x4 $ f x5 x
-instance Traversable Layers where
-    {-# INLINE traverse #-}
-    traverse f Layers
-        { _lay0 = x0 
-        , _lay1 = x1
-        , _lay2 = x2 
-        , _lay3 = x3 
-        , _lay4 = x4 
-        , _lay5 = x5 
-        } = Layers <$> f x0 <*> f x1 <*> f x2 <*> f x3 <*> f x4 <*> f x5
-
-makeLenses ''Layers

src/Preload/Render.hs

@@ -63,14 +63,14 @@ preloadRender = do
         <- makeShader "lighting/lineShadow" [vert,geom,frag] [3] ELinesAdjacency
                 >>= addUniforms ["lightPos"]
 -- 2D draw shaders
-    bslist <- makeVShader "twoD/basic"   [vert,frag] [3,4]   ETriangles 
-    aslist <- makeVShader "twoD/arc"     [vert,frag] [3,4,3] ETriangles 
-    eslist <- makeVShader "twoD/ellipse" [vert,geom,frag] [3,4]   ETriangles 
-    bezierQuadShader <- makeVShader "twoD/bezierQuad" [vert,frag] [3,4,4]  ETriangleStrip
-    cslist <- makeVShader "twoD/character" [vert,frag] [3,4,2] ETriangles 
+    bslist <- makeShader "twoD/basic"   [vert,frag] [3,4]   ETriangles 
+    aslist <- makeShader "twoD/arc"     [vert,frag] [3,4,3] ETriangles 
+    eslist <- makeShader "twoD/ellipse" [vert,geom,frag] [3,4]   ETriangles 
+    bezierQuadShader <- makeShader "twoD/bezierQuad" [vert,frag] [3,4,4]  ETriangleStrip
+    cslist <- makeShader "twoD/character" [vert,frag] [3,4,2] ETriangles 
                   >>= vaddTextureNoFilter "data/texture/charMap.png"
                     -- this should really be a 2d texture array
-    basicTweakZShad <- makeVShader "twoD/basicTweakZ" [vert,frag] [4,4] ETriangles
+    basicTweakZShad <- makeShader "twoD/basicTweakZ" [vert,frag] [4,4] ETriangles
 -- fullscreen shaders
     fullscreenAlphaHalveShad <- makeShaderSized "fullscreen/alphaHalve" [vert,frag] [2] 4 ETriangleStrip
     pokeArray (shadVBOptr fullscreenAlphaHalveShad) $ concat cornerListNoCoord

src/Render.hs

@@ -22,7 +22,7 @@ import Foreign hiding (rotate)
 import Graphics.Rendering.OpenGL hiding (Line,translate,scale,imageHeight,Polygon,Color,T)
 --import Data.Foldable
 --import Data.Tuple.Extra
-import qualified Data.IntMap.Strict as IM
+--import qualified Data.IntMap.Strict as IM
 import qualified SDL
 import qualified Data.Vector.Unboxed.Mutable as UMV
 import qualified Data.Vector.Mutable as MV
@@ -146,7 +146,7 @@ drawTextureOnFramebuffer fs fbo to = do
     drawShader fs 4
 
 pokeBindFoldable
-    :: MV.MVector (PrimState IO) VShader
+    :: MV.MVector (PrimState IO) FullShader
     -> UMV.MVector (PrimState IO) Int
     -> [Verx]
     -> IO ()
@@ -154,11 +154,8 @@ pokeBindFoldable shadV counts m = do
     pokeVerxs shadV counts m
     bindShader shadV counts
 
-zeroCounts :: PicShads Int
-zeroCounts = PicShads 0 0 0 0 0 0
-
 pokeBindFoldableLayer
-    :: MV.MVector (PrimState IO) VShader
+    :: MV.MVector (PrimState IO) FullShader
     -> UMV.MVector (PrimState IO) Int
     -> Picture
     -> IO ()
@@ -167,7 +164,7 @@ pokeBindFoldableLayer shadV counts m = do
     bindShaderLayers shadV counts
 
 renderFoldable
-    :: MV.MVector (PrimState IO) VShader
+    :: MV.MVector (PrimState IO) FullShader
     -> [Verx]
     -> IO ()
 renderFoldable shadV struct = do
@@ -176,7 +173,7 @@ renderFoldable shadV struct = do
     MV.imapM_ (drawShaderLay' 0 counts) shadV
 
 renderFoldableTimed
-    :: MV.MVector (PrimState IO) VShader
+    :: MV.MVector (PrimState IO) FullShader
     -> [Verx]
     -> IO Word32
 renderFoldableTimed shadV struct = do
@@ -188,18 +185,14 @@ renderFoldableTimed shadV struct = do
     return $ pokeEndTicks - pokeStartTicks
 ------------------------------end renderFoldable
 
-renderLayer :: Int -> PicShads VShader -> IM.IntMap (PicShads Int) -> IO ()
-renderLayer layer shads counts = sequence_ $ drawShaderLay layer <$> shads <*> counts IM.! layer
-
-renderLayer' 
+renderLayer 
     :: Int 
-    -> MV.MVector (PrimState IO) VShader
+    -> MV.MVector (PrimState IO) FullShader
     -> UMV.MVector (PrimState IO) Int
     -> IO ()
-renderLayer' layer shads counts = do
+renderLayer layer shads counts = do
     let layerCounts = UMV.slice (layer * 6) 6 counts
     MV.imapM_ (drawShaderLay' layer layerCounts) shads
-    -- sequence_ $ drawShaderLay layer <$> shads <*> counts IM.! layer
 
 pokeTwoOff 
     :: Ptr Float 

src/Shader.hs

@@ -41,11 +41,11 @@ bindArrayBuffers numVs theVBO = do
         (fromIntegral $ floatSize * numVs * sum (_vboAttribSizes theVBO)) 
         (_vboPtr theVBO)
 
-bindShaderLayers :: MV.MVector (PrimState IO) VShader -> UMV.MVector (PrimState IO) Int -> IO ()
+bindShaderLayers :: MV.MVector (PrimState IO) FullShader -> UMV.MVector (PrimState IO) Int -> IO ()
 bindShaderLayers shads counts = MV.imapM_ f shads
   where
     f i shad = do
-        let theVBO = _vaoVBO $ _vshaderVAO shad
+        let theVBO = _vaoVBO $ _shaderVAO shad
             stride = sum $ _vboAttribSizes theVBO
         bindBuffer ArrayBuffer $= (Just . _vbo $ theVBO)
         mapM_ (g stride theVBO) [0..5]
@@ -60,12 +60,11 @@ bindShaderLayers shads counts = MV.imapM_ f shads
                 (_vboPtr theVBO `plusPtr` (floatSize * stride * numSubElements * lay))
             
 
- --lay counts = sequence_ $ bindArrayBuffersLayer lay <$> counts <*> (_vaoVBO . _vshaderVAO <$> shads)
 
-bindShader :: MV.MVector (PrimState IO) VShader -> UMV.MVector (PrimState IO) Int -> IO ()
+bindShader :: MV.MVector (PrimState IO) FullShader -> UMV.MVector (PrimState IO) Int -> IO ()
 bindShader shads counts = MV.imapM_ f shads
   where
-    f i shad = UMV.read counts i >>= flip bindArrayBuffers (_vaoVBO . _vshaderVAO $ shad)
+    f i shad = UMV.read counts i >>= flip bindArrayBuffers (_vaoVBO . _shaderVAO $ shad)
 
 
 bindShaderBuffers :: [FullShader] -> [Int] -> IO ()
@@ -73,28 +72,28 @@ bindShaderBuffers = zipWithM_ f
   where 
     f fs i = bindArrayBuffers i $ _vaoVBO $ _shaderVAO fs
 
-drawShaderLay :: Int -> VShader -> Int -> IO ()
+drawShaderLay :: Int -> FullShader -> Int -> IO ()
 {-# INLINE drawShaderLay #-}
 drawShaderLay l fs i = do 
-    currentProgram $= Just (_vshaderProgram fs)
-    bindVertexArrayObject $= Just (_vao $ _vshaderVAO fs)
-    case _vshaderTexture fs of 
+    currentProgram $= Just (_shaderProgram fs)
+    bindVertexArrayObject $= Just (_vao $ _shaderVAO fs)
+    case _shaderTexture fs of 
         Just ShaderTexture{_textureObject = txo}
             -> textureBinding Texture2D $= Just txo
         _   -> return ()
-    glDrawArrays (marshalEPrimitiveMode $ _vshaderDrawPrimitive fs) (fromIntegral $ l*numSubElements) (fromIntegral i)
+    glDrawArrays (marshalEPrimitiveMode $ _shaderDrawPrimitive fs) (fromIntegral $ l*numSubElements) (fromIntegral i)
 
-drawShaderLay' :: Int -> UMV.MVector (PrimState IO) Int -> Int -> VShader -> IO ()
+drawShaderLay' :: Int -> UMV.MVector (PrimState IO) Int -> Int -> FullShader -> IO ()
 {-# INLINE drawShaderLay' #-}
 drawShaderLay' l countsVector shadIn fs = do 
     i <- UMV.read countsVector shadIn
-    currentProgram $= Just (_vshaderProgram fs)
-    bindVertexArrayObject $= Just (_vao $ _vshaderVAO fs)
-    case _vshaderTexture fs of 
+    currentProgram $= Just (_shaderProgram fs)
+    bindVertexArrayObject $= Just (_vao $ _shaderVAO fs)
+    case _shaderTexture fs of 
         Just ShaderTexture{_textureObject = txo}
             -> textureBinding Texture2D $= Just txo
         _   -> return ()
-    glDrawArrays (marshalEPrimitiveMode $ _vshaderDrawPrimitive fs) (fromIntegral $ l*numSubElements) (fromIntegral i)
+    glDrawArrays (marshalEPrimitiveMode $ _shaderDrawPrimitive fs) (fromIntegral $ l*numSubElements) (fromIntegral i)
 
 drawShader :: FullShader -> Int -> IO ()
 {-# INLINE drawShader #-}

src/Shader/AuxAddition.hs

@@ -35,7 +35,7 @@ addTexture texturePath shad = do
     generateMipmap' Texture2D
     return $ shad & shaderTexture ?~ ShaderTexture {_textureObject = textureOb}
 
-vaddTextureNoFilter :: String -> VShader -> IO VShader
+vaddTextureNoFilter :: String -> FullShader -> IO FullShader
 vaddTextureNoFilter texturePath shad = do
     Right cmap <- readImage texturePath
     let tex = convertRGBA8 cmap
@@ -48,7 +48,7 @@ vaddTextureNoFilter texturePath shad = do
     glTexStorage2D GL_TEXTURE_2D 1 GL_RGBA8 wtex htex
     withArray texData $ \ptr -> do
         glTexSubImage2D GL_TEXTURE_2D 0 0 0 wtex htex GL_RGBA GL_UNSIGNED_BYTE ptr
-    return $ shad & vshaderTexture ?~ ShaderTexture {_textureObject = textureOb}
+    return $ shad & shaderTexture ?~ ShaderTexture {_textureObject = textureOb}
 
 addTextureNoFilter :: String -> FullShader -> IO FullShader
 addTextureNoFilter texturePath shad = do

src/Shader/Compile.hs

@@ -1,6 +1,6 @@
 module Shader.Compile
     ( makeShader
-    , makeVShader
+    --, makeVShader
     , makeShaderSized
     , makeShaderUsingShaderVAO
     , makeSourcedShader
@@ -16,28 +16,28 @@ import Control.Monad
 --import Control.Lens
 import Graphics.Rendering.OpenGL hiding (Point,translate,scale,imageHeight)
 
-{- | 
-Compiles a vertex shader found within the shader directory.
-The shader is made up of files begining with the inputted string with extensions .vert, .geom etc.
--}
-makeVShader 
-    :: String       -- ^ First part of the name of the shader
-    -> [ShaderType] -- ^ Filetype extensions
-    -> [Int]   -- ^ The input vertex sizes
-    -> EPrimitiveMode
-    -> IO VShader
-makeVShader s shaderlist sizes pm = do
-    prog <- makeSourcedShader s shaderlist
-    vaob <- setupVAO sizes
-    return $ VShader 
-        { _vshaderProgram = prog
-        , _vshaderVAO = vaob
-        , _vshaderTexture = Nothing
-        , _vshaderCustomUnis = []
-        , _vshaderDrawPrimitive = pm
-        }
+--{- | 
+--Compiles a vertex shader found within the shader directory.
+--The shader is made up of files begining with the inputted string with extensions .vert, .geom etc.
+---}
+--makeVShader 
+--    :: String       -- ^ First part of the name of the shader
+--    -> [ShaderType] -- ^ Filetype extensions
+--    -> [Int]   -- ^ The input vertex sizes
+--    -> EPrimitiveMode
+--    -> IO VShader
+--makeVShader s shaderlist sizes pm = do
+--    prog <- makeSourcedShader s shaderlist
+--    vaob <- setupVAO sizes
+--    return $ VShader 
+--        { _vshaderProgram = prog
+--        , _vshaderVAO = vaob
+--        , _vshaderTexture = Nothing
+--        , _vshaderCustomUnis = []
+--        , _vshaderDrawPrimitive = pm
+--        }
 
--- | Takes the VAO and poke strategy from another shader
+-- | Takes the VAO from another shader
 makeShaderUsingShaderVAO
     :: String       -- ^ First part of the name of the shader
     -> [ShaderType] -- ^ Filetype extensions
@@ -60,7 +60,8 @@ makeShader
     :: String       -- ^ First part of the name of the shader
     -> [ShaderType] -- ^ Filetype extensions
     -> [Int]   -- ^ The input vertex sizes
-    -> EPrimitiveMode -> IO FullShader
+    -> EPrimitiveMode 
+    -> IO FullShader
 makeShader s shaderlist sizes pm = do
     prog <- makeSourcedShader s shaderlist
     vaob <- setupVAO sizes

src/Shader/Data.hs

@@ -1,154 +1,55 @@
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE StrictData #-}
-{- |
-Datatypes used to setup and pass data to shaders.
--}
+{- | Datatypes used to setup and pass data to shaders.  -}
 module Shader.Data
     ( VAO (..)
     , VBO (..)
     , FullShader (..)
-    , VShader (..)
     , ShaderTexture (..)
     , EPrimitiveMode (..)
-    , PicShads (..)
 -- | Lens functions
     , vao
     , vaoVBO
-
     , shaderProgram
     , shaderVAO
     , shaderDrawPrimitive
     , shaderTexture
     , shaderCustomUnis
-
-    , vshaderProgram
-    , vshaderVAO
-    , vshaderDrawPrimitive
-    , vshaderTexture
-    , vshaderCustomUnis
-
-    , psPoly 
-    , psPolyz
-    , psBez  
-    , psText 
-    , psArc  
-    , psEll  
-    
+    , vbo
+    , vboPtr
+    , vboAttribSizes
+    , vboStride
+-- | Synonyms
     , vert
     , geom
     , frag
-
--- TODO make lenses for VBO object
---    , textureObject 
     ) where
---import Geometry.Data
-
 import Graphics.Rendering.OpenGL
 import Foreign
 import Control.Lens
---import Graphics.GL.Types
+{- | Datatype containing the necessary information for a single shader.  -}
+data FullShader = FullShader
+    { _shaderProgram        :: Program
+    , _shaderVAO            :: VAO
+    , _shaderDrawPrimitive  :: EPrimitiveMode
+    , _shaderTexture        :: Maybe ShaderTexture
+    , _shaderCustomUnis     :: [UniformLocation]
+    }
 {- | Vertex array object: contains the reference to the object,
 and its buffer targets.  -}
 data VAO = VAO
-    { _vao :: VertexArrayObject
-    , _vaoVBO :: VBO
+    { _vao      :: VertexArrayObject
+    , _vaoVBO   :: VBO
     }
 {- | Vertex buffer object: contains the reference to the object,
 a pointer to a location with space that can be written to the buffer,
 and a list of attribute pointer sizes.
 Vertex attributes are interleaved within the vbo. -}
 data VBO = VBO
-    { _vbo      :: BufferObject
-    , _vboPtr :: Ptr Float
+    { _vbo            :: BufferObject
+    , _vboPtr         :: Ptr Float
     , _vboAttribSizes :: [Int]  -- ^ It is not clear to me if this is necessary to store or not
-    , _vboStride :: Int
-    }
-data VShader = VShader
-    { _vshaderProgram :: Program
-    , _vshaderVAO :: VAO
-    , _vshaderDrawPrimitive :: EPrimitiveMode
-    , _vshaderTexture :: Maybe ShaderTexture
-    , _vshaderCustomUnis :: [UniformLocation]
-    }
-data PicShads a = PicShads
-    { _psPoly   :: a
-    , _psPolyz  :: a
-    , _psBez    :: a
-    , _psText   :: a
-    , _psArc    :: a
-    , _psEll    :: a
-    }
--- boilerplate folows
-instance Functor PicShads where
-    fmap f PicShads
-        { _psPoly  = thePoly 
-        , _psPolyz = thePolyz
-        , _psBez   = theBez  
-        , _psText  = theText 
-        , _psArc   = theArc  
-        , _psEll   = theEll  
-        }
-        = PicShads
-        { _psPoly  = f thePoly 
-        , _psPolyz = f thePolyz
-        , _psBez   = f theBez  
-        , _psText  = f theText 
-        , _psArc   = f theArc  
-        , _psEll   = f theEll  
-        }
-instance Applicative PicShads where
-    pure a = PicShads a a a a a a
-    (<*>) PicShads
-        { _psPoly  = fPoly 
-        , _psPolyz = fPolyz
-        , _psBez   = fBez  
-        , _psText  = fText 
-        , _psArc   = fArc  
-        , _psEll   = fEll  
-        }
-        PicShads
-        { _psPoly  = thePoly 
-        , _psPolyz = thePolyz
-        , _psBez   = theBez  
-        , _psText  = theText 
-        , _psArc   = theArc  
-        , _psEll   = theEll  
-        }
-        = PicShads
-        { _psPoly  = fPoly  thePoly 
-        , _psPolyz = fPolyz thePolyz
-        , _psBez   = fBez   theBez  
-        , _psText  = fText  theText 
-        , _psArc   = fArc   theArc  
-        , _psEll   = fEll   theEll  
-        }
-instance Foldable PicShads where
-    foldr f x PicShads
-        { _psPoly  = thePoly 
-        , _psPolyz = thePolyz
-        , _psBez   = theBez  
-        , _psText  = theText 
-        , _psArc   = theArc  
-        , _psEll   = theEll  
-        }
-        = f thePoly . f thePolyz . f theBez . f theText . f theArc $ f theEll x
-instance Traversable PicShads where
-    {-# INLINE traverse #-}
-    traverse f PicShads
-        { _psPoly   = x0 
-        , _psPolyz  = x1
-        , _psBez    = x2 
-        , _psText   = x3 
-        , _psArc    = x4 
-        , _psEll    = x5 
-        } = PicShads <$> f x0 <*> f x1 <*> f x2 <*> f x3 <*> f x4 <*> f x5
-{- | Datatype containing the necessary information for a single shader.  -}
-data FullShader = FullShader
-    { _shaderProgram :: Program
-    , _shaderVAO :: VAO
-    , _shaderDrawPrimitive :: EPrimitiveMode
-    , _shaderTexture :: Maybe ShaderTexture
-    , _shaderCustomUnis :: [UniformLocation]
+    , _vboStride      :: Int
     }
 {- | Datatype containing the reference to a texture object.  -}
 newtype ShaderTexture = ShaderTexture
@@ -166,14 +67,11 @@ data EPrimitiveMode
     | EQuadStrip
     | EPolygon
     | EPatches
-
 -- | Short synonyms for shader types
 vert, geom, frag :: ShaderType
 vert = VertexShader
 geom = GeometryShader
 frag = FragmentShader
-
 makeLenses ''VAO
+makeLenses ''VBO
 makeLenses ''FullShader
-makeLenses ''VShader
-makeLenses ''PicShads

src/Shader/Poke.hs

@@ -1,22 +1,17 @@
 --{-# LANGUAGE TupleSections #-}
 {-# LANGUAGE BangPatterns #-}
 module Shader.Poke
-    ( pokeArrayOff
+    ( pokeVerxs
+    , pokeLayVerxs
+    , pokeArrayOff
     , pokePoint3s
     , pokePoint33s
-    , pokeVerxs
-    , pokeLayVerxs
     , poke224s
-    , picShadToUMV
-    , picShadToMV
-    , vToPicShad
-    , vToPicShadMV
     ) where
 import Shader.Data
 import Shader.Parameters
 import Picture.Data
 import Geometry.Data
---import Layers
 
 --import qualified Streaming.Prelude as SP
 --import Data.Maybe
@@ -32,16 +27,16 @@ import qualified Data.Vector.Fusion.Stream.Monadic as VS
 import Control.Monad.Primitive
 
 pokeVerxs 
-    :: MV.MVector (PrimState IO) VShader
+    :: MV.MVector (PrimState IO) FullShader
     -> UMV.MVector (PrimState IO) Int 
     -> [Verx] 
     -> IO ()
 pokeVerxs vbos count vxs = VS.mapM_ (pokeVerx vbos count) $ VS.fromList vxs
 
-pokeVerx :: MV.MVector (PrimState IO) VShader -> UMV.MVector (PrimState IO) Int -> Verx -> IO ()
+pokeVerx :: MV.MVector (PrimState IO) FullShader -> UMV.MVector (PrimState IO) Int -> Verx -> IO ()
 pokeVerx vbos offsets Verx{_vxPos=thePos,_vxCol=theCol,_vxExt=ext,_vxShadNum=theShadNum} = do
     typeOff <- UMV.unsafeRead offsets sn
-    basePtr <- fmap (_vboPtr . _vaoVBO . _vshaderVAO) $ MV.read vbos sn
+    basePtr <- _vboPtr . _vaoVBO . _shaderVAO <$> MV.read vbos sn
     let thePtr = plusPtr basePtr (typeOff * pokeStride sn * floatSize)
     poke34 thePtr thePos theCol
     pokeArrayOff thePtr 7 ext
@@ -49,37 +44,37 @@ pokeVerx vbos offsets Verx{_vxPos=thePos,_vxCol=theCol,_vxExt=ext,_vxShadNum=the
   where
     sn = _unShadNum theShadNum
 
-vToPicShad :: UMV.MVector (PrimState IO) Int -> IO (PicShads Int)
-{-# INLINE vToPicShad #-}
-vToPicShad mv = mapM (UMV.unsafeRead mv) $ PicShads 0 1 2 3 4 5
-
-vToPicShadMV :: MV.MVector (PrimState IO) Int -> IO (PicShads Int)
-{-# INLINE vToPicShadMV #-}
-vToPicShadMV mv = mapM (MV.unsafeRead mv) $ PicShads 0 1 2 3 4 5
-
-picShadToUMV :: PicShads Int -> IO (UMV.MVector (PrimState IO) Int)
-{-# INLINE picShadToUMV #-}
-picShadToUMV (PicShads a b c d e f) = do
-    theVec <- UMV.new 6
-    UMV.write theVec 0 a
-    UMV.write theVec 1 b
-    UMV.write theVec 2 c
-    UMV.write theVec 3 d
-    UMV.write theVec 4 e
-    UMV.write theVec 5 f
-    return theVec
-
-picShadToMV :: PicShads a -> IO (MV.MVector (PrimState IO) a)
-{-# INLINE picShadToMV #-}
-picShadToMV (PicShads a b c d e f) = do
-    theVec <- MV.new 6
-    MV.write theVec 0 a
-    MV.write theVec 1 b
-    MV.write theVec 2 c
-    MV.write theVec 3 d
-    MV.write theVec 4 e
-    MV.write theVec 5 f
-    return theVec
+--vToPicShad :: UMV.MVector (PrimState IO) Int -> IO (PicShads Int)
+--{-# INLINE vToPicShad #-}
+--vToPicShad mv = mapM (UMV.unsafeRead mv) $ PicShads 0 1 2 3 4 5
+--
+--vToPicShadMV :: MV.MVector (PrimState IO) Int -> IO (PicShads Int)
+--{-# INLINE vToPicShadMV #-}
+--vToPicShadMV mv = mapM (MV.unsafeRead mv) $ PicShads 0 1 2 3 4 5
+--
+--picShadToUMV :: PicShads Int -> IO (UMV.MVector (PrimState IO) Int)
+--{-# INLINE picShadToUMV #-}
+--picShadToUMV (PicShads a b c d e f) = do
+--    theVec <- UMV.new 6
+--    UMV.write theVec 0 a
+--    UMV.write theVec 1 b
+--    UMV.write theVec 2 c
+--    UMV.write theVec 3 d
+--    UMV.write theVec 4 e
+--    UMV.write theVec 5 f
+--    return theVec
+--
+--picShadToMV :: PicShads a -> IO (MV.MVector (PrimState IO) a)
+--{-# INLINE picShadToMV #-}
+--picShadToMV (PicShads a b c d e f) = do
+--    theVec <- MV.new 6
+--    MV.write theVec 0 a
+--    MV.write theVec 1 b
+--    MV.write theVec 2 c
+--    MV.write theVec 3 d
+--    MV.write theVec 4 e
+--    MV.write theVec 5 f
+--    return theVec
 
 
 poke34 :: Ptr Float -> Point3 -> Point4 -> IO ()
@@ -125,17 +120,17 @@ pokePoint3s ptr vals0 = go vals0 0
         off i = n*3 + i
 
 pokeLayVerxs 
-    :: MV.MVector (PrimState IO) VShader 
+    :: MV.MVector (PrimState IO) FullShader 
     -> UMV.MVector (PrimState IO) Int
     -> [Verx] 
     -> IO ()
 pokeLayVerxs vbos counts vxs = VS.mapM_ (pokeLayVerx vbos counts) $ VS.fromList vxs
 
-pokeLayVerx :: MV.MVector (PrimState IO) VShader -> UMV.MVector (PrimState IO) Int -> Verx -> IO ()
+pokeLayVerx :: MV.MVector (PrimState IO) FullShader -> UMV.MVector (PrimState IO) Int -> Verx -> IO ()
 --{-# INLINE pokeLayVerx #-}
 pokeLayVerx vbos counts vx = do
     theOff <- UMV.unsafeRead counts vecPos
-    basePtr <- fmap (_vboPtr . _vaoVBO . _vshaderVAO) $ MV.unsafeRead vbos sn
+    basePtr <- _vboPtr . _vaoVBO . _shaderVAO <$> MV.unsafeRead vbos sn
     let thePtr = plusPtr basePtr ((theOff + layOff) * theStride * floatSize)
     poke34 thePtr thePos theCol
     pokeArrayOff thePtr 7 (_vxExt vx)
@@ -146,7 +141,6 @@ pokeLayVerx vbos counts vx = do
     theLayer = _vxLayer vx
     thePos = _vxPos vx
     theCol = _vxCol vx
-    --basePtr = _vboPtr $ vboFromType vbos sn
     layOff = theLayer * numSubElements
     theStride = pokeStride sn