Add shading for shapes and the floor

shader/lighting/texture.frag

@@ -1,17 +1,24 @@
 #version 450 core
 uniform vec3 lightPos;
 uniform vec4 lumRad;
-uniform sampler2D screenTexture;
+layout (binding = 0) uniform sampler2D screenTexture;
+layout (binding = 1) uniform sampler2D normals;
 in vec2 vTexPos;
 out vec4 fColor;
 float rad = lumRad.a;
 void main() {
-  vec3 distVec = texture(screenTexture, vTexPos).xyz - lightPos;
+  vec3 pos = texture(screenTexture, vTexPos).xyz;
+  vec3 distVec = pos - lightPos;
+  vec4 normbit = texture(normals, vTexPos);
+  vec3 norm = normbit.xyz - pos;
+  float y1 = float(normbit.w == 0 ? 1 : dot(normalize(norm), normalize(distVec)));
+  float y = float(y1 > 0 ? 1 : 0);
+//  float y = float(normbit.w == 1 ? 1 : 0);
   float dist = dot(distVec, distVec);
   if (dist > rad) {
     discard;
   }
   float x = 1 - dist / rad;
-  vec3 c = (x * x * x) * lumRad.rgb;
+  vec3 c = y* (x * x * x) * lumRad.rgb;
   fColor = vec4(c, 0);
 }

shader/shape/basic.frag

@@ -1,10 +1,14 @@
 #version 450 core
 in vec4 vCol;
 in vec4 vPos;
+in vec4 vNorm;
 layout (location=0) out vec4 fCol;
 layout (location=1) out vec4 fPos;
+layout (location=2) out vec4 fNorm;
 void main()
 {
   fCol = vCol;
-  fPos = vec4(vPos.xyz,1);
+  fPos = vPos;
+  fNorm = vNorm;
+  //fNorm = vec4(vPos.x,vPos.y+2,vPos.z,1);
 }

shader/shape/basic.vert

@@ -1,11 +1,14 @@
 #version 450 core
 layout (location = 0) in vec4 pos;
 layout (location = 1) in vec4 col;
+layout (location = 2) in vec4 norm;
 layout (std140, binding = 0) uniform TheMat { mat4 theMat; } ;
 out vec4 vCol;
 out vec4 vPos;
+out vec4 vNorm;
 void main() {
   gl_Position = theMat * vec4(pos.xyz,1);
   vCol = col;
   vPos = pos;
+  vNorm = norm;
 }

shader/texture/arrayPos.frag

@@ -3,9 +3,12 @@ in vec3 vTexPos;
 in vec3 vPos;
 layout (location=0) out vec4 fCol;
 layout (location=1) out vec4 fPos;
+layout (location=2) out vec4 normal;
 uniform sampler2DArray tilesetSampler;
 void main()
 {
     fCol = texture(tilesetSampler, vTexPos);
     fPos = vec4(vPos,1);
+    //normal = vec4(vPos.xy,vPos.z-1,1);
+    normal = vec4(vPos.xy,vPos.z-1,1);
 }

shader/wall/texture.frag

@@ -1,6 +1,7 @@
 #version 450 core
 layout (location=0) out vec4 fCol;
 layout (location=1) out vec4 fPos;
+layout (location=2) out vec4 fNorm;
 in vec2 tPos;
 in vec4 gPos;
 in vec4 gColor;
@@ -9,4 +10,5 @@ void main()
 {
   fCol = gColor * texture(tex,tPos);
   fPos = gPos;
+  fNorm = gPos + vec4(1,0,0,0);
 }

shader/wall/texture.geom

@@ -15,13 +15,9 @@ void main()
   vec4 p2 = vec4 (gl_in[0].gl_Position.zw,0,1);
   vec4 p3 = vec4 (p1.xy,100,1);
   vec4 p4 = vec4 (p2.xy,100,1);
