Draw shape shadows using index buffer

src/Data/Preload/Render.hs

@@ -30,6 +30,7 @@ data RenderData = RenderData
     , _grayscaleShader          :: FullShader
     , _shapeShader              :: FullShader
     , _shapeEBO :: EBO
+    , _silhouetteEBO :: EBO
     , _pictureShaders           :: MV.MVector (PrimState IO) FullShader
     , _fbo2                     :: (FramebufferObject, TextureObject)
     , _fbo3                     :: (FramebufferObject, TextureObject)

src/Dodge/Creature/Picture.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE TupleSections #-}
 {- |
 Drawing of creatures. 
 Takes into account damage etc. -}
@@ -173,9 +174,22 @@ scalp cr
     | oneH   cr = rotateSH 0.5 $ translateSHf (0.25 * crad) 0 fhead
     | otherwise = translateSHf (0.25 * crad) 0 fhead
   where
-    fhead = colorSH (greyN 0.9) . upperPrismPoly 5 . polyCirc 3 $ crad * 0.5
+    --fhead = colorSH (greyN 0.9) . upperPrismPoly 5 . polyCirc 3 $ crad * 0.5
+    fhead = ([ShapeObj TopHexahedron $ map (flip ShapeV (greyN 0.9)) aBox] , mempty)
     crad = _crRad cr
 
+aBox :: [Point3]
+aBox =
+    [ V3 0 0 5
+    , V3 5 0 5
+    , V3 5 5 5
+    , V3 0 5 5
+    , V3 0 0 0
+    , V3 5 0 0
+    , V3 5 5 0
+    , V3 0 5 0
+    ]
+
 oneH :: Creature -> Bool
 oneH cr = crIsAiming' cr && crIt ^? itAimStance == Just OneHand
   where

src/Dodge/Layout.hs

@@ -79,7 +79,7 @@ setupWorldBounds w = w
 
 setupForegroundEdgeVerxs :: World -> World
 setupForegroundEdgeVerxs w = w & foregroundEdgeVerx .~ polyhedrasToEdges (_foregroundDecorations w)
-    & foregroundShape .~ (vs,es)
+    & foregroundShape .~ ([ShapeObj ListV vs],es)
   where
     vs = shVfromList $ map pairToSV $ concatMap polyToTris $ concatMap _pyFaces $ _foregroundDecorations w
     es = shEfromList $ polyhedrasToEdges (_foregroundDecorations w)

src/Dodge/Render.hs

@@ -57,10 +57,11 @@ doDrawing pdata w = do
     -- bind as much data into vbos as feasible at this point
     -- poke wall points and colors
     nWalls <- poke224s (shadVBOptr $ _wallTextureShader pdata) wallPointsCol
-    (numShapeVs,nSils) <- pokeShape
+    (numShapeVs,nSils,nIndices,nSilIndices) <- pokeShape
         (_vboPtr $ _vaoVBO $ _shadVAO $ _shapeShader pdata)
         (shadVBOptr $ _lightingLineShadowShader pdata) 
         (_eboPtr $ _shapeEBO pdata)
+        (_eboPtr $ _silhouetteEBO pdata)
         $ worldShape w
     -- bind wall points, silhouette data, surface geometry
     uncurry bindShaderBuffers $ unzip
@@ -68,6 +69,20 @@ doDrawing pdata w = do
         , (_lightingLineShadowShader pdata, nSils)
         , (_shapeShader pdata, numShapeVs)
         ]
+    bindBuffer ElementArrayBuffer $= Just (_ebo $ _shapeEBO pdata)
+    bufferSubData
+        ElementArrayBuffer
+        WriteToBuffer
+        0
+        (fromIntegral $ glushortSize * nIndices)
+        (_eboPtr $ _shapeEBO pdata)
+    bindBuffer ElementArrayBuffer $= Just (_ebo $ _silhouetteEBO pdata)
+    bufferSubData
+        ElementArrayBuffer
+        WriteToBuffer
+        0
+        (fromIntegral $ glushortSize * nIndices)
+        (_eboPtr $ _silhouetteEBO pdata)
     -- set the coordinate uniform ready for drawing elements using world coordinates
     bufferUBO $ perspectiveMatrixb rot camzoom trans wins viewFroms
     setViewportSize (round winx `div` resFact) (round winy `div` resFact)
