Implement low res shadows

src/Dodge/Render.hs

@@ -4,6 +4,7 @@ module Dodge.Render
     )
   where
 import Dodge.Data
+import Dodge.Config.Data
 import Dodge.Base
 import Dodge.Render.HUD
 import Dodge.Render.MenuScreen
@@ -15,22 +16,23 @@ import Picture.Render
 import Picture.Preload
 import Shader
 
-import Data.Graph.Inductive.Query.DFS
-import Data.Graph.Inductive.Graph
+import Foreign (Word32)
+import Control.Applicative
 import Control.Monad.State
+import Control.Lens
+import qualified Control.Foldl as F
+import Data.Maybe
 import Data.List
 import Data.Bifunctor
 import Data.Function
-import Foreign (Word32)
-import Control.Applicative
-import Control.Lens
-import Data.Maybe
 import qualified Data.IntMap.Strict as IM
 import qualified Data.Map as M
 import qualified Data.Set as S
 import Graphics.Rendering.OpenGL hiding (color,scale,translate,rotate)
 import qualified SDL
 
+halfwindow = over windowX ( / 2) . over windowY ( / 2)
+
 doDrawing :: RenderData -> World -> IO (Word32)
 doDrawing pdata w = do
     sTicks <- SDL.ticks
@@ -47,28 +49,33 @@ doDrawing pdata w = do
         wallPoints = map fst wallPointsCol
     setCommonUniforms pdata rot zoom trans wins
     depthFunc $= Just Less
-    pmat <- (newMatrix RowMajor $ perspectiveMatrix w) :: IO (GLmatrix GLfloat)
+    pmat <- (newMatrix RowMajor $ perspectiveMatrix rot zoom trans wins viewFroms) 
+                :: IO (GLmatrix GLfloat)
+--    pmat2 <- (newMatrix RowMajor $ perspectiveMatrix $ halfwindow w) :: IO (GLmatrix GLfloat)
     createLightMap pdata rot zoom trans wins wallPoints lightPoints viewFroms pmat
     blendFuncSeparate    $= ((SrcAlphaSaturate, OneMinusSrcAlpha), (Zero,One))
 --    clear [DepthBuffer]
     depthFunc $= Just Always
     renderBackground pdata rot zoom trans wins
-    depthFunc $= Just Lequal
---    depthFunc $= Just Less
-    renderWalls pdata wallPointsCol pmat
-    setWallDepth pdata wallPoints (viewFromx,viewFromy) pmat
+    depthFunc $= Just Less
+    if w ^. config . wall_textured
+        then renderTextureWalls pdata wallPointsCol pmat
+        else renderBlankWalls pdata wallPointsCol pmat
+-- I believe a more apt name would be setCeilingDepth
+--    setWallDepth pdata wallPoints (viewFromx,viewFromy) pmat
 --    depthFunc $= Just Lequal
     renderFoldable pdata $ picToLTree (Just 0) pic
 -- reset blend so that light map doesn't apply
 --    blendFunc $= (SrcAlpha,OneMinusSrcAlpha)
     blendFuncSeparate $= ((SrcAlpha,OneMinusSrcAlpha) , (Zero,One))
 --    blendFunc $= (SrcAlpha,OneMinusSrcAlpha)
+    depthFunc $= Just Lequal
     renderFoldable pdata $ picToLTree (Just 1) pic
 -- set drawing for on top
     blendFuncSeparate    $= ((SrcAlphaSaturate, OneMinusSrcAlpha), (Zero,One))
     renderFoldable pdata $ picToLTree (Just 2) pic
     depthMask $= Disabled
-    renderWalls pdata windowPoints pmat
+    renderBlankWalls pdata windowPoints pmat
     depthMask $= Enabled
     resetShaderUniforms (map extractProgAndUnis $ _pictureShaders pdata)
 ----------------------
@@ -76,3 +83,33 @@ doDrawing pdata w = do
     renderFoldable pdata (picToLTree Nothing $ fixedCoordPictures w)
     eTicks <- SDL.ticks
     return (eTicks - sTicks)
+
+renderBlankWalls 
+    :: RenderData 
+    -> [((Point2,Point2),Point4)]   -- ^ List: wall positions and color
+    -> GLmatrix GLfloat 
+    -> IO ()
+renderBlankWalls pdata wps pmat = do
+    n <- F.foldM (pokeShader $ _wallBlankShader pdata) wps
+    bindShaderBuffers [_wallBlankShader pdata] [n]
+    currentProgram $= Just (_shaderProgram $ _wallBlankShader pdata)
+    uniform (head (fromJust $ _shaderCustomUnis $ _wallBlankShader pdata) )
+            $= pmat
+    cullFace $= Just Back
+    drawShader (_wallBlankShader pdata) n
+    cullFace $= Nothing
+
+renderTextureWalls 
+    :: RenderData 
+    -> [((Point2,Point2),Point4)]   -- ^ List: wall positions and color
+    -> GLmatrix GLfloat 
+    -> IO ()
+renderTextureWalls pdata wps pmat = do
+    n <- F.foldM (pokeShader $ _wallTextureShader pdata) wps
+    bindShaderBuffers [_wallTextureShader pdata] [n]
+    currentProgram $= Just (_shaderProgram $ _wallTextureShader pdata)
+    uniform (head (fromJust $ _shaderCustomUnis $ _wallTextureShader pdata) )
+            $= pmat
+    cullFace $= Just Back
+    drawShader (_wallTextureShader pdata) n
+    cullFace $= Nothing