-  vec4 a1 = theMat * p1;
+  gPos = p1; tPos = vec2 ( 1,-1) ; gl_Position = vec4(theMat * p1); EmitVertex();
-  vec4 a2 = theMat * p2;
+  gPos = p3; tPos = vec2 ( 1, 1) ; gl_Position = vec4(theMat * p3); EmitVertex();
-  vec4 a3 = theMat * p3;
+  gPos = p2; tPos = vec2 (-1,-1) ; gl_Position = vec4(theMat * p2); EmitVertex();
-  vec4 a4 = theMat * p4;
+  gPos = p4; tPos = vec2 (-1, 1) ; gl_Position = vec4(theMat * p4); EmitVertex();
-  gPos = p1; tPos = vec2 ( 1,-1) ; gl_Position = a1; EmitVertex();
-  gPos = p3; tPos = vec2 ( 1, 1) ; gl_Position = a3; EmitVertex();
-  gPos = p2; tPos = vec2 (-1,-1) ; gl_Position = a2; EmitVertex();
-  gPos = p4; tPos = vec2 (-1, 1) ; gl_Position = a4; EmitVertex();
   EndPrimitive();
 }

src/Data/Preload/Render.hs

@@ -44,7 +44,7 @@ data RenderData = RenderData
     , _fboHalf1 :: (FBO, TO)
     , _fboHalf2 :: (FBO, TO)
     , _fboHalf3 :: (FBO, TO)
-    , _fboBase :: (FBO, (TO, TO))
+    , _fboBase :: (FBO, (TO, TO, TO))
     , _fboCloud :: (FBO, (TO, TO))
     , _fboBloom :: (FBO, TO)
     , _fboColor :: (FBO, TO)

src/Dodge/Render.hs