@@ -90,20 +105,12 @@ doDrawing pdata w = do
     pokeBindFoldableLayer shadV layerCounts $ worldPictures w
     renderLayer 0 shadV layerCounts
 
---    drawShader (_shapeShader pdata) numShapeVs
     let fs = _shapeShader pdata
     currentProgram $= Just (_shadProg fs)
     bindVertexArrayObject $= Just (_vao $ _shadVAO fs)
-    bindBuffer ElementArrayBuffer $= Just (_ebo $ _shapeEBO pdata)
-    bufferSubData
-        ElementArrayBuffer
-        WriteToBuffer
-        0
-        (fromIntegral $ glushortSize * numShapeVs)
-        (_eboPtr $ _shapeEBO pdata)
     glDrawElements
         (marshalEPrimitiveMode $ _shadPrim fs) 
-        (fromIntegral numShapeVs)
+        (fromIntegral nIndices)
         (GL_UNSIGNED_SHORT)
         nullPtr
 
@@ -113,8 +120,8 @@ doDrawing pdata w = do
     drawShader (_textureArrayShader pdata) nTextArrayVs
     --draw lightmap for base buffer
     bindFramebuffer Framebuffer $= fst (_fboLighting pdata)
-    --createLightMap pdata lightPoints nWalls nSils numShapeVs (snd $ snd $ _fboBase pdata)
+    createLightMap pdata lightPoints nWalls nSils numShapeVs (snd $ snd $ _fboBase pdata)
-    createLightMap pdata lightPoints nWalls 0 0 (snd $ snd $ _fboBase pdata)
+    --createLightMap pdata lightPoints nWalls 0 0 (snd $ snd $ _fboBase pdata)
     colorMask $= Color4 Enabled Enabled Enabled Enabled
     clearColor $= Color4 0 0 0 0
     --apply lightmap to base buffer

src/Preload/Render.hs

@@ -96,6 +96,7 @@ preloadRender = do
     bindVertexArrayObject $= Just shPosVAOname
     bindBuffer ArrayBuffer $= Just shVBOname
     setupVertexAttribPointer 0 3 7 0
+    bindBuffer ElementArrayBuffer $= Just shEBOname
     let shPosColVAO = VAO { _vao = shPosColVAOname, _vaoVBO = shVBO }
         shPosVAO    = VAO { _vao = shPosVAOname,    _vaoVBO = shVBO }
     -- lighting shaders
@@ -107,6 +108,16 @@ preloadRender = do
     lightingLineShadowShad
         <- makeShader "lighting/lineShadow" [vert,geom,frag] [3] ELinesAdjacency
                 >>= addUniforms ["lightPos"]
+    silEBOname <- genObjectName
+    silEBOptr <- mallocArray numDrawableElements
+    -- it may be important to bind this while the correct VAO is bound
+    bindBuffer ElementArrayBuffer $= Just silEBOname
+    bufferData ElementArrayBuffer $=
+        ( fromIntegral $ glushortSize * numDrawableElements
+        , nullPtr
+        , StreamDraw
+        )
+    let silEBO = EBO {_ebo = silEBOname, _eboPtr = silEBOptr}
 -- 2D draw shaders
     bslist <- makeShader "dualTwoD/basic"   [vert,frag] [3,4]   ETriangles 
     bslista <- makeShader "dualTwoD/basic"   [vert,frag] [3,4]   ETriangles 
@@ -181,6 +192,7 @@ preloadRender = do
         { _pictureShaders = shadV
         , _shapeShader = bslista {_shadVAO = shPosColVAO }
         , _shapeEBO = shEBO
+        , _silhouetteEBO = silEBO
         , _lightingCapShader        = lightingCapShad { _shadVAO = shPosVAO }
         , _lightingLineShadowShader = lightingLineShadowShad
         , _lightingOccludeShader    = wsShad    {_shadVAO = wpVAO}

src/Render.hs

@@ -9,6 +9,7 @@ module Render
     )
   where
 import Shader
