justin/loop
1
0
Fork 0
Code Issues Pull Requests 1 Packages Projects Releases Wiki Activity

Implement low res shadows

Browse Source
This commit is contained in:
jgk
2021-04-28 20:50:53 +02:00
parent 5a8555d5a0
commit 8cb177a21c
11 changed files with 147 additions and 77 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Config/Data.hs
+3
View File
@@ -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
+4 -5
View File
@@ -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
@@ -58,10 +59,8 @@ handlePressedKeyInMenu mState scode w = case mState of
startLevel = unpause . storeLevel
dec x = max 0 (x - 0.1)
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 :)
pushMenu ml w = Just $ w & menuLayers %~ (ml :)
popMenu w = Just $ w & menuLayers %~ tail
sw = w & sideEffects %~ (setVol (_config w) : )
startNewGame = Just $ generateFromList levx
$ initialWorld
src/Dodge/Render.hs
+49 -12
View File
@@ -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
src/Dodge/Render/MenuScreen.hs
+1 -1
View File
@@ -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
+9 -10
View File
@@ -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 w =
let rot = _cameraRot w
zoom = _cameraZoom w
(tranx,trany) = _cameraCenter w
(winx,winy) = (_windowX w,_windowY w)
(viewFromx,viewFromy) = _cameraViewFrom w
scalMat = Linear.Matrix.transpose $ V4
perspectiveMatrix
:: Float -- ^ Rotation
-> Float -- ^ Zoom
-> Point2 -- ^ Translation
-> Point2 -- ^ Window size
-> Point2 -- ^ View froms
-> [GLfloat]
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
+20 -13
View File
@@ -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
wlFace <- makeShader "wall/blank" [vert,geom,frag] [(0,4),(1,4)] Points pokeWPColStrat
-- blank wallShader
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"]
@@ -80,16 +85,17 @@ preloadRender = do
bindFramebuffer Framebuffer $= defaultFramebufferObject
return $ RenderData
{ _pictureShaders = [bslist,lslist,cslist,aslist,eslist,bezierQuadShader]
, _lightingFloorShader = lsShad
, _lightingOccludeShader = wsShad
, _lightingWallShader = wlLightShad
, _wallFaceShader = wlFace
, _backgroundShader = bgShad
, _fullscreenShader = fsShad
, _spareFBO = fbo
, _fboTexture = fboTO
, _fboRenderbufferObject = fboRBO
{ _pictureShaders = [bslist,lslist,cslist,aslist,eslist,bezierQuadShader]
, _lightingFloorShader = lsShad
, _lightingOccludeShader = wsShad
, _lightingWallShader = wlLightShad
, _wallBlankShader = wlBlank
, _wallTextureShader = wlTexture
, _backgroundShader = bgShad
, _fullscreenShader = fsShad
, _spareFBO = fbo
, _fboTexture = fboTO
, _fboRenderbufferObject = fboRBO
}
-- potential drawing setup
@@ -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
+45 -19
View File
@@ -25,17 +25,12 @@ import Data.Maybe (fromJust)
import qualified Data.IntMap.Strict as IM
import qualified SDL
renderWalls :: RenderData -> [((Point2,Point2),Point4)] -> GLmatrix GLfloat -> IO ()
renderWalls pdata wps pmat = do
n <- F.foldM (pokeShader $ _wallFaceShader pdata) wps
bindShaderBuffers [_wallFaceShader pdata] [n]
currentProgram $= Just (_shaderProgram $ _wallFaceShader pdata)
uniform (head (fromJust $ _shaderCustomUnis $ _wallFaceShader pdata) )
$= pmat
drawShader (_wallFaceShader pdata) n
setWallDepth :: RenderData -> [(Point2,Point2)] -> (Float,Float) -> GLmatrix GLfloat -> IO Word32
setWallDepth
:: RenderData
-> [(Point2,Point2)] -- ^ Wall points
-> (Float,Float) -- ^ View from point
-> 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 :: Ptr Float -> Int -> (Float,Float) -> IO ()
pokeTwoOff
:: 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
+2 -2
View File
@@ -14,8 +14,8 @@ resizeSpareFBO xsize ysize pdata = do
fboName = _spareFBO rdata
fboTO = _fboTexture rdata
fboRBO = _fboRenderbufferObject rdata
xsize' = fromIntegral xsize
ysize' = fromIntegral ysize
xsize' = fromIntegral $ xsize `div` 2
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)