Implement low res shadows

shader/lighting/floor.frag

@@ -1,5 +1,4 @@
 #version 430 core
-in vec2 cenPosT;
 in float lum;
 
 in vec2 dField;

shader/lighting/floor.geom

@@ -1,33 +1,34 @@
 #version 430 core
 layout (points) in;
 layout (triangle_strip, max_vertices = 4) out;
-in vec2 vParams [];
 out float lum;
-out vec2 cenPosT;
 out vec2 dField;
 
 uniform vec2 winSize;
 uniform float zoom;
+uniform mat4 worldMat;
 
 void main()
 {
-  lum = vParams[0].y;
+  lum = gl_in[0].gl_Position.w;
-  vec3 cenPos = gl_in[0].gl_Position.xyz;
+  vec2 cenPos = vec2( gl_in[0].gl_Position.x / 2, gl_in[0].gl_Position.y / 2);
-  float gRad = vParams[0].x * zoom * 2;
+  float gRad = gl_in[0].gl_Position.z * zoom * 2;
-
-  cenPosT = vec2 ( (cenPos.x + 1) * 0.5 * winSize.x , (cenPos.y + 1) * 0.5 * winSize.y);
 
   dField = vec2 ( 1, 1);
-  gl_Position = vec4 (cenPos.x + gRad/winSize.x, cenPos.y + gRad/winSize.y, -0 , 1);
+  gl_Position 
+      = vec4 (cenPos.x + gRad/winSize.x, cenPos.y + gRad/winSize.y, -0 , 1);
   EmitVertex();
   dField = vec2 (-1, 1);
-  gl_Position = vec4 (cenPos.x - gRad/winSize.x, cenPos.y + gRad/winSize.y, -0 , 1);
+  gl_Position 
+      = vec4 (cenPos.x - gRad/winSize.x, cenPos.y + gRad/winSize.y, -0 , 1);
   EmitVertex();
   dField = vec2 ( 1,-1);
-  gl_Position = vec4 (cenPos.x + gRad/winSize.x, cenPos.y - gRad/winSize.y, -0 , 1);
+  gl_Position 
+      = vec4 (cenPos.x + gRad/winSize.x, cenPos.y - gRad/winSize.y, -0 , 1);
   EmitVertex();
   dField = vec2 (-1,-1);
-  gl_Position = vec4 (cenPos.x - gRad/winSize.x, cenPos.y - gRad/winSize.y, -0 , 1);
+  gl_Position 
+      = vec4 (cenPos.x - gRad/winSize.x, cenPos.y - gRad/winSize.y, -0 , 1);
   EmitVertex();
 
   EndPrimitive();

shader/lighting/floor.vert

@@ -1,6 +1,6 @@
 #version 430 core
 layout (location = 0) in vec4 position;
-out vec2 vParams;
+//out vec2 vParams;
 
 uniform vec2 winSize;
 uniform float zoom;
@@ -10,6 +10,5 @@ uniform mat4 worldMat;
 
 void main()
 {
-  gl_Position = vec4(position.xy,0,1);
+  gl_Position = position;
-  vParams = position.zw;
 }

src/Dodge/Config/Data.hs

@@ -7,6 +7,7 @@ module Dodge.Config.Data (
     , volume_master
     , volume_sound
     , volume_music
+    , wall_textured
     ) where
 
 import Data.Aeson
@@ -21,6 +22,7 @@ data Configuration = Configuration
   { _volume_master   :: Float
   , _volume_sound    :: Float
   , _volume_music    :: Float
+  , _wall_textured   :: Bool
   }
   deriving (Generic, Show)
 
@@ -35,5 +37,6 @@ defaultConfig = Configuration
     { _volume_master = 1
     , _volume_sound  = 1
     , _volume_music  = 1
+    , _wall_textured = False
     }
  

src/Dodge/Event/Menu.hs

@@ -49,7 +49,8 @@ handlePressedKeyInMenu mState scode w = case mState of
         ScancodeM       -> Just $ sw & config . volume_music  %~ inc
         _               -> popMenu $ w & sideEffects %~ (saveConfig (_config w) :)
     GraphicsOptionMenu -> case scode of
-        _ -> popMenu w
+        ScancodeW       -> Just $ w & config . wall_textured %~ not
+        _ -> popMenu $ w & sideEffects %~ (saveConfig (_config w) :)
     ControlList -> Just $ w & menuLayers %~ tail
     _ -> Just w
   where 
@@ -60,8 +61,6 @@ handlePressedKeyInMenu mState scode w = case mState of
     inc x = min 1 (x + 0.1)
     pushMenu ml w   = Just $ w & menuLayers %~ (ml :)
     popMenu w       = Just $ w & menuLayers %~ tail
-    goToOptionMenu w = Just $ w & menuLayers %~ (OptionMenu :)
-    goToControls w = Just $ w & menuLayers %~ (ControlList :)
     sw = w & sideEffects %~ (setVol (_config w) : )
     startNewGame = Just $ generateFromList levx 
         $ initialWorld 

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 Foreign (Word32)
-import Data.Graph.Inductive.Graph
+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
---    depthFunc $= Just Less
+    if w ^. config . wall_textured
-    renderWalls pdata wallPointsCol pmat
+        then renderTextureWalls pdata wallPointsCol pmat
-    setWallDepth pdata wallPoints (viewFromx,viewFromy) 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

src/Dodge/Render/MenuScreen.hs

@@ -42,7 +42,7 @@ menuScreen cfig hw hh mLays = case mLays of
         ,"n - MUSIC  VOLUME + m : " ++ muvol
         ]
     (GraphicsOptionMenu : _) -> optionsList hw hh "OPTIONS:GRAPHICS" 
