Refactor shaders, commit before major deletion of old code

app/Main.hs

@@ -60,7 +60,7 @@ main = do
                                             (lightsForGloom' w)
                                             (worldPictures w)
                       blendFunc $= (SrcAlpha,OneMinusSrcAlpha)
-                      renderTree (_renderData preData) (_cameraRot w) (_cameraZoom w) (_cameraPos w)
+                      renderTree' (_renderData preData) (_cameraRot w) (_cameraZoom w) (_cameraPos w)
                                             (_windowX w,_windowY w) 
                                             --(picToLTree (Just 1) $ fixedCoordPictures w)
                                             (picToLTree Nothing $ fixedCoordPictures w)

src/Picture/Data.hs

@@ -40,7 +40,11 @@ data FullShader = FullShader
     , _shaderVAO :: VAO
     , _shaderPokeStrategy :: RenderType -> [[[Float]]]-- -> F.FoldM IO RenderType Int
     , _shaderDrawPrimitive :: PrimitiveMode
+    , _shaderTexture :: Maybe ShaderTexture
     }
+data ShaderTexture = ShaderTexture
+    { _textureObject :: TextureObject }
+
 makeLenses ''VAO
 makeLenses ''FullShader
 
@@ -51,6 +55,10 @@ drawShaders 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)
                             
 

src/Picture/Preload.hs

@@ -55,7 +55,38 @@ makeShader s shaderlist alocs pm renStrat = do
                         , _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}
+                        }
+
 
 mkS :: IO FullShader
 mkS = do 
@@ -150,7 +181,9 @@ preloadRender = do
 
     bslist <- makeShader "basic"        [vert,frag] [(0,3),(1,4)] Triangles pokeTriStrat
     lslist <- makeShader "basic"        [vert,frag] [(0,3),(1,4)] Lines pokeLineStrat
-    cslist <- makeShader "character"    [vert,geom,frag] [(0,3),(1,4),(2,3)] Points pokeCharStrat
+    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
 

src/Picture/Render.hs

@@ -403,6 +403,8 @@ renderPicture' pdata rot zoom (tranx,trany) (winx,winy) wallPoints lightPoints p
     wmata <- (newMatrix RowMajor $ concatMap vToL $ vToL wmat) :: IO (GLmatrix GLfloat)
 
 -- set common uniforms
+    setShaderUniforms rot zoom (tranx,trany) (winx,winy) (_listShaders pdata)
+
     forM_ [_basicShader      pdata
           ,_textShader       pdata
           ,_circShader       pdata
@@ -454,6 +456,21 @@ renderPicture' pdata rot zoom (tranx,trany) (winx,winy) wallPoints lightPoints p
 -- set drawing for on top
     blendFuncSeparate    $= ((SrcAlphaSaturate, OneMinusSrcAlpha), (Zero,One))
     clear [DepthBuffer]
+-- draw background
+    bindArrayBuffers 1 $ _vaoBufferTargets $ _backVAO pdata
+    depthFunc $= Just Less
+
+    currentProgram $= Just (fst $ _backShader pdata)
+    bindVertexArrayObject $= Just (_vao $ _backVAO pdata)
+    let backPtr = (\(_,x,_) -> x) $ head $ _vaoBufferTargets $ _backVAO pdata
+        backPtr2 = (\(_,x,_) -> x) $ (_vaoBufferTargets $ _backVAO pdata) !! 1
+    pokeFourOff backPtr 0 (tranx,trany,rot,zoom)
+    pokeTwoOff backPtr2 0  (winx,winy)
+    textureBinding Texture2D $= Just (_textures pdata !! 1)
+    drawArrays Points (fromIntegral 0) (fromIntegral 1)
+
+    depthFunc $= Just Lequal
+
 -- draw layer 0
     ticks2 <- renderTree' pdata rot zoom (tranx,trany) (winx,winy) $ picToLTree (Just 0) pic
                                                         --((picToAlt 0 pic) :: [RenderType])
@@ -472,6 +489,13 @@ renderPicture' pdata rot zoom (tranx,trany) (winx,winy) wallPoints lightPoints p
                                  ,0,0,0,1
                                  ]
              ) :: IO (GLmatrix GLfloat)
+    forM_ (_listShaders pdata) $ \shad -> do
+        currentProgram $= Just (_shaderProgram shad)
+        uniform (_shaderUniforms shad !! 0)  $= Vector2 (2::Float) 2
+        uniform (_shaderUniforms shad !! 1)  $= (1::Float)
+        uniform (_shaderUniforms shad !! 2)  $= (0::Float)
+        uniform (_shaderUniforms shad !! 3)  $= Vector2 (0::Float) 0
+        uniform (_shaderUniforms shad !! 4)  $= idmat
     forM_ [_basicShader      pdata
           ,_textShader       pdata
           ,_circShader       pdata
@@ -500,7 +524,6 @@ renderTree' pdata rot zoom (tranx,trany) (winx,winy) tree = do
     pokeStartTicks <- SDL.ticks
 
     let slist = _listShaders pdata
-    setShaderUniforms rot zoom (tranx,trany) (winx,winy) slist
 
     is <- F.foldM (pokeShaders slist) tree
 
@@ -534,7 +557,6 @@ renderTree pdata rot zoom (tranx,trany) (winx,winy) tree = do
 -- the idea of doing as much of this at once, rather than interweaving with draw
 -- calls, is to prevent opengl from waiting for a draw call to finish
 -- before it performs another state change
-    bindArrayBuffers 1 $ _vaoBufferTargets $ _backVAO pdata
     bindArrayBuffers nTriVs $ _vaoBufferTargets $ _triVAO pdata
     bindArrayBuffers nCircVs $ _vaoBufferTargets $ _circVAO pdata
     bindArrayBuffers nArcVs $ _vaoBufferTargets $ _arcVAO pdata
@@ -542,18 +564,6 @@ renderTree pdata rot zoom (tranx,trany) (winx,winy) tree = do
     bindArrayBuffers nTextVs $ _vaoBufferTargets $ _textVAO pdata
     bindArrayBuffers nEllVs $ _vaoBufferTargets $ _ellipseVAO pdata
 
-    depthFunc $= Just Less
-
-    currentProgram $= Just (fst $ _backShader pdata)
-    bindVertexArrayObject $= Just (_vao $ _backVAO pdata)
-    let backPtr = (\(_,x,_) -> x) $ head $ _vaoBufferTargets $ _backVAO pdata
-        backPtr2 = (\(_,x,_) -> x) $ (_vaoBufferTargets $ _backVAO pdata) !! 1
-    pokeFourOff backPtr 0 (tranx,trany,rot,zoom)
-    pokeTwoOff backPtr2 0  (winx,winy)
-    textureBinding Texture2D $= Just (_textures pdata !! 1)
-    drawArrays Points (fromIntegral 0) (fromIntegral 1)
-
-    depthFunc $= Just Lequal
 
 -- draw triangles
     currentProgram $= Just (fst $ _basicShader pdata)

src/Shaders.hs

@@ -1,8 +1,8 @@
 {-# LANGUAGE QuasiQuotes #-}
 module Shaders 
-    (makeTextureShader
+    (--makeTextureShader
-    ,makeBasicShader
+--    ,makeBasicShader
-    ,makeFadeShader
+    makeFadeShader
     ,makeCircleShader
     ,makeArcShader
     ,makeBackgroundShader