+import Shader.ExtraPrimitive
 import Shader.Data
 --import Shader.Poke
 import Data.Preload.Render
@@ -16,13 +17,14 @@ import Picture.Data
 import Geometry.Data
 
 --import Data.Foldable
---import Foreign hiding (rotate)
+import Foreign hiding (rotate)
 import Graphics.Rendering.OpenGL hiding (Line,translate,scale,imageHeight,Polygon,Color,T)
 --import qualified SDL
 import qualified Data.Vector.Unboxed.Mutable as UMV
 import qualified Data.Vector.Mutable as MV
 import Control.Monad.Primitive
 import qualified Data.Vector.Fusion.Stream.Monadic as VS
+import Graphics.GL.Core43
 
 divideSize :: Int -> Size -> Size
 divideSize i (Size x y) = Size (div x $ fromIntegral i) (div y $ fromIntegral i)
@@ -66,16 +68,32 @@ createLightMap pdata lightPoints nWalls nSils nCaps toPos = do
             $= Vector3 x y z
         drawShader (_lightingOccludeShader pdata) nWalls
         --draw silhouette shadows
+        let llss = _lightingLineShadowShader pdata
         currentProgram $= Just (_shadProg $ _lightingLineShadowShader pdata)
         uniform (head $  _shadUnis $ _lightingLineShadowShader pdata)
             $= Vector3 x y z
-        drawShader (_lightingLineShadowShader pdata) nSils
+    --    drawShader (_lightingLineShadowShader pdata) nSils
+        bindVertexArrayObject $= Just (_vao $ _shadVAO llss)
+        glDrawElements
+            (marshalEPrimitiveMode $ _shadPrim llss) 
+            (fromIntegral nSils)
+            (GL_UNSIGNED_SHORT)
+            nullPtr
         cullFace $= Just Back
+
         --draw caps on the near plane as required
         currentProgram $= Just (_shadProg $ _lightingCapShader pdata)
         uniform (head $  _shadUnis $ _lightingCapShader pdata)
             $= Vector3 x y z
-        drawShader (_lightingCapShader pdata) nCaps
+        -- TODO clean this up
+        let fs = _lightingCapShader pdata
+        bindVertexArrayObject $= Just (_vao $ _shadVAO fs)
+        glDrawElements
+            (marshalEPrimitiveMode $ _shadPrim fs) 
+            (fromIntegral nCaps)
+            (GL_UNSIGNED_SHORT)
+            nullPtr
+        --drawShader (_lightingCapShader pdata) nCaps
         --draw lightmap itself
         depthFunc $= Just Always
         --cullFace $= Nothing

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 
-pokeShape vptr eptr iptr = bifoldlM (pokeShapeVs' vptr iptr) (pokeShapeEs' eptr) (0,0)
+    :: 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)
+pokeShapeObjs 
-pokeShapeVs' ptr iptr count = VS.foldlM' (pokeShapeV' ptr iptr) count . VS.fromList
+    :: 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)
+pokeShapeObj :: Ptr Float -> Ptr GLushort -> (Int,Int,Int,Int) -> ShapeObj -> IO (Int,Int,Int,Int)
-pokeShapeEs' ptr count = VS.foldlM' (pokeShapeE' ptr) count . VS.fromList
+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)
+pokeShapeVs :: Ptr Float -> Ptr GLushort -> (Int,Int,Int,Int) -> [ShapeV] -> IO (Int, Int,Int,Int)
-pokeShapeE' ptr (nv,n) (V3 a b c) = do
+pokeShapeVs ptr iptr count = VS.foldlM' (pokeShapeV ptr iptr) count . VS.fromList
-    pokeElemOff ptr (n * 3) a
-    pokeElemOff ptr (n * 3 + 1) b
-    pokeElemOff ptr (n * 3 + 2) c
-    return $ (nv,n + 1)
 
-pokeShapeV' :: Ptr Float -> Ptr GLushort -> (Int,Int) -> ShapeV -> IO (Int,Int)
+pokeShapeEs :: Ptr Float -> Ptr GLushort -> (Int,Int,Int,Int) -> [Point3] -> IO (Int,Int,Int,Int)
-pokeShapeV' ptr iptr (n,ne) sh = do
+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 (nv+1,ne,ni,nei)
-    return (n+1,ne)
   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
 

