Partial refactor of shader loading and drawing

src/Picture/Data.hs

@@ -24,7 +24,7 @@ import Data.Traversable
 data RenderType
     = RenderPoly [(Point3,Point4)]
     | RenderText [(Point3,Point4,Point3)]
-    | RenderCirc (Point3,Point4,Float)
+--    | RenderCirc (Point3,Point4,Float)
     | RenderArc  (Point3,Point4,Point4)
     | RenderLine [(Point3,Point4)]
     | RenderEllipse [(Point3,Point4)]
@@ -44,6 +44,16 @@ data FullShader = FullShader
 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))
+                        drawArrays (_shaderDrawPrimitive fs) 0 (fromIntegral i)
+                            
+
 bindShaderBuffers :: [FullShader] -> [Int] -> IO ()
 bindShaderBuffers fss is =
     zipWithM_ f fss is

src/Picture/Preload.hs

@@ -29,6 +29,7 @@ data RenderData = RenderData
     , _lightmapCircleShader :: (Program, [UniformLocation])
     , _backShader       :: (Program, [UniformLocation])
     , _wallShadowShader :: (Program, [UniformLocation])
+    , _listShaders :: [FullShader]
     , _triVAO :: VAO
     , _lineVAO :: VAO
     , _textVAO :: VAO
@@ -45,6 +46,43 @@ 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
+                        }
+
+mkS :: IO FullShader
+mkS = do 
+    (prog,unis)  <- makeSourcedShader "basic"      [VertexShader,FragmentShader]
+    trivao        <- setupVAO [(0,3),(1,4)]
+    return $ FullShader { _shaderProgram = prog
+                        , _shaderUniforms = unis
+                        , _shaderVAO = trivao
+                        , _shaderPokeStrategy = pokeTriStrat
+                        , _shaderDrawPrimitive = Triangles
+                        }
+
+pokeTriStrat (RenderPoly vs) = fmap (\((x,y,z),(r,g,b,a)) -> [[x,y,z],[r,g,b,a]]) vs
+pokeTriStrat _ = []
+
+pokeCharStrat (RenderText vs) = fmap (\(a,b,c) -> flat3 (flat3 a, flat4 b, flat3 c)) vs
+pokeCharStrat _ = []
+
+pokeArcStrat (RenderArc (a,b,c)) = [flat3 (flat3 a, flat4 b, flat4 c)]
+pokeArcStrat _ = []
+
+pokeLineStrat (RenderLine vs) = fmap (\((x,y,z),(r,g,b,a)) -> [[x,y,z],[r,g,b,a]]) vs
+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
@@ -92,6 +130,10 @@ loadTextures = do
 bufferOffset :: Integral a => a -> Ptr b
 bufferOffset = plusPtr nullPtr . fromIntegral
 
+vert = VertexShader
+geom = GeometryShader
+frag = FragmentShader
+
 preloadRender :: IO RenderData
 preloadRender = do
 -- compile shader programs
@@ -106,6 +148,12 @@ preloadRender = do
 
     wssLightPosUniLoc   <- GL.uniformLocation (fst wss) "lightPos"
 
+    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
+    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
     dummyptr <- mallocArray numDrawableElements
@@ -163,6 +211,7 @@ preloadRender = do
         , _circShader = cs
         , _ellipseShader = es
         , _arcShader = as
+        , _listShaders = [bslist,lslist,cslist,aslist,eslist]
         , _lightmapCircleShader = fcs
         , _backShader = bgs
         , _wallShadowShader = wss

src/Picture/Render.hs

@@ -64,7 +64,7 @@ overPos f (RenderPoly vs) = RenderPoly $ map (first $ f) vs
 overPos f (RenderLine vs) = RenderLine $ map (first $ f) vs
 overPos f (RenderText vs) = RenderText $ map (\(a,b,c) -> (f a,b,c)) vs
 overPos f (RenderEllipse vs) = RenderEllipse $ map (first f) vs
-overPos f (RenderCirc (a,b,c)) = RenderCirc (f a,b,c)
+--overPos f (RenderCirc (a,b,c)) = RenderCirc (f a,b,c)
 overPos f (RenderArc (a,b,c))  = RenderArc (f a,b,c)
 
 overRot :: Float -> RenderType -> RenderType
@@ -78,7 +78,7 @@ overCol f (RenderPoly vs)      = RenderPoly $ map (second $ f) vs
 overCol f (RenderLine vs)      = RenderLine $ map (second $ f) vs
 overCol f (RenderEllipse vs)   = RenderEllipse $ map (second $ f) vs
 overCol f (RenderText vs)      = RenderText $ map (\(a,b,c) -> (a,f b,c)) vs
-overCol f (RenderCirc (a,b,c)) = RenderCirc (a,f b,c)
+--overCol f (RenderCirc (a,b,c)) = RenderCirc (a,f b,c)
 overCol f (RenderArc (a,b,c))   = RenderArc (a,f b,c)
 
 overSca :: (Point2 -> Point2) -> RenderType -> RenderType
