Commit before changes to wallShadow shaders

shader/wall.frag

@@ -4,6 +4,5 @@ out vec4 fColor;
 
 void main()
 {
-  fColor = vec4 (0.9,0.5,0,1);
   fColor = vParams;
 }

src/Picture/Render.hs

@@ -59,6 +59,7 @@ renderPicture' pdata rot zoom (tranx,trany) (winx,winy) wallPoints lightPoints p
     clear [ColorBuffer]
 --    depthMask $= Enabled
 
+--    nBoxWalls <- F.foldM (pokeShader (_wallShader pdata)) $ concat $ mkShadFromWall <$> wallPoints <*> lightPoints
     nWalls <- F.foldM (pokeShader (_wallShadowShader pdata)) wallPoints
     bindShaderBuffers [_wallShadowShader pdata] [nWalls]
 
@@ -155,24 +156,27 @@ renderPicture' pdata rot zoom (tranx,trany) (winx,winy) wallPoints lightPoints p
     ticks4 <- renderFoldable pdata rot zoom (tranx,trany) (winx,winy) $ picToLTree (Just 2) pic
     bticks <- SDL.ticks
 
--- -- render walls
---     depthFunc $= Nothing
---     blendFunc $= (SrcAlpha,OneMinusSrcAlpha)
---     -- poke data
---     let lights = map (\(x,y,r,g) -> ((x,y),(r,g,0,0))) lightPoints
---         wallPairs = map (\(a,b,_,_) -> [(a,(1,1,1,1)),(b,(1,1,1,1))]) wallPoints
---         f (x,y) = [(x,y,0),(x,y,0),(x,y,-1)]
---         g (x,y) = [(x,y,0),(x,y,-1),(x,y,-1)]
---         wp = concatMap (\(a,b,_,_) -> f a ++ g b) wallPoints
---         h p = (p,(1,0,0,1))
---     i <- F.foldM (pokeShader (_wallShader pdata)) $ map h wp
--- 
---     -- bind buffers
---     bindShaderBuffers [_wallShader pdata] [i]
--- 
---     -- draw call
---     drawShaders [_wallShader pdata] [i]
---     depthFunc $= Just Lequal
+-- render walls
+--    depthFunc $= Nothing
+--    blendFunc $= (SrcAlpha,OneMinusSrcAlpha)
+--    -- poke data
+--    cullFace $= Just Back
+--    let lights = map (\(x,y,r,g) -> ((x,y),(r,g,0,0))) lightPoints
+--        wallPairs = map (\(a,b,_,_) -> [(a,(1,1,1,1)),(b,(1,1,1,1))]) wallPoints
+--        f (x,y) = [(x,y,0),(x,y,0),(x,y,-1)]
+--        g (x,y) = [(x,y,0),(x,y,-1),(x,y,-1)]
+--        wp = concatMap (\(a,b,_,_) -> f a ++ g b) wallPoints
+--        h p = (p,(1,0,0,1))
+--        wp2 = ((200,200),(-200,200),(0,0),(0,0))
+--        wp3 = ((-200,200),(-200,-200),(0,0),(0,0))
+--    i <- F.foldM (pokeShader (_wallShader pdata)) $ concat $ mkShadFromWall <$> [wp2,wp3] <*> [(300,50,200,0)]
+--
+--    -- bind buffers
+--    bindShaderBuffers [_wallShader pdata] [i]
+--
+--    -- draw call
+--    drawShaders [_wallShader pdata] [i]
+--    depthFunc $= Just Lequal
 
 ------    blendFunc $= (One,Zero)
 ------    let f (x,y) = (x,y,0)
@@ -238,3 +242,33 @@ pokeFourOff ptr n (x,y,z,w) = do
     pokeElemOff ptr (4*n+2) z
     pokeElemOff ptr (4*n+3) w
 
+mkShadFromWall :: (Point2,Point2,Point2,Point2) -> Point4 -> [(Point3,Point4)]
+{-# INLINE mkShadFromWall #-}
+mkShadFromWall (wla,wlb,_,_) (x,y,r,_) 
+    = makeHexahedron $ prismQuad (f wla
+                                 ,f wlb
+                                 ,f $ wla +.+ r *.* normalizeV (wla -.- ls)
+                                 ,f $ wlb +.+ r *.* normalizeV (wlb -.- ls)
+                                 )
+        where f (x,y) = (x,y,0)
+              ls = (x,y)
+
+prismQuad :: (Point3,Point3,Point3,Point3) -> 
+                (Point3,Point3,Point3,Point3
+                ,Point3,Point3,Point3,Point3)
+{-# INLINE prismQuad #-}
+prismQuad (a,b,c,d) = (a,b,c,d,f a,f b,f d,f c)
+    where f (x,y,z) = (x,y,z-0.5)
+
+-- note this doubles the first and last points, assumes these points will be
+-- input as part of a triangle strip
+makeHexahedron :: (Point3,Point3,Point3,Point3
+                    ,Point3,Point3,Point3,Point3) -> [(Point3,Point4)]
+{-# INLINE makeHexahedron #-}
+makeHexahedron (a1,a2,a3,a4,a5,a6,a7,a8)
+        = [cr a4 ,cr a4 ,cr a3 ,cr a7 ,cr a8 
+          ,cr a5 ,cr a3 ,cb a1 ,cb a4 ,cr a2 ,cr a7 ,cr a6 ,cr a5 ,cr a2 ,cr a1 ,cr a1 ]
+    where col = (1,0,1,0.1)
+          cr a = (a,(1,0,0,0.1))
+          cg a = (a,(0,1,0,0.1))
+          cb a = (a,(0,0,1,0.1))