src/Shape.hs

@@ -40,7 +40,7 @@ upperPrismPoly
     -> Shape
 {-# INLINE upperPrismPoly #-}
 upperPrismPoly h ps =
-    ( topFace <> sideFaces
+    ( [ShapeObj ListV (topFace <> sideFaces)]
     , topEdges <> bottomEdges <> sideEdges
     )
   where
@@ -64,7 +64,7 @@ prismPoly
     -> Shape
 {-# INLINE prismPoly #-}
 prismPoly h ps =
-    ( topFace <> bottomFace <> sideFaces
+    ( [ShapeObj ListV (topFace <> bottomFace <> sideFaces)]
     , topEdges <> bottomEdges <> sideEdges
     )
   where
@@ -86,7 +86,7 @@ prismPoly h ps =
 
 flatPoly :: [Point2] -> Shape
 flatPoly ps =
-    ( shVfromList $ polyToTris $ map f ps
+    ( [ShapeObj ListV $ shVfromList $ polyToTris $ map f ps]
     , shEfromList $ concat $ zipWith g ps (tail ps ++ [head ps])
     )
   where
@@ -106,11 +106,11 @@ colorSH col = overCol $ const col
 
 overCol :: (Point4 -> Point4) -> Shape -> Shape
 {-# INLINE overCol #-}
-overCol f = first (fmap $ overColVertex f)
+overCol f = first (fmap $ overColObj f)
 
 overPos :: (Point3 -> Point3) -> Shape -> Shape
 {-# INLINE overPos #-}
-overPos f = bimap (fmap $ overPosVertex f) (fmap f)
+overPos f = bimap (fmap $ overPosObj f) (fmap f)
 
 translateSH :: Point3 -> Shape -> Shape
 {-# INLINE translateSH #-}
@@ -132,10 +132,18 @@ scaleSH :: Point3 -> Shape -> Shape
 {-# INLINE scaleSH #-}
 scaleSH !(V3 a b c) = overPos (\(V3 x y z) -> V3 (x*a) (y*b) (z*c))
 
+overColObj :: (Point4 -> Point4) -> ShapeObj -> ShapeObj
+{-# INLINE overColObj #-}
+overColObj f (ShapeObj st vs) = ShapeObj st (map (overColVertex f) vs)
+
 overColVertex :: (Point4 -> Point4) -> ShapeV -> ShapeV
 {-# INLINE overColVertex #-}
 overColVertex f (ShapeV a b) = ShapeV a (f b)
 
+overPosObj :: (Point3 -> Point3) -> ShapeObj -> ShapeObj
+{-# INLINE overPosObj #-}
+overPosObj f (ShapeObj st vs) = ShapeObj st $ map (overPosVertex f) vs
+
 overPosVertex :: (Point3 -> Point3) -> ShapeV -> ShapeV
 {-# INLINE overPosVertex #-}
 overPosVertex f (ShapeV a b) = ShapeV (f a) b

src/Shape/Data.hs

@@ -8,10 +8,11 @@ module Shape.Data
 import Geometry.Data
 --import qualified Data.DList as DL
 
-type Shape = ([ShapeV], [Point3])
+type Shape = ([ShapeObj], [Point3])
+
 _shVertices :: Shape -> [ShapeV]
 {-# INLINE _shVertices #-}
-_shVertices = fst
+_shVertices = concatMap _shVs . fst
 _shEdges :: Shape -> [Point3]
 {-# INLINE _shEdges #-}
 _shEdges = snd
@@ -32,6 +33,16 @@ shVfromList = id
 shEfromList = id
 --shEfromList = DL.fromList
 
+data ShapeObj = ShapeObj 
+    { _shType :: ShapeType 
+    , _shVs :: [ShapeV]
+    }
+
+data ShapeType
+    = ListV
+    | TopHexahedron    -- ^ assumed convex, eight vertices
+    | TopPrism Int
+
 -- edges are given by four consecutive points
 data ShapeV = ShapeV
     {_svPos :: Point3