@@ -284,13 +284,13 @@ pokeLineVert pa pb n (p,c)
 
 pokeCirc :: ThreePtrs -> Int -> RenderType -> IO Int
 {-# INLINE pokeCirc #-}
-pokeCirc (pa,pb,pc) n (RenderCirc (p,c,s)) 
+--pokeCirc (pa,pb,pc) n (RenderCirc (p,c,s)) 
-    | n > 20000 * 2 = return n
+--    | n > 20000 * 2 = return n
-    | otherwise = do
+--    | otherwise = do
-        pokeThreeOff pa n p
+--        pokeThreeOff pa n p
-        pokeFourOff  pb n c
+--        pokeFourOff  pb n c
-        pokeElemOff  pc n s
+--        pokeElemOff  pc n s
-        return (n+1)
+--        return (n+1)
 pokeCirc _          n _               = return n
 
 pokeText :: (Ptr Float, Ptr Float, Ptr Float) -> Int -> RenderType -> IO Int
@@ -333,7 +333,6 @@ rotate3 :: Float -> Point3 -> Point3
 rotate3 a (x,y,z) = (x',y',z)
     where (x',y') = rotateV a (x,y)
 
-
 twoPtrsVAO :: VAO -> (Ptr Float, Ptr Float)
 {-# INLINE twoPtrsVAO #-}
 twoPtrsVAO vao = case (\(_,ps,_) -> ps) $ unzip3 $ _vaoBufferTargets vao of
@@ -343,7 +342,36 @@ 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 rot zoom (tranx,trany) (winx,winy) fss = do
+    let scalMat = Linear.Matrix.transpose $
+            V4 (V4 (2*zoom/winx) 0             0 (0::GLfloat))
+                (V4 0             (2*zoom/winy) 0 0)
+                (V4 0             0             1 0)
+                (V4 0             0             0 1)
+    let rotMat = Linear.Matrix.transpose $
+            V4 (V4 (cos rot) (sin (-rot)) 0 0)
+                (V4 (sin rot) (cos rot)    0 0)
+                (V4 0             0        1 0)
+                (V4 0             0        0 1)
+    let tranMat = Linear.Matrix.transpose $
+            V4 (V4 1        0        0 0)
+                (V4 0        1        0 0)
+                (V4 0        0        1 0)
+                (V4 (-tranx) (-trany) 0 1)
+    let wmat = scalMat !*! rotMat !*! tranMat
+        vToL (V4 a b c d) = [a,b,c,d]
+    wmata <- (newMatrix RowMajor $ concatMap vToL $ vToL wmat) :: IO (GLmatrix GLfloat)
 
+-- set common uniforms
+    forM_ fss $ \shad -> do
+        currentProgram $= Just (_shaderProgram shad)
+        uniform (_shaderUniforms shad !! 0) $= Vector2 winx winy
+        uniform (_shaderUniforms shad !! 1) $= zoom
+        uniform (_shaderUniforms shad !! 2) $= rot
+        uniform (_shaderUniforms shad !! 3) $= Vector2 tranx trany
+        uniform (_shaderUniforms shad !! 4) $= wmata
+    
 renderPicture' :: RenderData -> Float -> Float -> (Float,Float) -> (Float,Float) ->
                     [(Point2,Point2,Point2,Point2)] -> [Point4] -> Picture -> IO (Word32,Word32)
 renderPicture' pdata rot zoom (tranx,trany) (winx,winy) wallPoints lightPoints pic = do
@@ -427,15 +455,15 @@ renderPicture' pdata rot zoom (tranx,trany) (winx,winy) wallPoints lightPoints p
     blendFuncSeparate    $= ((SrcAlphaSaturate, OneMinusSrcAlpha), (Zero,One))
     clear [DepthBuffer]
 -- draw layer 0
-    ticks2 <- renderTree pdata rot zoom (tranx,trany) (winx,winy) $ picToLTree (Just 0) pic
+    ticks2 <- renderTree' pdata rot zoom (tranx,trany) (winx,winy) $ picToLTree (Just 0) pic
                                                         --((picToAlt 0 pic) :: [RenderType])
 -- reset blend so that light map doesn't apply
     blendFunc $= (SrcAlpha,OneMinusSrcAlpha)
-    ticks3 <- renderTree pdata rot zoom (tranx,trany) (winx,winy) $ picToLTree (Just 1) pic
+    ticks3 <- renderTree' pdata rot zoom (tranx,trany) (winx,winy) $ picToLTree (Just 1) pic
 -- set drawing for on top
     aticks <- SDL.ticks
     blendFuncSeparate    $= ((SrcAlphaSaturate, OneMinusSrcAlpha), (Zero,One))
-    ticks4 <- renderTree pdata rot zoom (tranx,trany) (winx,winy) $ picToLTree (Just 2) pic
+    ticks4 <- renderTree' pdata rot zoom (tranx,trany) (winx,winy) $ picToLTree (Just 2) pic
     bticks <- SDL.ticks
 -- reset uniforms (hacky for now)
     idmat <- (newMatrix RowMajor [1,0,0,0
@@ -466,6 +494,21 @@ renderPicture' pdata rot zoom (tranx,trany) (winx,winy) wallPoints lightPoints p
 bufferOffset :: Integral a => a -> Ptr b
 bufferOffset = plusPtr nullPtr . fromIntegral
 
+renderTree' :: Foldable f => RenderData -> Float -> Float -> (Float,Float) -> (Float,Float)
+                    -> f RenderType -> IO Word32
+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
+
+    bindShaderBuffers slist is
+    drawShaders slist is
+    
+    pokeEndTicks <- SDL.ticks
+    return $ pokeEndTicks - pokeStartTicks
 
 -- the following code draws a picture tree
 -- it does not set nor change the blend function or depth buffer