Continue tweaking rendering

src/Shader/Poke.hs

@@ -1,15 +1,21 @@
+{-# LANGUAGE TupleSections #-}
 module Shader.Poke
     ( pokeArrayOff
     , pokeShader
     , pokeShaderLayer
+    , pokeVX
     ) where
 import Shader.Data
 import Shader.Parameters
 import Picture.Data
 
+import Data.Maybe
+import Data.List
 import Foreign
 import Control.Monad
 import qualified Control.Foldl as F
+import qualified Data.IntMap.Strict as IM
+import Control.Lens
 
 pokeShader :: FullShader -> F.FoldM IO RenderType Int
 pokeShader fs = F.FoldM (pokeVertices fls ptr stride)  (return 0) return
@@ -30,6 +36,25 @@ pokeVertices
     -> IO Int
 pokeVertices toFs ptr stride n rt = foldM (pokeVertex ptr stride) n (toFs rt)
 
+pokeSL :: [(Int,[VShader])] -> [Verx] -> IO (IM.IntMap [(VShader,Int)])
+pokeSL vslist vxs = do
+    foldM pokeVX (f vslist) vxs
+  where
+    f = IM.map (map (, 0)) . IM.fromList
+
+pokeVX :: IM.IntMap [(VShader,Int)] -> Verx -> IO (IM.IntMap [(VShader,Int)])
+pokeVX count vx = do
+    let offset = _vxLayer vx
+        lshads = count IM.! offset
+        (vshad,n) = fromJust $ find (\(s,_) -> _vshaderPokeTest s $ _vxType vx) lshads
+        i = fromJust $ findIndex (\(s,_) -> _vshaderPokeTest s $ _vxType vx) lshads
+        theVBO = _vaoVBO $ _vshaderVAO vshad
+        ptr = _vboPointer theVBO
+        stride = sum $ _vboAttribSizes theVBO
+    pokeArrayOff ptr (stride * (n+offset * numSubElements)) (toFls' vx)
+    return $ count & ix offset . ix i . _2 +~ 1
+
+
 pokeShaderLayer :: (Int,VShader) -> F.FoldM IO Verx Int
 pokeShaderLayer (l,fs) = F.FoldM (pokeVerticesOff ptr (_vshaderPokeTest fs) stride l)  (return 0) return
   where 
@@ -53,6 +78,15 @@ pokeVerticesOff ptr vtest stride offset n vx
     i = _vxLayer vx
     typetest = vtest (_vxType vx)
 
+toFls' :: Verx -> [Float]
+toFls' vx = flat3 (_vxPos vx) ++ flat4 (_vxCol vx) ++ f (_vxType vx)
+  where
+    f (PolyzV x) = [x]
+    f (BezV x) = flat4 x
+    f (TextV x) = flat2 x
+    f (ArcV x) = flat3 x
+    f _ = []
+
 toFls :: Verx -> [[Float]]
 toFls vx = [flat3 (_vxPos vx) ++ flat4 (_vxCol vx) ++ f (_vxType vx)]
   where