@@ -125,7 +125,12 @@ doDrawing' win pdata u = do
             (marshalEPrimitiveMode $ pdata ^. lightingWallShadShader . shadPrim')
             0
             (fromIntegral nWalls)
---    glDisable GL_CULL_FACE
+    -- clear normals
+    withArray [0,0,0,0] $ \ptr -> glClearNamedFramebufferfv
+        (pdata ^. fboBase . _1 . unFBO)
+        GL_COLOR
+        2
+        ptr
     --draw walls onto base buffer
     if cfig ^. graphics_wall_textured
         then renderTextureWalls pdata nWalls
@@ -152,7 +157,7 @@ doDrawing' win pdata u = do
         nSilIndices
         nIndices
         (u ^. uvConfig . graphics_object_shadows)
-        (snd $ snd $ pdata ^. fboBase)
+        (pdata ^. fboBase . _2 . _2)
         (drawCPUShadows pdata ws)
     glColorMask GL_TRUE GL_TRUE GL_TRUE GL_TRUE
     glClearColor 0 0 0 0
@@ -196,29 +201,29 @@ doDrawing' win pdata u = do
     glClear GL_COLOR_BUFFER_BIT
     renderLayer MidLayer shadV layerCounts
     drawShader (_windowShader pdata) nWins
-    when (_graphics_cloud_shadows cfig) $ do
+--    when (_graphics_cloud_shadows cfig) $ do
-        ----render transparency depths
+--        ----render transparency depths
-        glDepthMask GL_TRUE
+--        glDepthMask GL_TRUE
-        glDisable GL_BLEND
+--        glDisable GL_BLEND
-        withArray [GL_NONE, GL_COLOR_ATTACHMENT1] $ \ptr -> glDrawBuffers 2 ptr
+--        withArray [GL_NONE, GL_COLOR_ATTACHMENT1] $ \ptr -> glDrawBuffers 2 ptr
-        renderLayer MidLayer shadV layerCounts
+--        renderLayer MidLayer shadV layerCounts
-        drawShader (_windowShader pdata) nWins
+--        drawShader (_windowShader pdata) nWins
-        ----draw lightmap for cloud buffer
+--        ----draw lightmap for cloud buffer
-        glDepthMask GL_FALSE
+--        glDepthMask GL_FALSE
-        glEnable GL_BLEND
+--        glEnable GL_BLEND
-        glBindFramebuffer GL_FRAMEBUFFER (_unFBO (fst (_fboLighting pdata)))
+--        glBindFramebuffer GL_FRAMEBUFFER (_unFBO (fst (_fboLighting pdata)))
-        createLightMap
+--        createLightMap
-            cfig
+--            cfig
-            pdata
+--            pdata
-            lightPoints
+--            lightPoints
-            nWalls
+--            nWalls
-            nSilIndices
+--            nSilIndices
-            nIndices
+--            nIndices
-            (_graphics_object_shadows $ _uvConfig u)
+--            (_graphics_object_shadows $ _uvConfig u)
-            (snd $ snd $ _fboCloud pdata)
+--            (snd $ snd $ _fboCloud pdata)
-            (drawCPUShadows pdata ws)
+--            (drawCPUShadows pdata ws)
-        glColorMask GL_TRUE GL_TRUE GL_TRUE GL_TRUE
+--        glColorMask GL_TRUE GL_TRUE GL_TRUE GL_TRUE
-        glClearColor 0 0 0 0
+--        glClearColor 0 0 0 0
     glInvalidateBufferData (pdata ^. vboShapes . vboName)
     --apply lightmap to cloud buffer
     glClearColor 0 0 0 0
@@ -249,7 +254,7 @@ doDrawing' win pdata u = do
     -- perform any radial distortion
     case w ^. cWorld . lWorld . distortions of
         [] -> do
-            bindTO $ fst $ snd $ _fboBase pdata
+            bindTO $ pdata ^. fboBase . _2 . _1
             glBindFramebuffer GL_FRAMEBUFFER 0
             drawShader (fst $ _fullscreenShader pdata) 4
         rds -> do
@@ -261,7 +266,7 @@ doDrawing' win pdata u = do
                 fboList =
                     take (length rds - 1) (concat (repeat [fst $ _fbo2 pdata, fst $ _fbo3 pdata]))
                         ++ [FBO 0]
-                toList = fst (snd (_fboBase pdata)) : concat (repeat [snd $ _fbo2 pdata, snd $ _fbo3 pdata])
+                toList = (pdata ^. fboBase . _2 . _1) : concat (repeat [snd $ _fbo2 pdata, snd $ _fbo3 pdata])
                 bindings = zipWith (>>) (map bindFBO fboList) (map bindTO toList)
             glActiveTexture GL_TEXTURE1
             zipWithM_ (>>) bindings $ map bindDrawDist rds

src/Framebuffer/Setup.hs

@@ -3,6 +3,7 @@ module Framebuffer.Setup (
     setupTextureFramebuffer,
     setupFramebufferGivenStencil,
     setupFramebuffer2GivenStencil,
+    setupFramebuffer3GivenStencil,
     setupShadowFramebuffer,
 ) where
 
@@ -75,3 +76,15 @@ setupFramebuffer2GivenStencil rboName = do
     glNamedFramebufferRenderbuffer fboName GL_DEPTH_STENCIL_ATTACHMENT GL_RENDERBUFFER rboName
     checkFBO $ FBO fboName
     return (FBO fboName, (TO to1, TO to2))
+
+setupFramebuffer3GivenStencil ::
+    GLuint -> -- RenderbufferObject
+    IO (FBO, (TO, TO, TO))
+setupFramebuffer3GivenStencil rboName = do
+    fboName <- mglCreate glCreateFramebuffers
+    to1 <- mglCreate (glCreateTextures GL_TEXTURE_2D)
+    to2 <- mglCreate (glCreateTextures GL_TEXTURE_2D)
+    to3 <- mglCreate (glCreateTextures GL_TEXTURE_2D)
+    glNamedFramebufferRenderbuffer fboName GL_DEPTH_STENCIL_ATTACHMENT GL_RENDERBUFFER rboName
+    checkFBO $ FBO fboName
+    return (FBO fboName, (TO to1, TO to2, TO to3))

src/Framebuffer/Update.hs

@@ -29,8 +29,9 @@ sizeFBOs ::
     IO RenderData
 sizeFBOs xsize ysize xfull yfull rdata = do
     resizeRBO (_rboBaseBloom rdata) xsize ysize
+    rdata1 <- updateFBOTO3 xsize ysize GL_NEAREST GL_NEAREST GL_RGBA8 GL_RGBA16F GL_RGBA16F rdata fboBase
     rdata' <-
-        foldM (updateFBOTO2 xsize ysize GL_NEAREST GL_NEAREST GL_RGBA8 GL_RGBA16F) rdata [fboBase, fboCloud]
+        foldM (updateFBOTO2 xsize ysize GL_NEAREST GL_NEAREST GL_RGBA8 GL_RGBA16F) rdata1 [fboCloud]
             >>= flip
                 (foldM (updateFBOTO xsize ysize GL_NEAREST GL_NEAREST GL_RGBA8))
                 [fboColor, fboLighting]
@@ -101,6 +102,26 @@ updateFBOTO2 xsize ysize minfilt magfilt inFormat1 inFormat2 pdata target = do
     newfbo2 <- resizeFBOTO2 (pdata ^# target) xsize ysize minfilt magfilt inFormat1 inFormat2
     return $ storing target newfbo2 pdata
 
+updateFBOTO3 ::
+    Int ->
+    Int ->
+    -- | minification filter
+    GLenum ->
+    -- | magnification filter
+    GLenum ->
+    -- | internal color format texture1
+    GLenum ->
+    -- | internal color format texture2
+    GLenum ->
+    -- | internal color format texture3
+    GLenum ->
+    RenderData ->
+    ALens' RenderData (FBO, (TO, TO, TO)) ->
+    IO RenderData
+updateFBOTO3 xsize ysize minfilt magfilt inFormat1 inFormat2 inFormat3 pdata target = do
+    newfbo2 <- resizeFBOTO3 (pdata ^# target) xsize ysize minfilt magfilt inFormat1 inFormat2 inFormat3
+    return $ storing target newfbo2 pdata
+
 -- note we only really "change" the texture objects
 resizeShadowFBO ::
     (FBO, (TO, TO)) ->
@@ -141,6 +162,34 @@ resizeFBOTO2 (fbo, (toOld1, toOld2)) xsize ysize minfilt magfilt inFormat1 inFor
     checkFBO fbo
     return (fbo, (TO to1, TO to2))
 
+resizeFBOTO3 ::
+    (FBO, (TO, TO,TO)) ->
+    Int ->
+    Int ->
+    -- | minification filter
+    GLenum ->
+    -- | magnification filter
+    GLenum ->
+    -- | internal color format1
+    GLenum ->
+    -- | internal color format2
+    GLenum ->
+    -- | internal color format3
+    GLenum ->
+    IO (FBO, (TO, TO,TO))
+resizeFBOTO3 (fbo, (toOld1, toOld2,told3)) xsize ysize minfilt magfilt inFormat1 inFormat2 inform3 = do
+    glBindFramebuffer GL_FRAMEBUFFER (_unFBO fbo)
+    mglDelete glDeleteTextures $ _unTO toOld1
+    mglDelete glDeleteTextures $ _unTO toOld2
+    mglDelete glDeleteTextures $ _unTO told3
+    to1 <- initializeTexture2D fbo GL_COLOR_ATTACHMENT0 xsize ysize minfilt magfilt inFormat1
+    to2 <- initializeTexture2D fbo GL_COLOR_ATTACHMENT1 xsize ysize minfilt magfilt inFormat2
+    to3 <- initializeTexture2D fbo GL_COLOR_ATTACHMENT2 xsize ysize minfilt magfilt inform3
+    withArray [GL_COLOR_ATTACHMENT0, GL_COLOR_ATTACHMENT1, GL_COLOR_ATTACHMENT2] $ \ptr ->
+        glNamedFramebufferDrawBuffers (_unFBO fbo) 3 ptr
+    checkFBO fbo
+    return (fbo, (TO to1, TO to2,TO to3))
+
 resizeFBOTO ::
     (FBO, TO) ->
     Int ->

src/Geometry/Polygon.hs

@@ -113,6 +113,9 @@ grahamEliminate xs = xs
 centroid :: Foldable t => t Point2 -> Point2
 centroid = L.fold $ (/) <$> L.Fold (+.+) (V2 0 0) id <*> L.genericLength
 
+centroidNum :: (Fractional a ,Foldable t) => t a -> a
+centroidNum = L.fold $ (/) <$> L.Fold (+) 0 id <*> L.genericLength
+
 shrinkPolyOnEdges :: Float -> [Point2] -> [Point2]
 shrinkPolyOnEdges x (p:q:ps) = map (shrinkVert x) . slideWindow 3 $ (p:q:ps) ++ [p,q]
 shrinkPolyOnEdges _ _ = error "too few vertices in polygon"

src/Preload/Render.hs

@@ -141,7 +141,7 @@ preloadRender = do
     positionalBlankShad <- makeShader "positional/blank" [vert, frag] [3] ETriangles
     -- 2D draw shaders
     bslist <- makeShader "dualTwoD/basic" [vert, frag] [3, 4] ETriangles
-    bslista <- makeShader4 "shape/basic" [vert, frag] [4, 4] ETriangles shVBO
+    bslista <- makeShader4 "shape/basic" [vert, frag] [4, 4, 4] nShapeVerxComp ETriangles shVBO
     glVertexArrayElementBuffer (bslista ^. shadVAO . vaoName) shEBOname
     aslist <- makeShader "dualTwoD/arc" [vert, frag] [3, 4, 3] ETriangles
     eslist <- makeShader "dualTwoD/ellipse" [vert, geom, frag] [3, 4] ETriangles
@@ -194,7 +194,7 @@ preloadRender = do
         800
         600
 
-    fboBaseName <- setupFramebuffer2GivenStencil rboBaseBloomName
+    fboBaseName <- setupFramebuffer3GivenStencil rboBaseBloomName
     fboCloudName <- setupFramebuffer2GivenStencil rboBaseBloomName
     fboBloomName <- setupFramebufferGivenStencil rboBaseBloomName
     fboColorName <- setupFramebufferGivenStencil rboBaseBloomName

src/Render.hs

@@ -100,7 +100,8 @@ createLightMap cfig pdata lightPoints nWalls nSils nCaps shadsdrawtype toPos dra
         glClear $ GL_COLOR_BUFFER_BIT + GL_DEPTH_BUFFER_BIT
         --    glClearDepth 1
         glDisable GL_CULL_FACE
-        bindTO toPos
+        --bindTO toPos
+        glBindTextureUnit 0 (toPos ^. unTO)
         glDepthFunc GL_ALWAYS
         glDepthMask GL_FALSE
     _ -> do
@@ -173,6 +174,7 @@ createLightMap cfig pdata lightPoints nWalls nSils nCaps shadsdrawtype toPos dra
             -- bind world position texture
             glDisable GL_CULL_FACE
             bindTO toPos
+            glBindTextureUnit 1 (pdata ^. fboBase . _2 . _3 . unTO)
             glColorMask GL_TRUE GL_TRUE GL_TRUE GL_TRUE
             glStencilFunc GL_EQUAL 0 255
             glUseProgram (ltextShad ^. shadName) --Just (_shadProg ltextShad)

src/Shader/Compile.hs

@@ -53,12 +53,14 @@ makeShader4 ::
     [GLenum] ->
     -- | The input vertex sizes
     [Int] ->
+    -- | The stride
+    Int ->
     EPrimitiveMode ->
     VBO ->
     IO FullShader
-makeShader4 s shaderlist sizes pm vbo = do
+makeShader4 s shaderlist sizes strd pm vbo = do
     prog <- makeSourcedShader s shaderlist
-    vao <- setupVAOvbo sizes vbo
+    vao <- setupVAOvbo sizes strd vbo
     return $ FullShader
             { _shadName = prog
             , _shadVAO = vao
@@ -163,11 +165,11 @@ shaderTypeExt' _ = undefined
 setupVAO :: [Int] -> IO (VAO,VBO)
 setupVAO = setupVAOSized numDrawableElements
 
-setupVAOvbo :: [Int] -> VBO -> IO VAO
+setupVAOvbo :: [Int] -> Int -> VBO -> IO VAO
-setupVAOvbo sizes vbo = do
+setupVAOvbo sizes strd vbo = do
     vaoname <- mglCreate glCreateVertexArrays
     glBindVertexArray vaoname
-    setupVertexAttribs vbo vaoname sizes
+    setupVertexAttribs vbo vaoname sizes strd
     return $ VAO
             { _vaoName = vaoname
             }
@@ -206,13 +208,12 @@ setupVBOSized ndraw vao sizes = do
     strd = sum sizes
     offs = scanl (+) 0 sizes
 
-setupVertexAttribs :: VBO -> GLuint -> [Int] -> IO ()
+setupVertexAttribs :: VBO -> GLuint -> [Int] -> Int -> IO ()
-setupVertexAttribs vbo vao sizes = do
+setupVertexAttribs vbo vao sizes strd = do
     glVertexArrayVertexBuffer vao 0 (vbo ^. vboName) 0 (fromIntegral $ floatSize * strd) 
     forM_ (zip3 [0 ..] sizes offs) $ \(loc, siz, off) -> do
         setupVertexAttribPointer vao loc siz off
   where
-    strd = sum sizes
     offs = scanl (+) 0 sizes
 
 -- | Assumes the correct VBO is bound

src/Shader/Poke.hs

@@ -6,11 +6,13 @@ module Shader.Poke
     , pokeWallsWindowsFloor
     , memoTopPrismEdgeIndices
     ) where
+import Geometry.Polygon
 import Shader.Data
 import Shader.Parameters
 import Picture.Data
 import Shape.Data
 import Geometry.Data
+import Control.Monad
 --import ShapePicture
 
 import Graphics.GL.Core45
@@ -96,16 +98,18 @@ pokeShapeObj
     -> IO (Int,Int,Int)
 {-# INLINE pokeShapeObj #-}
 pokeShapeObj ptr iptr ieptr counts (ShapeObj shtype shVerts) = case shtype of
-    TopPrism size -> pokeTopPrism (size - 2) ptr iptr ieptr counts (VFSM.fromList shVerts)
+    TopPrism size -> pokeTopPrism midp (size - 2) ptr iptr ieptr counts (VFSM.fromList shVerts)
+  where
+    midp = centroidNum $ map _svPos shVerts
 
-pokeTopPrism :: Int -> Ptr Float -> Ptr GLushort 
+pokeTopPrism :: Point3 -> Int -> Ptr Float -> Ptr GLushort 
     -> Ptr GLushort 
     -> (Int,Int,Int)
     -> VFSM.Stream IO ShapeV
     -> IO (Int,Int,Int)
 {-# INLINE pokeTopPrism #-}
-pokeTopPrism size ptr iptr ieptr (nv,nshapeindices,nedgeindices) svs = do
+pokeTopPrism cp size ptr iptr ieptr (nv,nshapeindices,nedgeindices) svs = do
-    nv' <- VFSM.foldlM' (pokeJustV ptr) nv svs
+    nv' <- VFSM.foldlM' (pokeJustV cp ptr) nv svs
     nshapeindices' <- UV.foldM' (pokeTopPrismIndex nv iptr) nshapeindices 
         (memoTopPrismIndices     V.! size)
     nedgeindices' <- UV.foldM' (pokeTopPrismEdgeIndex nv ieptr) nedgeindices
@@ -165,25 +169,23 @@ topPrismIndices n = concatMap f [1..n-2]    -- triangles on top face
 -- consider changing the position to a vec4
 -- and just doing two pokes rather than seven
 -- (especially if adding normal data)
-pokeJustV :: Ptr Float
+pokeJustV :: Point3
+    -> Ptr Float
     -> Int
     -> ShapeV 
     -> IO Int
 {-# INLINE pokeJustV #-}
-pokeJustV ptr nv sh = do
+pokeJustV cp ptr nv sh = do
-    pokeElemOff ptr (off 0) x
+    zipWithM_ f [0..] [x,y,z,1,r,g,b,a,nx,ny,nz,1]
-    pokeElemOff ptr (off 1) y
-    pokeElemOff ptr (off 2) z
-    pokeElemOff ptr (off 3) 0
-    pokeElemOff ptr (off 4) r
-    pokeElemOff ptr (off 5) g
-    pokeElemOff ptr (off 6) b
-    pokeElemOff ptr (off 7) a
     return (nv + 1)
   where
-    off i = nv*nShapeVerxComp + i
+    f i = pokeElemOff ptr (nv*nShapeVerxComp + i)
     V3 x y z    = _svPos sh
     V4 r g b a  = _svCol sh
+    V3 nx ny nz = cp
+    --nx = x
+    --ny = y
+    --nz = z - 1
 
 pokeLayVerxs 
     :: MV.MVector (PrimState IO) (FullShader ,VBO)

src/Shape/Data.hs

@@ -44,12 +44,11 @@ pairToSV = uncurry ShapeV
 makeLenses ''ShapeV
 makeLenses ''ShapeObj
 makeLenses ''ShapeType
---type Shape' = Stream (Of ShapeObj) IO ()
 
 type Shape = [ShapeObj]
 
 nShapeVerxComp :: Int
-nShapeVerxComp = 8
+nShapeVerxComp = 12
 
 deriveJSON defaultOptions ''ShapeType
 deriveJSON defaultOptions ''ShapeV