From 89c3ff96c89cf64bedf0668c5af1cf70cf4ed1f0 Mon Sep 17 00:00:00 2001 From: jgk Date: Mon, 29 Mar 2021 23:25:48 +0200 Subject: [PATCH 1/4] Add spawner gun --- app/Main.hs | 31 ++++++++++++++++----------- src/Dodge/Creature.hs | 1 + src/Dodge/Item/Weapon.hs | 23 +++++++++++++++++++- src/Dodge/WorldEvent/SpawnParticle.hs | 4 ++-- src/Picture/Render.hs | 14 ++++-------- 5 files changed, 48 insertions(+), 25 deletions(-) diff --git a/app/Main.hs b/app/Main.hs index 7385911da..7fe2ea989 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -24,6 +24,7 @@ import Sound.Preload import Control.Concurrent import Control.Lens +import Foreign (Word32) import Control.Monad (when) @@ -52,18 +53,7 @@ main = do (fmap (setWindowSize sizex sizey keyConfig) firstWorld) ( \preData w -> do startTicks <- SDL.ticks - clear [ColorBuffer,DepthBuffer] - (lightTicks,timeSpentPoking) <- renderPicture' (_renderData preData) - (_cameraRot w) (_cameraZoom w) - (_cameraCenter w) - (_windowX w,_windowY w) - (wallsPointsAndCols w) - (wallsWindows w) - (lightsForGloom' w) - (_cameraViewFrom w) - (worldPictures w) - blendFunc $= (SrcAlpha,OneMinusSrcAlpha) - renderFoldable (_renderData preData) (picToLTree Nothing $ fixedCoordPictures w) + doTheRender preData w playSoundQueue (_soundData preData) (_soundQueue w) newSoundData <- playAndUpdate (_sounds w) (_soundData preData) @@ -91,3 +81,20 @@ 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] + renderPicture' (_renderData preData) + (_cameraRot w) (_cameraZoom w) + (_cameraCenter w) + (_windowX w,_windowY w) + (wallsPointsAndCols w) + (wallsWindows w) + (lightsForGloom' w) + (_cameraViewFrom w) + (worldPictures w) + blendFunc $= (SrcAlpha,OneMinusSrcAlpha) + renderFoldable (_renderData preData) (picToLTree Nothing $ fixedCoordPictures w) + eTicks <- SDL.ticks + return (eTicks - sTicks) diff --git a/src/Dodge/Creature.hs b/src/Dodge/Creature.hs index 8e516554e..f86a9d483 100644 --- a/src/Dodge/Creature.hs +++ b/src/Dodge/Creature.hs @@ -254,6 +254,7 @@ startCr = defaultCreature ( [pistol ,blinkGun + ,spawnGun lamp ,flameGrenade ,teslaGrenade ,autoGun diff --git a/src/Dodge/Item/Weapon.hs b/src/Dodge/Item/Weapon.hs index 1cb76928c..3127a4955 100644 --- a/src/Dodge/Item/Weapon.hs +++ b/src/Dodge/Item/Weapon.hs @@ -82,6 +82,7 @@ pistol = Weapon , _itInvColor = white } defaultGun = pistol + defaultAutoGun = autoGun {_itScrollUp = const id , _itScrollDown = const id, _itInvDisplay = basicWeaponDisplay} effectGun :: String -> (Int -> World -> World) -> Item @@ -900,13 +901,14 @@ aFlame a cid w w where (a2,g) = randomR (-0.1,0.1) (_randGen w) + (t,_) = randomR (99,101) (_randGen w) angle = min flamerAngle $ max (-flamerAngle) (a + a2) cr = (_creatures w IM.! cid) dir = _crDir cr + angle pos = _crPos cr +.+ ((_crRad cr + 2.9) *.* unitVectorAtAngle (_crDir cr)) w1 = set randGen g w vel = (_crPos cr -.- _crOldPos cr) +.+ 4 *.* unitVectorAtAngle dir - insertFlame = makeFlame pos vel (Just cid) -- . makeFlame pos2 vel (Just cid) + insertFlame = makeFlame t pos vel (Just cid) -- . makeFlame pos2 vel (Just cid) resetAngle = set (creatures . ix cid . crInv . ix (_crInvSel cr) . wpFire) (shoot $ aFlame angle) @@ -1942,4 +1944,23 @@ makeLaserScope p ep d relFrac = Particle' +spawnGun :: Creature -> Item +spawnGun cr = defaultGun + { _itName = "SPAWNER" + , _wpMaxAmmo = 1 + , _wpLoadedAmmo = 1 + , _wpReloadTime = 80 + , _wpReloadState = 0 + , _wpFireRate = 100 + , _wpFire = spawnCrNextTo cr + } +spawnCrNextTo :: Creature -> Int -> World -> World +spawnCrNextTo cr i w = w & creatures %~ IM.insert k newCr + where + k = newKey $ _creatures w + sCr = _creatures w IM.! i + newCr = cr + & crID .~ k + & crPos .~ _crPos sCr +.+ unitVectorAtAngle (_crDir sCr) + & crOldPos .~ _crPos sCr +.+ unitVectorAtAngle (_crDir sCr) diff --git a/src/Dodge/WorldEvent/SpawnParticle.hs b/src/Dodge/WorldEvent/SpawnParticle.hs index dc900a111..487ee9248 100644 --- a/src/Dodge/WorldEvent/SpawnParticle.hs +++ b/src/Dodge/WorldEvent/SpawnParticle.hs @@ -37,8 +37,8 @@ aFlameParticle t pos vel maycid = Pt' , _btHitEffect' = destroyOnImpact (doFlameDam 1) noEff noEff } -makeFlame :: Point2 -> Point2 -> Maybe Int -> World -> World -makeFlame pos vel maycid = over particles' (aFlameParticle 100 pos vel maycid : ) +makeFlame :: Int -> Point2 -> Point2 -> Maybe Int -> World -> World +makeFlame t pos vel maycid = over particles' (aFlameParticle t pos vel maycid : ) drawFlame :: Point2 -> Particle' -> Picture drawFlame rotd pt = thePic diff --git a/src/Picture/Render.hs b/src/Picture/Render.hs index 066cfb270..855bbb2da 100644 --- a/src/Picture/Render.hs +++ b/src/Picture/Render.hs @@ -33,25 +33,22 @@ import qualified SDL as SDL renderPicture' :: RenderData -> Float -> Float -> Point2 -> Point2 -> [((Point2,Point2),Point4)] -> [((Point2,Point2),Point4)] -> [Point4] -> - (Float,Float) -> Picture -> IO (Word32,Word32) + (Float,Float) -> Picture -> IO (Word32) renderPicture' pdata rot zoom trans@(tranx,trany) wins@(winx,winy) wallPointsCol windowPoints lightPoints viewFroms@(viewFromx,viewFromy) pic = do - let wallPoints = map fst wallPointsCol startTicks <- SDL.ticks + let wallPoints = map fst wallPointsCol setCommonUniforms pdata rot zoom trans wins depthFunc $= Just Less --- calculate perspective matrix 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 - ticksAfterLighting <- SDL.ticks - renderBackground pdata rot zoom trans wins renderWalls pdata wallPointsCol pmat @@ -65,6 +62,7 @@ renderPicture' pdata rot zoom trans@(tranx,trany) wins@(winx,winy) wallPointsCol -- 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 @@ -78,7 +76,7 @@ renderPicture' pdata rot zoom trans@(tranx,trany) wins@(winx,winy) wallPointsCol resetShaderUniforms (map extractProgAndUnis $ _listShaders pdata) endTicks <- SDL.ticks - return (ticksAfterLighting, endTicks - startTicks) + return (endTicks - startTicks) renderWalls :: RenderData -> [((Point2,Point2),Point4)] -> GLmatrix GLfloat -> IO () renderWalls pdata wps pmat = do @@ -190,15 +188,11 @@ createLightMap pdata rot zoom (tranx,trany) (winx,winy) wallPoints lightPoints blend $= Disabled --- blendFunc $= (Zero,One) bindFramebuffer Framebuffer $= defaultFramebufferObject colorMask $= (Color4 Disabled Disabled Disabled Enabled) --- --- blendFunc $= (SrcAlpha, OneMinusSrcAlpha) bindShaderBuffers [_fullscreenShader pdata] [4] textureBinding Texture2D $= Just (_fboTexture pdata) --- blendFunc $= (One, Zero) drawShader (_fullscreenShader pdata) 4 colorMask $= (Color4 Enabled Enabled Enabled Enabled) From e62ff391a561e53795fe91c9528f53cb04898f2a Mon Sep 17 00:00:00 2001 From: jgk Date: Wed, 31 Mar 2021 11:27:45 +0200 Subject: [PATCH 2/4] Reogranise drawing in main --- app/Main.hs | 61 ++++++++++++++++++++++---- src/Dodge/Creature/Inanimate.hs | 3 +- src/Dodge/WallCreatureCollisions.hs | 7 ++- src/Dodge/WorldEvent/Flash.hs | 2 +- src/Dodge/WorldEvent/ThingsHit.hs | 1 + src/Geometry.hs | 1 + src/Picture/Render.hs | 68 +++++++++++++++++------------ 7 files changed, 99 insertions(+), 44 deletions(-) diff --git a/app/Main.hs b/app/Main.hs index 7fe2ea989..d3c3a114d 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -85,15 +85,58 @@ doTheRender :: PreloadData a -> World -> IO (Word32) doTheRender preData w = do sTicks <- SDL.ticks clear [ColorBuffer,DepthBuffer] - renderPicture' (_renderData preData) - (_cameraRot w) (_cameraZoom w) - (_cameraCenter w) - (_windowX w,_windowY w) - (wallsPointsAndCols w) - (wallsWindows w) - (lightsForGloom' w) - (_cameraViewFrom w) - (worldPictures w) + 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 diff --git a/src/Dodge/Creature/Inanimate.hs b/src/Dodge/Creature/Inanimate.hs index 058840b30..4397a33d2 100644 --- a/src/Dodge/Creature/Inanimate.hs +++ b/src/Dodge/Creature/Inanimate.hs @@ -5,6 +5,7 @@ import Dodge.Base import Dodge.Default import Dodge.CreatureState import Dodge.LightSources +import Dodge.WorldEvent.Flash import Dodge.WorldEvent.Sound @@ -34,7 +35,7 @@ updateLamp :: Int -> CRUpdate updateLamp i = unrandUpdate handleLS internalUpdate where handleLS cr w - | _crHP cr < 0 = mkSoundBreakGlass w & lightSources %~ IM.delete i + | _crHP cr < 0 = explosionFlashAt (_crPos cr) $ mkSoundBreakGlass w & lightSources %~ IM.delete i | otherwise = w & lightSources . ix i . lsPos .~ _crPos cr internalUpdate cr | _crHP cr < 0 = Nothing diff --git a/src/Dodge/WallCreatureCollisions.hs b/src/Dodge/WallCreatureCollisions.hs index 32bb96116..d5685de40 100644 --- a/src/Dodge/WallCreatureCollisions.hs +++ b/src/Dodge/WallCreatureCollisions.hs @@ -40,18 +40,17 @@ wallBuffer = 3 -- the following tests whether or not a point is on a wall, and if so pushes it -- out from the wall --- If the resultant push out is itself on another wall, the original point is --- returned +-- this is then repeated if the point ends up on a new wall collideWalls :: Float -> Point2 -> [[Point2]] -> Point2 -> Point2 collideWalls rad cp1 walls cp2 = case (listToMaybe.mapMaybe (pushOutFromWall rad cp2)) walls of Nothing -> cp2 Just cp3 -> case (listToMaybe.reverse.mapMaybe (pushOutFromWall rad cp3)) walls of Nothing -> cp3 - Just cp4 -> cp1 + Just cp4 -> cp4 -- pushes a point out from a list of walls --- if multiple new points occur, chooses the one closest to the orignal pointjk +-- if multiple new points occur, chooses the one closest to the orignal point pushOutFromWalls :: Float -> [[Point2]] -> Point2 -> Point2 pushOutFromWalls rad walls p = fromMaybe p diff --git a/src/Dodge/WorldEvent/Flash.hs b/src/Dodge/WorldEvent/Flash.hs index 721b9d1ea..26171d70c 100644 --- a/src/Dodge/WorldEvent/Flash.hs +++ b/src/Dodge/WorldEvent/Flash.hs @@ -59,7 +59,7 @@ glareBetween t len wdth col a b w lowLightPic :: Float -> Float -> Color -> (Point2, Point2) -> World -> Picture lowLightPic len wdth col (a,b) w - = case thingsHitLongLine a b w of + = case thingsHit a b w of ((p, E3x2 wall):_) -> setCol . lineOfThickness wdth $ [alongLineBy len p wa, alongLineBy len p wb] where x = len *.* (normalizeV $ wa -.- wb) diff --git a/src/Dodge/WorldEvent/ThingsHit.hs b/src/Dodge/WorldEvent/ThingsHit.hs index 149d288a6..73c0b7b80 100644 --- a/src/Dodge/WorldEvent/ThingsHit.hs +++ b/src/Dodge/WorldEvent/ThingsHit.hs @@ -17,6 +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 crPs = map (\cr -> ssaTriPoint ep (_crPos cr) sp (_crRad cr)) hitCrs crs = zip crPs (map E3x1 hitCrs) diff --git a/src/Geometry.hs b/src/Geometry.hs index 666cfab39..0c8614ad6 100644 --- a/src/Geometry.hs +++ b/src/Geometry.hs @@ -152,6 +152,7 @@ circOnLine' !p1 !p2 !c !rad = isJustTrue (fmap (\p -> magV (p -.- c) < rad) y) -- this should probably be circOnSeg circOnLine :: Point2 -> Point2 -> Point2 -> Float -> Bool +{-# INLINE circOnLine #-} circOnLine !p1 !p2 !c !rad = magV (p1 -.- c) <= rad || magV (p2 -.- c) <= rad || isJustTrue (fmap (\p -> magV (p -.- c) < rad) y) where diff --git a/src/Picture/Render.hs b/src/Picture/Render.hs index 855bbb2da..c1fbccce6 100644 --- a/src/Picture/Render.hs +++ b/src/Picture/Render.hs @@ -1,9 +1,9 @@ --{-# LANGUAGE Strict #-} {-# LANGUAGE DeriveFoldable, StandaloneDeriving #-} module Picture.Render - ( renderPicture' - , renderFoldable + ( module Picture.Render , picToLTree + , perspectiveMatrix ) where @@ -114,19 +114,27 @@ createLightMap pdata rot zoom (tranx,trany) (winx,winy) wallPoints lightPoints (viewFromx,viewFromy) pmat = do bindFramebuffer Framebuffer $= (_spareFBO pdata) - clearColor $= Color4 0 0.5 0 1 - depthFunc $= Just Less + +-- 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 - nWalls <- F.foldM (pokeShader $ _wallShadowShader pdata) wallPoints - bindShaderBuffers [_wallShadowShader pdata] [nWalls] +-- 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) @@ -140,41 +148,44 @@ createLightMap pdata rot zoom (tranx,trany) (winx,winy) wallPoints lightPoints cullFace $= Just Back drawShader (_wallShadowShader pdata) nWalls +-- for each of the lights: +-- stencil out the walls from this lights point of view +-- draw fading lightmap circles on the floor +-- draw fading lightmaps on the walls depthMask $= Disabled blendFunc $= (Zero, OneMinusSrcAlpha) --- blendFuncSeparate $= ((Zero,Zero),(Zero, OneMinusSrcAlpha)) stencilTest $= Enabled forM_ lightPoints $ \(x,y,r,lum) -> do --- depthFunc $= Just Less - colorMask $= (Color4 Disabled Disabled Disabled Disabled) - clear [StencilBuffer] - cullFace $= Just Back --- stencilOp $= (OpKeep,OpKeep,OpReplace) - stencilOp $= (OpKeep,OpKeep,OpIncr) - stencilFunc $= (Always, 0, 255) --- currentProgram does get called twice: here and inside drawShader below - currentProgram $= Just (_shaderProgram $ _wallShadowShader pdata) - uniform (head $ fromJust $ _shaderCustomUnis $ _wallShadowShader pdata) - $= Vector2 x y --- blendFunc $= (Zero,One) - drawShader (_wallShadowShader pdata) nWalls - cullFace $= Just Front - stencilOp $= (OpKeep,OpKeep,OpDecr) - drawShader (_wallShadowShader pdata) nWalls - - cullFace $= Nothing - - colorMask $= (Color4 Enabled Enabled Enabled Enabled) +-- 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] + cullFace $= Just Back + stencilOp $= (OpKeep,OpKeep,OpIncr) + stencilFunc $= (Always, 0, 255) + currentProgram $= Just (_shaderProgram $ _wallShadowShader pdata) + uniform (head $ fromJust $ _shaderCustomUnis $ _wallShadowShader pdata) + $= Vector2 x y + drawShader (_wallShadowShader pdata) nWalls + 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) $= Vector2 x y @@ -204,8 +215,7 @@ renderBackground pdata rot zoom (tranx,trany) (winx,winy) = do depthFunc $= Just Less -- set drawing for on top - blendFuncSeparate $= ((SrcAlphaSaturate, OneMinusSrcAlpha), (Zero,One)) - clear [DepthBuffer] + --blendFuncSeparate $= ((SrcAlphaSaturate, OneMinusSrcAlpha), (Zero,One)) -- draw background bindArrayBuffers 1 $ _vaoBufferTargets $ _shaderVAO $ _backgroundShader pdata From 1e9a07d1c806e4daf0d99bb6e87a264ede54b3d1 Mon Sep 17 00:00:00 2001 From: jgk Date: Thu, 1 Apr 2021 11:28:53 +0200 Subject: [PATCH 3/4] Reorganise rendering in Dodge --- app/Main.hs | 64 +-------- package.yaml | 20 +++ src/Dodge/Base.hs | 11 +- src/Dodge/Render.hs | 122 ++++++++++++++++++ src/Dodge/{Rendering => Render}/HUD.hs | 2 +- src/Dodge/{Rendering => Render}/MenuScreen.hs | 2 +- src/Dodge/Render/PerspectiveMatrix.hs | 50 +++++++ src/Dodge/{Rendering.hs => Render/Picture.hs} | 20 +-- src/Dodge/Update.hs | 7 +- src/Dodge/WorldEvent/SpawnParticle.hs | 1 + src/Dodge/WorldEvent/ThingsHit.hs | 2 +- src/MatrixHelper.hs | 2 +- src/Picture/Render.hs | 27 +--- 13 files changed, 217 insertions(+), 113 deletions(-) create mode 100644 src/Dodge/Render.hs rename src/Dodge/{Rendering => Render}/HUD.hs (99%) rename src/Dodge/{Rendering => Render}/MenuScreen.hs (98%) create mode 100644 src/Dodge/Render/PerspectiveMatrix.hs rename src/Dodge/{Rendering.hs => Render/Picture.hs} (95%) diff --git a/app/Main.hs b/app/Main.hs index d3c3a114d..ddcf6053c 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -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) diff --git a/package.yaml b/package.yaml index 4e1a8d080..d93b19c2b 100644 --- a/package.yaml +++ b/package.yaml @@ -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 + diff --git a/src/Dodge/Base.hs b/src/Dodge/Base.hs index c37542b2a..2b9144773 100644 --- a/src/Dodge/Base.hs +++ b/src/Dodge/Base.hs @@ -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 diff --git a/src/Dodge/Render.hs b/src/Dodge/Render.hs new file mode 100644 index 000000000..7fc6b254f --- /dev/null +++ b/src/Dodge/Render.hs @@ -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) + diff --git a/src/Dodge/Rendering/HUD.hs b/src/Dodge/Render/HUD.hs similarity index 99% rename from src/Dodge/Rendering/HUD.hs rename to src/Dodge/Render/HUD.hs index 3ec96ef85..e2dc56816 100644 --- a/src/Dodge/Rendering/HUD.hs +++ b/src/Dodge/Render/HUD.hs @@ -1,4 +1,4 @@ -module Dodge.Rendering.HUD +module Dodge.Render.HUD where import Dodge.Data diff --git a/src/Dodge/Rendering/MenuScreen.hs b/src/Dodge/Render/MenuScreen.hs similarity index 98% rename from src/Dodge/Rendering/MenuScreen.hs rename to src/Dodge/Render/MenuScreen.hs index 3661baead..b27ea3a43 100644 --- a/src/Dodge/Rendering/MenuScreen.hs +++ b/src/Dodge/Render/MenuScreen.hs @@ -1,4 +1,4 @@ -module Dodge.Rendering.MenuScreen +module Dodge.Render.MenuScreen ( menuScreen ) where diff --git a/src/Dodge/Render/PerspectiveMatrix.hs b/src/Dodge/Render/PerspectiveMatrix.hs new file mode 100644 index 000000000..4ea325552 --- /dev/null +++ b/src/Dodge/Render/PerspectiveMatrix.hs @@ -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 diff --git a/src/Dodge/Rendering.hs b/src/Dodge/Render/Picture.hs similarity index 95% rename from src/Dodge/Rendering.hs rename to src/Dodge/Render/Picture.hs index ddbe643cc..e6c2ad832 100644 --- a/src/Dodge/Rendering.hs +++ b/src/Dodge/Render/Picture.hs @@ -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 diff --git a/src/Dodge/Update.hs b/src/Dodge/Update.hs index 6edfb7168..4faa832be 100644 --- a/src/Dodge/Update.hs +++ b/src/Dodge/Update.hs @@ -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 diff --git a/src/Dodge/WorldEvent/SpawnParticle.hs b/src/Dodge/WorldEvent/SpawnParticle.hs index 487ee9248..8c25c3d50 100644 --- a/src/Dodge/WorldEvent/SpawnParticle.hs +++ b/src/Dodge/WorldEvent/SpawnParticle.hs @@ -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) diff --git a/src/Dodge/WorldEvent/ThingsHit.hs b/src/Dodge/WorldEvent/ThingsHit.hs index 73c0b7b80..3360f0b25 100644 --- a/src/Dodge/WorldEvent/ThingsHit.hs +++ b/src/Dodge/WorldEvent/ThingsHit.hs @@ -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) diff --git a/src/MatrixHelper.hs b/src/MatrixHelper.hs index 1e9b52aa8..ae8ba552f 100644 --- a/src/MatrixHelper.hs +++ b/src/MatrixHelper.hs @@ -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) diff --git a/src/Picture/Render.hs b/src/Picture/Render.hs index c1fbccce6..a04c83bb0 100644 --- a/src/Picture/Render.hs +++ b/src/Picture/Render.hs @@ -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 From cbcc0f700b238cea41f95c09a420355470187328 Mon Sep 17 00:00:00 2001 From: jgk Date: Thu, 1 Apr 2021 12:38:49 +0200 Subject: [PATCH 4/4] Setup benchmarking --- bench/Bench.hs | 4 ++++ package.yaml | 12 ++++++------ 2 files changed, 10 insertions(+), 6 deletions(-) create mode 100644 bench/Bench.hs diff --git a/bench/Bench.hs b/bench/Bench.hs new file mode 100644 index 000000000..2a50cac83 --- /dev/null +++ b/bench/Bench.hs @@ -0,0 +1,4 @@ +import Criterion.Main + +main :: IO () +main = putStrLn "h" diff --git a/package.yaml b/package.yaml index d93b19c2b..63eef0d8d 100644 --- a/package.yaml +++ b/package.yaml @@ -81,10 +81,10 @@ tests: - loop benchmarks: - loop-benchmarks: - dependencies: - - criterion - ghc-options: + loop-benchmarks: + dependencies: + - criterion + ghc-options: - -threaded - -O2 - -rtsopts @@ -96,6 +96,6 @@ benchmarks: - -funfolding-keeness-factor1000 - -fllvm - -optlo-O3 - main: Bench.hs - source-dirs: bench + main: Bench.hs + source-dirs: bench