-        ["w - WALL TEXTURES"
+        ["w - WALL TEXTURES:" ++ show (_wall_textured cfig)
         ]
     (ControlList : _) -> pictures 
         [color (withAlpha 0.5 black) $ polygon $ screenBox hw hh

src/Dodge/Render/PerspectiveMatrix.hs

@@ -1,21 +1,20 @@
 module Dodge.Render.PerspectiveMatrix
     where
-import Dodge.Data
-
 import Geometry
 
 import Linear.Matrix
 import Linear.V4
 import Graphics.Rendering.OpenGL (GLfloat)
 
-perspectiveMatrix :: World -> [GLfloat]
+perspectiveMatrix 
-perspectiveMatrix w =
+    :: Float        -- ^ Rotation
-    let rot     = _cameraRot w
+    -> Float        -- ^ Zoom
-        zoom    = _cameraZoom w
+    -> Point2       -- ^ Translation
-        (tranx,trany)   = _cameraCenter w
+    -> Point2       -- ^ Window size
-        (winx,winy)     = (_windowX w,_windowY w)
+    -> Point2       -- ^ View froms
-        (viewFromx,viewFromy)   = _cameraViewFrom w
+    -> [GLfloat]
-        scalMat = Linear.Matrix.transpose $ V4 
+perspectiveMatrix rot zoom (tranx,trany) (winx,winy) (viewFromx,viewFromy) =
+    let scalMat = Linear.Matrix.transpose $ V4 
             (V4 (2*zoom/winx) 0             0   (0::GLfloat))
             (V4 0             (2*zoom/winy) 0   0)
             (V4 0             0             0.5 0) --scaled to make walls shorter

src/Picture/Preload.hs

@@ -21,7 +21,8 @@ data RenderData = RenderData
     { _lightingFloorShader :: FullShader (Float,Float,Float,Float)
     , _lightingOccludeShader  :: FullShader (Point2,Point2)
     , _lightingWallShader   :: FullShader (Point2,Point2)
-    , _wallFaceShader    :: FullShader ((Point2,Point2),Point4)
+    , _wallBlankShader    :: FullShader ((Point2,Point2),Point4)
+    , _wallTextureShader    :: FullShader ((Point2,Point2),Point4)
     , _backgroundShader  :: FullShader (Point2,Point2,Point2,Point2)
     , _fullscreenShader  :: FullShader ()
     , _pictureShaders :: [FullShader RenderType]
@@ -68,8 +69,12 @@ preloadRender = do
     bgShad <- makeShader "background" [vert,geom,frag] [(0,4),(1,2)] Points pokeBGStrat
                 >>= addTexture "data/texture/smudgedDirt.png"
 
--- wallShader
+-- blank wallShader
-    wlFace <- makeShader "wall/blank" [vert,geom,frag] [(0,4),(1,4)] Points pokeWPColStrat
+    wlBlank <- makeShader "wall/blank" [vert,geom,frag] [(0,4),(1,4)] Points pokeWPColStrat
+--                >>= addTexture "data/texture/grayscaleDirt.png"
+                >>= addUniforms ["perpMat"]
+-- textured wallShader
+    wlTexture <- makeShader "wall/texture" [vert,geom,frag] [(0,4),(1,4)] Points pokeWPColStrat
                 >>= addTexture "data/texture/grayscaleDirt.png"
                 >>= addUniforms ["perpMat"]
 
@@ -84,7 +89,8 @@ preloadRender = do
         , _lightingFloorShader      = lsShad
         , _lightingOccludeShader    = wsShad
         , _lightingWallShader       = wlLightShad
-        , _wallFaceShader       = wlFace
+        , _wallBlankShader          = wlBlank
+        , _wallTextureShader        = wlTexture
         , _backgroundShader         = bgShad
         , _fullscreenShader         = fsShad
         , _spareFBO                 = fbo
@@ -113,6 +119,7 @@ setupFramebuffer = do
     fboTO <- genObjectName
     textureBinding Texture2D $= Just fboTO
     texImage2D Texture2D NoProxy 0 RGBA8 (TextureSize2D 800 600) 0 (PixelData RGBA UnsignedByte nullPtr)
+    texImage2D Texture2D NoProxy 0 RGBA8 (TextureSize2D 8 6) 0 (PixelData RGBA UnsignedByte nullPtr)
     textureFilter Texture2D $= ((Linear',Just Linear') , Nearest)
     generateMipmap' Texture2D
     framebufferTexture2D Framebuffer (ColorAttachment 0) Texture2D fboTO 0

src/Picture/Render.hs

@@ -25,17 +25,12 @@ import Data.Maybe (fromJust)
 import qualified Data.IntMap.Strict as IM
 import qualified SDL
 
-
+setWallDepth
-renderWalls :: RenderData -> [((Point2,Point2),Point4)] -> GLmatrix GLfloat -> IO ()
+    :: RenderData
-renderWalls pdata wps pmat = do
+    -> [(Point2,Point2)]    -- ^ Wall points
-    n <- F.foldM (pokeShader $ _wallFaceShader pdata) wps
+    -> (Float,Float)        -- ^ View from point
-    bindShaderBuffers [_wallFaceShader pdata] [n]
+    -> GLmatrix GLfloat
-    currentProgram $= Just (_shaderProgram $ _wallFaceShader pdata)
+    -> IO Word32
-    uniform (head (fromJust $ _shaderCustomUnis $ _wallFaceShader pdata) )
-            $= pmat
-    drawShader (_wallFaceShader pdata) n
-
-setWallDepth :: RenderData -> [(Point2,Point2)] -> (Float,Float) -> GLmatrix GLfloat -> IO Word32
 setWallDepth pdata wallPoints (viewFromx,viewFromy) pmat = do
     startTicks <- SDL.ticks
     colorMask $= Color4 Disabled Disabled Disabled Disabled
@@ -55,6 +50,8 @@ setWallDepth pdata wallPoints (viewFromx,viewFromy) pmat = do
     endTicks <- SDL.ticks
     return $ endTicks - startTicks
 
+halfSize (Size x y) = Size (div x 2) (div y 2)
+
 createLightMap 
     :: RenderData 
     -> Float                -- Rotation
@@ -66,8 +63,13 @@ createLightMap
     -> (Float,Float)        -- View from position
     -> GLmatrix GLfloat 
     -> IO ()
-createLightMap pdata rot zoom (tranx,trany) (winx,winy) wallPoints lightPoints
+createLightMap pdata rot zoom (tranx,trany) (winx',winy') wallPoints lightPoints
                     (viewFromx,viewFromy) pmat = do
+    let winx = winx' / 2
+        winy = winy' / 2
+
+    (vppos,vpsize) <- get viewport
+    viewport $= (vppos, halfSize vpsize)
 
     bindFramebuffer Framebuffer $= _spareFBO pdata
 -- store wall and light positions into buffer
@@ -140,6 +142,7 @@ createLightMap pdata rot zoom (tranx,trany) (winx,winy) wallPoints lightPoints
     cullFace $= Nothing
     stencilTest $= Disabled
     blend $= Disabled
+    viewport $= (vppos, vpsize)
     bindFramebuffer Framebuffer $= defaultFramebufferObject
     colorMask $= Color4 Disabled Disabled Disabled Enabled
     bindShaderBuffers [_fullscreenShader pdata] [4]
@@ -148,7 +151,13 @@ createLightMap pdata rot zoom (tranx,trany) (winx,winy) wallPoints lightPoints
     colorMask $= Color4 Enabled Enabled Enabled Enabled
     blend $= Enabled
 
-renderBackground :: RenderData -> Float -> Float -> (Float,Float) -> (Float,Float) -> IO ()
+renderBackground 
+    :: RenderData 
+    -> Float            -- Rotation
+    -> Float            -- Zoom
+    -> (Float,Float)    -- Translation
+    -> (Float,Float)    -- Window size
+    -> IO ()
 renderBackground pdata rot zoom (tranx,trany) (winx,winy) = do
 --    depthFunc $= Just Less
 -- set drawing for on top
@@ -164,7 +173,13 @@ renderBackground pdata rot zoom (tranx,trany) (winx,winy) = do
     textureBinding Texture2D $= _textureObject <$> _shaderTexture (_backgroundShader pdata)
     drawArrays Points 0 1
 
-setCommonUniforms :: RenderData -> Float -> Float -> (Float,Float) -> (Float,Float) -> IO ()
+setCommonUniforms
+    :: RenderData
+    -> Float            -- ^ Rotation
+    -> Float            -- ^ Zoom
+    -> (Float,Float)    -- ^ Translation
+    -> (Float,Float)    -- ^ Window size
+    -> IO ()
 setCommonUniforms pdata rot zoom (tranx,trany) (winx,winy) = do
     setShaderUniforms rot zoom (tranx,trany) (winx,winy) 
         ( extractProgAndUnis (_lightingFloorShader pdata) 
@@ -174,7 +189,11 @@ setCommonUniforms pdata rot zoom (tranx,trany) (winx,winy) = do
         : map extractProgAndUnis (_pictureShaders pdata)
         )
 
-renderFoldable :: Foldable f => RenderData -> f RenderType -> IO Word32
+renderFoldable
+    :: Foldable f
+    => RenderData
+    -> f RenderType
+    -> IO Word32
 renderFoldable pdata tree = do
     pokeStartTicks <- SDL.ticks
 
@@ -183,7 +202,7 @@ renderFoldable pdata tree = do
 -- poke data, returns list of number of vertices for each shader
     is <- F.foldM (pokeShaders slist) tree
 
--- the idea of doing as binding of buffers at once, rather than interweaving with draw
+-- the idea of binding many buffers at once, rather than interweaving with draw
 -- calls, is to prevent opengl from waiting for a draw call to finish
 -- before it performs another state change
     bindShaderBuffers slist is
@@ -194,13 +213,20 @@ renderFoldable pdata tree = do
     return $ pokeEndTicks - pokeStartTicks
 ------------------------------end renderFoldable
 
-
+pokeTwoOff 
-pokeTwoOff :: Ptr Float -> Int -> (Float,Float) -> IO ()
+    :: Ptr Float 
+    -> Int 
+    -> (Float,Float) 
+    -> IO ()
 {-# INLINE pokeTwoOff #-}
 pokeTwoOff ptr n (x,y) = do
     pokeElemOff ptr (2*n+0) x
     pokeElemOff ptr (2*n+1) y
-pokeThreeOff :: Ptr Float -> Int -> (Float,Float,Float) -> IO ()
+pokeThreeOff 
+    :: Ptr Float 
+    -> Int 
+    -> (Float,Float,Float) 
+    -> IO ()
 {-# INLINE pokeThreeOff #-}
 pokeThreeOff ptr n (x,y,z) = do
     pokeElemOff ptr (3*n+0) x

src/Preload/Update.hs

@@ -14,8 +14,8 @@ resizeSpareFBO xsize ysize pdata = do
         fboName = _spareFBO rdata
         fboTO   = _fboTexture rdata
         fboRBO  = _fboRenderbufferObject rdata
-        xsize' = fromIntegral xsize
+        xsize' = fromIntegral $ xsize `div` 2
-        ysize' = fromIntegral ysize
+        ysize' = fromIntegral $ ysize `div` 2
     bindFramebuffer Framebuffer $= fboName
     textureBinding Texture2D $= Just fboTO
     texImage2D Texture2D NoProxy 0 RGBA8 (TextureSize2D xsize' ysize') 0 (PixelData RGBA UnsignedByte nullPtr)