Draw shape shadows using index buffer

src/Shader/Poke.hs

@@ -21,6 +21,7 @@ import qualified Data.Vector.Unboxed.Mutable as UMV
 import qualified Data.Vector.Mutable as MV
 import qualified Data.Vector.Fusion.Stream.Monadic as VS
 import Control.Monad.Primitive
+import Control.Monad
 import Data.Bifoldable
 --import qualified Data.DList as DL
 
@@ -42,25 +43,64 @@ pokeVerx vbos offsets Verx{_vxPos=thePos,_vxCol=theCol,_vxExt=ext,_vxShadNum=the
   where
     sn = _unShadNum theShadNum
 
-pokeShape :: Ptr Float -> Ptr Float -> Ptr GLushort -> Shape -> IO (Int,Int)
-pokeShape vptr eptr iptr = bifoldlM (pokeShapeVs' vptr iptr) (pokeShapeEs' eptr) (0,0)
+pokeShape 
+    :: Ptr Float    -- ^ vertex data pointer
+    -> Ptr Float    -- ^ edge data pointer
+    -> Ptr GLushort -- ^ vertex indices pointer
+    -> Ptr GLushort -- ^ edge indices pointer
+    -> Shape 
+    -> IO (Int,Int,Int,Int)
+pokeShape vptr eptr iptr ieptr = bifoldlM 
+    (pokeShapeObjs vptr iptr ieptr) 
+    (pokeShapeEs eptr ieptr) (0,0,0,0)
 
-pokeShapeVs' :: Ptr Float -> Ptr GLushort -> (Int,Int) -> [ShapeV] -> IO (Int, Int)
-pokeShapeVs' ptr iptr count = VS.foldlM' (pokeShapeV' ptr iptr) count . VS.fromList
+pokeShapeObjs 
+    :: Ptr Float 
+    -> Ptr GLushort 
+    -> Ptr GLushort -> (Int,Int,Int,Int) -> [ShapeObj] -> IO (Int, Int,Int,Int)
+pokeShapeObjs ptr iptr ieptr count = VS.foldlM' (pokeShapeObj ptr iptr) count . VS.fromList
 
-pokeShapeEs' :: Ptr Float -> (Int,Int) -> [Point3] -> IO (Int, Int)
-pokeShapeEs' ptr count = VS.foldlM' (pokeShapeE' ptr) count . VS.fromList
+pokeShapeObj :: Ptr Float -> Ptr GLushort -> (Int,Int,Int,Int) -> ShapeObj -> IO (Int,Int,Int,Int)
+pokeShapeObj ptr iptr counts (ShapeObj shType shVerts) = case shType of
+    ListV -> pokeShapeVs ptr iptr counts shVerts
+    TopHexahedron -> pokeTopHexahedron ptr iptr counts shVerts
 
 
-pokeShapeE' :: Ptr Float -> (Int,Int) -> Point3 -> IO (Int,Int)
-pokeShapeE' ptr (nv,n) (V3 a b c) = do
-    pokeElemOff ptr (n * 3) a
-    pokeElemOff ptr (n * 3 + 1) b
-    pokeElemOff ptr (n * 3 + 2) c
-    return $ (nv,n + 1)
+pokeShapeVs :: Ptr Float -> Ptr GLushort -> (Int,Int,Int,Int) -> [ShapeV] -> IO (Int, Int,Int,Int)
+pokeShapeVs ptr iptr count = VS.foldlM' (pokeShapeV ptr iptr) count . VS.fromList
 
-pokeShapeV' :: Ptr Float -> Ptr GLushort -> (Int,Int) -> ShapeV -> IO (Int,Int)
-pokeShapeV' ptr iptr (n,ne) sh = do
+pokeShapeEs :: Ptr Float -> Ptr GLushort -> (Int,Int,Int,Int) -> [Point3] -> IO (Int,Int,Int,Int)
+pokeShapeEs ptr ieptr count = VS.foldlM' (pokeShapeE ptr ieptr) count . VS.fromList
+
+
+pokeShapeE :: Ptr Float -> Ptr GLushort -> (Int,Int,Int,Int) -> Point3 -> IO (Int,Int,Int,Int)
+pokeShapeE eptr ieptr (nv,n,ni,nei) (V3 a b c) = do
+    pokeElemOff eptr (n * 3) a
+    pokeElemOff eptr (n * 3 + 1) b
+    pokeElemOff eptr (n * 3 + 2) c
+    pokeElemOff ieptr nei (fromIntegral nei)
+    return $ (nv,n + 1,ni,nei+1)
+
+pokeTopHexahedron :: Ptr Float -> Ptr GLushort -> (Int,Int,Int,Int) -> [ShapeV] -> IO (Int,Int,Int,Int)
+pokeTopHexahedron ptr iptr count svs = do
+    count' <- pokeHexahedronIndices iptr count
+    VS.foldlM' (pokeJustV ptr) count' (VS.fromList svs)
+
+pokeHexahedronIndices :: Ptr GLushort -> (Int,Int,Int,Int) -> IO (Int,Int,Int,Int)
+pokeHexahedronIndices iptr (nv,ne,ni,nei) = do
+    ni' <- foldM (pokeHexhedronIndex nv iptr) ni hexIndices
+    return (nv,ne,ni',nei)
+
+pokeHexhedronIndex :: Int -> Ptr GLushort -> Int -> Int -> IO Int
+pokeHexhedronIndex nv iptr ni ioff = do
+    pokeElemOff iptr ni (fromIntegral $ nv + ioff)
+    return (ni + 1)
+
+hexIndices :: [Int]
+hexIndices = [0,1,2,0,2,3,0,4,5,0,5,1,1,5,6,1,6,2,2,6,7,2,7,8,3,7,4,3,4,0]
+
+pokeJustV :: Ptr Float -> (Int,Int,Int,Int) -> ShapeV -> IO (Int,Int,Int,Int)
+pokeJustV ptr (nv,ne,ni,nei) sh = do
     pokeElemOff ptr (off 0) a
     pokeElemOff ptr (off 1) b
     pokeElemOff ptr (off 2) c
@@ -68,10 +108,25 @@ pokeShapeV' ptr iptr (n,ne) sh = do
     pokeElemOff ptr (off 4) e
     pokeElemOff ptr (off 5) f
     pokeElemOff ptr (off 6) g
-    pokeElemOff iptr n (fromIntegral n)
-    return (n+1,ne)
+    return (nv+1,ne,ni,nei)
   where
-    off i = n*7 + i
+    off i = nv*7 + i
+    V3 a b c    = _svPos sh
+    V4 d e f g  = _svCol sh
+
+pokeShapeV :: Ptr Float -> Ptr GLushort -> (Int,Int,Int,Int) -> ShapeV -> IO (Int,Int,Int,Int)
+pokeShapeV ptr iptr (nv,ne,ni,nei) sh = do
+    pokeElemOff ptr (off 0) a
+    pokeElemOff ptr (off 1) b
+    pokeElemOff ptr (off 2) c
+    pokeElemOff ptr (off 3) d
+    pokeElemOff ptr (off 4) e
+    pokeElemOff ptr (off 5) f
+    pokeElemOff ptr (off 6) g
+    pokeElemOff iptr ni (fromIntegral nv)
+    return (nv+1,ne,ni+1,nei)
+  where
+    off i = nv*7 + i
     V3 a b c    = _svPos sh
     V4 d e f g  = _svCol sh