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

Reorganise rendering in Dodge

Browse Source
This commit is contained in:
jgk
2021-04-01 11:28:53 +02:00
parent e62ff391a5
commit 1e9a07d1c8
13 changed files with 217 additions and 113 deletions
Download Patch File Download Diff File Expand all files Collapse all files
app/Main.hs
+2 -62
View File
@@ -10,7 +10,7 @@ import Dodge.Layout
import Dodge.LoadSound
import Dodge.Update
import Dodge.Event
import Dodge.Rendering
import Dodge.Render
import Dodge.Menu
import Dodge.Floor
import Dodge.LoadConfig
@@ -53,7 +53,7 @@ main = do
(fmap (setWindowSize sizex sizey keyConfig) firstWorld)
( \preData w -> do
startTicks <- SDL.ticks
doTheRender preData w
doDrawing (_renderData preData) w
playSoundQueue (_soundData preData) (_soundQueue w)
newSoundData <- playAndUpdate (_sounds w) (_soundData preData)
@@ -81,63 +81,3 @@ setWindowSize :: Int -> Int -> KeyConfigSDL-> World -> World
setWindowSize x y z w = w & windowX .~ fromIntegral x
& windowY .~ fromIntegral y
& keyConfig .~ z
doTheRender :: PreloadData a -> World -> IO (Word32)
doTheRender preData w = do
sTicks <- SDL.ticks
clear [ColorBuffer,DepthBuffer]
let pdata = _renderData preData
rot = _cameraRot w
zoom = _cameraZoom w
trans@(tranx,trany) = _cameraCenter w
wins@(winx,winy) = (_windowX w,_windowY w)
wallPointsCol = wallsPointsAndCols w
windowPoints = wallsWindows w
lightPoints = lightsForGloom' w
viewFroms@(viewFromx,viewFromy) = _cameraViewFrom w
pic = worldPictures w
let wallPoints = map fst wallPointsCol
setCommonUniforms pdata rot zoom trans wins
depthFunc $= Just Less
pmat <- (newMatrix RowMajor
$ perspectiveMatrix rot zoom (tranx,trany) (winx,winy) (viewFromx,viewFromy)
) :: IO (GLmatrix GLfloat)
createLightMap pdata rot zoom trans wins wallPoints lightPoints viewFroms pmat
blendFuncSeparate $= ((SrcAlphaSaturate, OneMinusSrcAlpha), (Zero,One))
clear [DepthBuffer]
renderBackground pdata rot zoom trans wins
renderWalls pdata wallPointsCol pmat
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)
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
depthMask $= Enabled
resetShaderUniforms (map extractProgAndUnis $ _listShaders pdata)
----------------------
blendFunc $= (SrcAlpha,OneMinusSrcAlpha)
renderFoldable (_renderData preData) (picToLTree Nothing $ fixedCoordPictures w)
eTicks <- SDL.ticks
return (eTicks - sTicks)
package.yaml
+20
View File
@@ -79,3 +79,23 @@ tests:
- -with-rtsopts=-N
dependencies:
- loop
benchmarks:
loop-benchmarks:
dependencies:
- criterion
ghc-options:
- -threaded
- -O2
- -rtsopts
- -with-rtsopts=-N
- -flate-dmd-anal
- -fno-liberate-case
- -fno-state-hack
- -funfolding-use-threshold1000
- -funfolding-keeness-factor1000
- -fllvm
- -optlo-O3
main: Bench.hs
source-dirs: bench
src/Dodge/Base.hs
+6 -5
View File
@@ -280,6 +280,12 @@ zoneOfLine :: Point2 -> Point2 -> [(Int,Int)]
zoneOfLine (aa,ab) (ba,bb) = nub $ concatMap f
$ digitalLine (zoneOfPoint (aa,ab)) (zoneOfPoint (ba,bb))
where f (x,y) = [(p,r) | p <-[x-1,x,x+1] , r<-[y-1,y,y+1]]
zoneOfLine' :: Point2 -> Point2 -> IM.IntMap IS.IntSet
{-# INLINE zoneOfLine' #-}
zoneOfLine' a b = expandLine $ digitalLine (x-1,y-1) (x'-1,y'-1)
where (x,y) = zoneOfPoint a
(x',y') = zoneOfPoint b
--zoneOfLine (aa,ab) (ba,bb) = nub $ concatMap f
-- $ digitalLine (zoneOfPoint (aa-n,ab-n)) (zoneOfPoint (ba-n,bb-n))
-- where f (x,y) = [(p,r) | p <-[x,x+1] , r<-[y,y+1]]
@@ -294,11 +300,6 @@ expandLine xs = IM.map expandSet
--expandSet s = s
where mk = IS.findMax s
zoneOfLine' :: Point2 -> Point2 -> IM.IntMap IS.IntSet
{-# INLINE zoneOfLine' #-}
zoneOfLine' a b = expandLine $ digitalLine (x-1,y-1) (x'-1,y'-1)
where (x,y) = zoneOfPoint a
(x',y') = zoneOfPoint b
--zoneOfLine a b = concatMap zoneNearPoint $ divideLine (2 * zoneSize) a b
--zoneOfLine a b = concatMap zoneNearPoint $ divideLine zoneSize a b
src/Dodge/Render.hs
+122
View File
@@ -0,0 +1,122 @@
module Dodge.Render
( module Dodge.Render.Picture
, doDrawing
, doDrawing'
)
where
import Dodge.Data
import Dodge.Base
import Dodge.Render.HUD
import Dodge.Render.MenuScreen
import Dodge.Render.Picture
import Dodge.Render.PerspectiveMatrix
import Geometry
import Picture
import Shader
import Picture.Render
import Picture.Preload
import Data.Graph.Inductive.Query.DFS
import Data.Graph.Inductive.Graph
import Control.Monad.State
import Data.List
import Data.Bifunctor
import Foreign (Word32)
import Data.Function
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
doDrawing :: RenderData -> World -> IO (Word32)
doDrawing pdata w = do
sTicks <- SDL.ticks
clear [ColorBuffer,DepthBuffer]
let rot = _cameraRot w
zoom = _cameraZoom w
trans@(tranx,trany) = _cameraCenter w
wins@(winx,winy) = (_windowX w,_windowY w)
wallPointsCol = wallsPointsAndCols w
windowPoints = wallsWindows w
lightPoints = lightsForGloom' w
viewFroms@(viewFromx,viewFromy) = _cameraViewFrom w
pic = worldPictures w
wallPoints = map fst wallPointsCol
setCommonUniforms pdata rot zoom trans wins
depthFunc $= Just Less
pmat <- (newMatrix RowMajor $ perspectiveMatrix 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
renderWalls pdata wallPointsCol pmat
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)
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
depthMask $= Enabled
resetShaderUniforms (map extractProgAndUnis $ _listShaders pdata)
----------------------
blendFunc $= (SrcAlpha,OneMinusSrcAlpha)
renderFoldable pdata (picToLTree Nothing $ fixedCoordPictures w)
eTicks <- SDL.ticks
return (eTicks - sTicks)
doDrawing' :: RenderData -> World -> IO (Word32)
doDrawing' pdata w = do
bindFramebuffer Framebuffer $= defaultFramebufferObject
sTicks <- SDL.ticks
clear [ColorBuffer,DepthBuffer]
let rot = _cameraRot w
zoom = _cameraZoom w
trans@(tranx,trany) = _cameraCenter w
wins@(winx,winy) = (_windowX w,_windowY w)
wallPointsCol = wallsPointsAndCols w
windowPoints = wallsWindows w
lightPoints = lightsForGloom' w
viewFroms@(viewFromx,viewFromy) = _cameraViewFrom w
pic = worldPictures w
wallPoints = map fst wallPointsCol
pmat <- (newMatrix RowMajor
$ perspectiveMatrix w) :: IO (GLmatrix GLfloat)
setCommonUniforms pdata rot zoom trans wins
depthMask $= Disabled
renderBackground pdata rot zoom trans wins
depthMask $= Enabled
blend $= Enabled
blendFunc $= (SrcAlpha, OneMinusSrcAlpha)
-- not sure why renderWalls and setWallDepth aren't combined
renderWalls pdata wallPointsCol pmat
setWallDepth pdata wallPoints (viewFromx,viewFromy) pmat
depthFunc $= Just Lequal
renderFoldable pdata $ picToLTree (Just 0) pic
renderFoldable pdata $ picToLTree (Just 1) pic
renderFoldable pdata $ picToLTree (Just 2) pic
eTicks <- SDL.ticks
return (eTicks - sTicks)
src/Dodge/Rendering/HUD.hs → src/Dodge/Render/HUD.hs
+1 -1
View File
@@ -1,4 +1,4 @@
module Dodge.Rendering.HUD
module Dodge.Render.HUD
where
import Dodge.Data
src/Dodge/Rendering/MenuScreen.hs → src/Dodge/Render/MenuScreen.hs
+1 -1
View File
@@ -1,4 +1,4 @@
module Dodge.Rendering.MenuScreen
module Dodge.Render.MenuScreen
( menuScreen
)
where
src/Dodge/Render/PerspectiveMatrix.hs
+50
View File
@@ -0,0 +1,50 @@
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
(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
(V4 0 0 0 1)
rotMat = Linear.Matrix.transpose $
V4 (V4 (cos rot) (sin (-rot)) 0 0)
(V4 (sin rot) (cos rot) 0 0)
(V4 0 0 1 0)
(V4 0 0 0 1)
tranMat3 = Linear.Matrix.transpose $
V4 (V4 1 0 0 0)
(V4 0 1 0 0)
(V4 0 0 1 0)
(V4 (-tranx) (-trany) 0 1)
tranMat2 = Linear.Matrix.transpose $
V4 (V4 1 0 0 0)
(V4 0 1 0 0)
(V4 0 0 1 0)
(V4 (viewFromx-tranx) (viewFromy-trany) 0 1)
perMat = Linear.Matrix.transpose $
V4 (V4 1 0 0 0)
(V4 0 1 0 0)
(V4 0 0 1 1)
(V4 0 0 0 1)
tranMat1 = Linear.Matrix.transpose $
V4 (V4 1 0 0 0)
(V4 0 1 0 0)
(V4 0 0 1 0)
(V4 (-viewFromx) (-viewFromy) 0 1)
wmat = scalMat !*! rotMat !*! tranMat2 !*! perMat !*! tranMat1
vToL (V4 a b c d) = [a,b,c,d]
in concatMap vToL $ vToL wmat
src/Dodge/Rendering.hs → src/Dodge/Render/Picture.hs
+4 -16
View File
@@ -1,29 +1,17 @@
module Dodge.Rendering where
-- imports {{{
module Dodge.Render.Picture
where
import Dodge.Data
import Dodge.Base
--import Dodge.Inventory
import Dodge.Rendering.HUD
import Dodge.Rendering.MenuScreen
import Dodge.Render.HUD
import Dodge.Render.MenuScreen
import Geometry
import Picture
import Data.Graph.Inductive.Query.DFS
import Data.Graph.Inductive.Graph
import Control.Monad.State
import Data.List
import Data.Bifunctor
import Data.Function
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
worldPictures :: World -> Picture
worldPictures w = pictures $ concat
src/Dodge/Update.hs
+5 -2
View File
@@ -71,8 +71,11 @@ updateLightSources w = set tempLightSources (catMaybes tlss) w'
updateProjectiles w = IM.foldr' _pjUpdate w $ _projectiles w
updateParticles' :: World -> World
updateParticles' w = set particles' (catMaybes ps) w'
where (w',ps) = mapAccumR (\a b -> _ptUpdate' b a b) w $ _particles' w
updateParticles' w =
--set particles' [] w
set particles' (catMaybes ps) w'
where
(w',ps) = mapAccumR (\a b -> _ptUpdate' b a b) w $ _particles' w
updateCreatures :: World -> World
updateCreatures w = f $ set randGen newG $ set creatures (IM.mapMaybe id crs) w
src/Dodge/WorldEvent/SpawnParticle.hs
+1
View File
@@ -167,6 +167,7 @@ moveFlamelet w pt
& btPassThrough' .~ Nothing
& btVel' .~ 0.8 *.* vel
damcrs = foldr ($) w $ map dodam $ filter closeCrs $ IM.elems $ _creatures w
-- damcrs = w
closeCrs cr = dist ep (_crPos cr) < _crRad cr + size
dodam cr = over (creatures . ix (_crID cr) . crState . crDamage)
((:) $ Flaming 3 sp ep ep)
src/Dodge/WorldEvent/ThingsHit.hs
+1 -1
View File
@@ -17,7 +17,7 @@ thingsHit sp ep w
where
hitCrs = IM.elems $ IM.filter (\cr -> circOnLine sp ep (_crPos cr) (_crRad cr))
$ _creatures w
-- $ creaturesAlongLine sp ep w
-- $ creaturesAlongLine sp ep w
crPs = map (\cr -> ssaTriPoint ep (_crPos cr) sp (_crRad cr)) hitCrs
crs = zip crPs (map E3x1 hitCrs)
src/MatrixHelper.hs
+1 -1
View File
@@ -11,7 +11,7 @@ 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) --scale to make walls shorter
(V4 0 0 0.5 0) --scaled to make walls shorter
(V4 0 0 0 1)
rotMat = Linear.Matrix.transpose $
V4 (V4 (cos rot) (sin (-rot)) 0 0)
src/Picture/Render.hs
+3 -24
View File
@@ -3,7 +3,7 @@
module Picture.Render
( module Picture.Render
, picToLTree
, perspectiveMatrix
-- , perspectiveMatrix
)
where
@@ -114,30 +114,23 @@ createLightMap pdata rot zoom (tranx,trany) (winx,winy) wallPoints lightPoints
(viewFromx,viewFromy) pmat = do
bindFramebuffer Framebuffer $= (_spareFBO pdata)
-- clear buffer to full alpha and furthest depth
clearColor $= Color4 0 0 0 1
clearDepth $= 1
clear [ColorBuffer,DepthBuffer]
depthFunc $= Just Less
-- store wall and light positions into buffer
nWallLights <- F.foldM (pokeShader $ _wallLightShader pdata) wallPoints
bindShaderBuffers [_wallLightShader pdata] [nWallLights]
nWalls <- F.foldM (pokeShader $ _wallShadowShader pdata) wallPoints
bindShaderBuffers [_wallShadowShader pdata] [nWalls]
-- set uniforms for shader that draws lights
currentProgram $= Just (_shaderProgram $ _wallLightShader pdata)
uniform ( (fromJust $ _shaderCustomUnis $ _wallLightShader pdata) !! 1)
$= pmat
-- draw walls from your point of view in order to set z buffer
colorMask $= (Color4 Disabled Disabled Disabled Disabled)
let (tx,ty) = (tranx,trany) -.- (viewFromx,viewFromy)
currentProgram $= Just (_shaderProgram $ _wallShadowShader pdata)
uniform (head $ fromJust $ _shaderCustomUnis $ _wallShadowShader pdata)
$= Vector2 viewFromx viewFromy
@@ -147,23 +140,20 @@ createLightMap pdata rot zoom (tranx,trany) (winx,winy) wallPoints lightPoints
$= (0 :: Float)
cullFace $= Just Back
drawShader (_wallShadowShader pdata) nWalls
-- for each of the lights:
-- stencil out the walls from this lights point of view
-- stencil out the walls from this light's point of view
-- draw fading lightmap circles on the floor
-- draw fading lightmaps on the walls
depthMask $= Disabled
blendFunc $= (Zero, OneMinusSrcAlpha)
stencilTest $= Enabled
forM_ lightPoints $ \(x,y,r,lum) -> do
-- bind buffer for floor light circle
let lightPtr = (\(_,ptr,_) -> ptr) $ head
$ _vaoBufferTargets $ _shaderVAO $ _lightSourceShader pdata
(x',y') = zTran $ rotateV (0 - rot) $ (x,y) -.- (tranx,trany)
zTran (a,b) = (a*2*zoom / winx, b*2*zoom / winy)
pokeFourOff lightPtr 0 (x',y',r,lum)
-- stencil out walls
colorMask $= (Color4 Disabled Disabled Disabled Disabled)
clear [StencilBuffer]
@@ -177,14 +167,12 @@ createLightMap pdata rot zoom (tranx,trany) (winx,winy) wallPoints lightPoints
cullFace $= Just Front
stencilOp $= (OpKeep,OpKeep,OpDecr)
drawShader (_wallShadowShader pdata) nWalls
-- draw floor light circles
cullFace $= Nothing
colorMask $= (Color4 Disabled Disabled Disabled Enabled)
bindShaderBuffers [_lightSourceShader pdata] [1]
stencilFunc $= (Equal, 0, 255)
drawShader (_lightSourceShader pdata) 1
-- draw wall light "circles"
currentProgram $= Just (_shaderProgram $ _wallLightShader pdata)
uniform (head $ fromJust $ _shaderCustomUnis $ _wallLightShader pdata)
@@ -192,34 +180,25 @@ createLightMap pdata rot zoom (tranx,trany) (winx,winy) wallPoints lightPoints
uniform ( (fromJust $ _shaderCustomUnis $ _wallLightShader pdata) !! 2)
$= Vector2 r lum
drawShader (_wallLightShader pdata) nWallLights
depthMask $= Enabled
cullFace $= Nothing
stencilTest $= Disabled
blend $= Disabled
bindFramebuffer Framebuffer $= defaultFramebufferObject
colorMask $= (Color4 Disabled Disabled Disabled Enabled)
bindShaderBuffers [_fullscreenShader pdata] [4]
textureBinding Texture2D $= Just (_fboTexture pdata)
drawShader (_fullscreenShader pdata) 4
colorMask $= (Color4 Enabled Enabled Enabled Enabled)
blend $= Enabled
renderBackground :: RenderData -> Float -> Float -> (Float,Float) -> (Float,Float) -> IO ()
renderBackground pdata rot zoom (tranx,trany) (winx,winy) = do
depthFunc $= Just Less
-- depthFunc $= Just Less
-- set drawing for on top
--blendFuncSeparate $= ((SrcAlphaSaturate, OneMinusSrcAlpha), (Zero,One))
-- draw background
bindArrayBuffers 1 $ _vaoBufferTargets $ _shaderVAO $ _backgroundShader pdata
currentProgram $= Just (_shaderProgram $ _backgroundShader pdata)
bindVertexArrayObject $= Just (_vao $ _shaderVAO $ _backgroundShader pdata)
let backPtr = (\(_,x,_) -> x) $ head $ _vaoBufferTargets $ _shaderVAO $ _backgroundShader pdata