From ac66b4b9d63a7241b2b77801ea33d572996087c2 Mon Sep 17 00:00:00 2001 From: jgk Date: Mon, 12 Jul 2021 12:44:43 +0200 Subject: [PATCH] Hlint pass --- src/Dodge/Creature/Picture.hs | 21 ++++++------ src/Dodge/Render.hs | 55 ++++++++++++++----------------- src/Dodge/Room/Foreground.hs | 2 +- src/Dodge/Update.hs | 3 ++ src/Picture/ToPolyhedra.hs | 2 +- src/Polyhedra.hs | 12 +++---- src/Preload/Render.hs | 25 +++++++++++--- src/Render.hs | 61 +++++++++-------------------------- 8 files changed, 85 insertions(+), 96 deletions(-) diff --git a/src/Dodge/Creature/Picture.hs b/src/Dodge/Creature/Picture.hs index 909e3bacc..3a50c123c 100644 --- a/src/Dodge/Creature/Picture.hs +++ b/src/Dodge/Creature/Picture.hs @@ -14,6 +14,7 @@ import Dodge.Creature.Test --import Dodge.Creature.AlertLevel.Data --import Dodge.Picture.Layer import Dodge.Item.Data +import Dodge.Base.Window import Picture import Geometry import Geometry.Vector3D @@ -26,15 +27,17 @@ basicCrPict -> Creature -> World -> Picture -basicCrPict col cr w = pictures $ - targetingPic ++ - [ tr . setDepth 0 $ color yellow $ circleSolid 10 - , tr . piercingMod $ bluntScale $ naked col cr - , tr $ torso (light4 col) (0,-crad) (0,crad) - , trFeet $ feet cr - , tr $ arms col cr - , tr $ drawEquipment cr - ] +basicCrPict col cr w + | dist (_crPos cr) (_cameraCenter w) > 1.5 * max (getWindowX w) (getWindowY w) = blank + | otherwise = pictures $ + targetingPic ++ + [ tr . setDepth 0 $ color yellow $ circleSolid 10 + , tr . piercingMod $ bluntScale $ naked col cr + , tr $ torso (light4 col) (0,-crad) (0,crad) + , trFeet $ feet cr + , tr $ arms col cr + , tr $ drawEquipment cr + ] where crad = _crRad cr targetingPic = IM.elems $ IM.mapMaybeWithKey f $ _crInv cr diff --git a/src/Dodge/Render.hs b/src/Dodge/Render.hs index 57997b811..cb0e89dad 100644 --- a/src/Dodge/Render.hs +++ b/src/Dodge/Render.hs @@ -11,7 +11,7 @@ import Dodge.Base --import Dodge.Render.MenuScreen import Dodge.Render.Picture --import Dodge.Render.PerspectiveMatrix ---import Geometry +import Geometry import Geometry.Data --import Picture import Render @@ -51,31 +51,40 @@ doDrawing pdata w = do wallPointsCol = wallsPointsAndCols w windowPoints = wallsWindows w lightPoints = lightsForGloom w - --viewFroms@(viewFromx,viewFromy) = _cameraViewFrom w viewFroms = _cameraViewFrom w pic = worldPictures w + -- bind as much data into vbos as feasible at this point -- bind wall points and colors to vbo nWalls <- F.foldM (pokeShader $ _wallTextureShader pdata) (map Render22x4 wallPointsCol) bindShaderBuffers [_wallTextureShader pdata] [nWalls] + -- store foreground silhouette geometry into buffer + nSils <- F.foldM (pokeShader $ _lightingLineShadowShader pdata) + (concatMap polyToRender (foregroundPics w)) + bindShaderBuffers [_lightingLineShadowShader pdata] [nSils] + -- store foreground geometry and floor into buffer + let addC (xx,yy) = (xx,yy,0) + nsurfVs <- F.foldM (pokeShader (_lightingSurfaceShader pdata)) + $ (Render3 $ polyToTris $ map addC $ screenPolygon w) + : concatMap polyToGeoRender (foregroundPics w) + bindShaderBuffers [_lightingSurfaceShader pdata] [nsurfVs] -- set the coordinate uniform ready for drawing elements using world coordinates bufferUBO $ perspectiveMatrixb rot camzoom trans wins viewFroms - bindFramebuffer Framebuffer $= (fst $ _fboBase pdata) + bindFramebuffer Framebuffer $= fst (_fboBase pdata) clearColor $= Color4 0 0 0 0 clear [ColorBuffer,DepthBuffer] depthFunc $= Just Less if w ^. config . wall_textured then renderTextureWalls pdata nWalls else renderBlankWalls pdata nWalls --- _ <- setWallDepth pdata wallPoints (viewFromx,viewFromy) _ <- renderFoldable pdata $ picToLTree (Just 0) (polysToPic $ foregroundPics w) _ <- renderFoldable pdata $ picToLTree (Just 0) pic _ <- renderShader (_textureArrayShader pdata) (_floorTiles w) - bindFramebuffer Framebuffer $= (fst $ _fboBloom pdata) + bindFramebuffer Framebuffer $= fst (_fboBloom pdata) clear [ColorBuffer] blendFunc $= (SrcAlpha,OneMinusSrcAlpha) _ <- renderFoldable pdata $ picToLTree (Just 1) pic - bindFramebuffer Framebuffer $= (fst $ _fboColor pdata) + bindFramebuffer Framebuffer $= fst (_fboColor pdata) clear [ColorBuffer] depthMask $= Disabled _ <- renderFoldable pdata $ picToLTree (Just 3) pic @@ -83,35 +92,21 @@ doDrawing pdata w = do _ <- renderFoldable pdata $ picToLTree (Just 5) pic depthMask $= Enabled - bindFramebuffer Framebuffer $= (fst $ _fboFourth1 pdata) + bindFramebuffer Framebuffer $= fst (_fboFourth1 pdata) viewport $= (Position 0 0, Size 300 300) depthFunc $= Just Always textureBinding Texture2D $= Just (snd $ _fboBloom pdata) - - --colorMask $= Color4 Disabled Disabled Disabled Enabled - --blendFunc $= (One,One) - --blendEquation $= FuncReverseSubtract - --drawShader (_fullscreenAlphaHalveShader pdata) 4 - --colorMask $= Color4 Enabled Enabled Enabled Enabled - --blendEquation $= FuncAdd - - --clear [ColorBuffer] - --blendFunc $= (SrcAlpha,OneMinusSrcAlpha) - blendFunc $= (One,Zero) - --textureBinding Texture2D $= Just (snd $ _fboFourth1 pdata) + blend $= Disabled drawShader (_bloomBlurShader pdata) 4 - --blendFunc $= (One,Zero) replicateM_ 3 $ pingPongBetween (_fboFourth1 pdata) (_fboFourth2 pdata) (_bloomBlurShader pdata) - --replicateM_ 5 $ pingPongBlur pdata - --blend $= Enabled viewport $= (Position 0 0, Size (round $ fst wins) (round $ snd wins)) + blend $= Enabled - blendFunc $= (SrcAlpha,OneMinusSrcAlpha) - - bindFramebuffer Framebuffer $= (fst $ _fboLighting pdata) - let scPol = screenPolygon w - createLightMap pdata (w ^. config . shadow_resolution) lightPoints - (foregroundPics w) scPol nWalls + bindFramebuffer Framebuffer $= fst (_fboLighting pdata) + viewport $= (Position 0 0 + ,divideSize (w ^. config . shadow_resolution) $ Size (round $ fst wins) (round $ snd wins)) + createLightMap pdata lightPoints nWalls nSils nsurfVs + viewport $= (Position 0 0, Size (round $ fst wins) (round $ snd wins)) colorMask $= Color4 Enabled Enabled Enabled Enabled clearColor $= Color4 0 0 0 0 @@ -119,7 +114,7 @@ doDrawing pdata w = do depthMask $= Disabled depthFunc $= Just Always - bindFramebuffer Framebuffer $= (fst $ _fboBase pdata) + bindFramebuffer Framebuffer $= fst (_fboBase pdata) --drawShader (_fullscreenShader pdata) 4 --textureBinding Texture2D $= Just (snd3 $ _fbo2 pdata) textureBinding Texture2D $= Just (snd $ _fboLighting pdata) @@ -160,7 +155,7 @@ doDrawing pdata w = do toList = snd (_fboBase pdata) : concat (repeat [snd $ _fbo2 pdata,snd $ _fbo3 pdata]) bindings = zipWith (>>) (map bindFBO fboList) (map bindTO toList) activeTexture $= TextureUnit 1 - sequence_ $ zipWith (>>) bindings $ map bindDrawDist rds + zipWithM_ (>>) bindings $ map bindDrawDist rds activeTexture $= TextureUnit 0 -- draw overlay bufferUBO $ isoMatrix 0 1 (0,0) (2,2) diff --git a/src/Dodge/Room/Foreground.hs b/src/Dodge/Room/Foreground.hs index 7aaef80d8..c36dce706 100644 --- a/src/Dodge/Room/Foreground.hs +++ b/src/Dodge/Room/Foreground.hs @@ -55,7 +55,7 @@ highPipe h x@(xx,xy) y = ] where (a,b) = y -.- x - (a',b') = 10 *.* (normalizeV $ vNormal (a,b)) + (a',b') = 10 *.* normalizeV (vNormal (a,b)) girderZ :: Float -> Point2 -> Point2 -> Picture girderZ w x y = setDepth 50 $ color red $ pictures $ diff --git a/src/Dodge/Update.hs b/src/Dodge/Update.hs index 9f55554f6..e25c26e11 100644 --- a/src/Dodge/Update.hs +++ b/src/Dodge/Update.hs @@ -161,6 +161,9 @@ checkEndGame w | _crHP (you w) < 1 = haltSound $ w {_menuLayers = [GameOverMenu]} | otherwise = w +--updateClouds :: World -> World +--updateClouds = (clouds .~ IM.empty) . (cloudsZone .~ IM.empty) + updateClouds :: World -> World updateClouds w = IM.foldr' updateCloud w $ _clouds w diff --git a/src/Picture/ToPolyhedra.hs b/src/Picture/ToPolyhedra.hs index 7b0f2923d..6be6b358f 100644 --- a/src/Picture/ToPolyhedra.hs +++ b/src/Picture/ToPolyhedra.hs @@ -7,5 +7,5 @@ toPolyhedra :: Picture -> [[Point3]] toPolyhedra (OnLayer _ pic) = toPolyhedra pic toPolyhedra (Pictures pics) = concatMap toPolyhedra pics toPolyhedra (OverPic f _ pic) = map (map f) $ toPolyhedra pic -toPolyhedra (Poly3D _ vs) = [fst $ unzip vs] +toPolyhedra (Poly3D _ vs) = [map fst vs] toPolyhedra _ = [] diff --git a/src/Polyhedra.hs b/src/Polyhedra.hs index c4bb2dd29..2165ad15a 100644 --- a/src/Polyhedra.hs +++ b/src/Polyhedra.hs @@ -13,7 +13,7 @@ import Data.Bifunctor import Control.Lens translateXY :: Float -> Float -> Polyhedra -> Polyhedra -translateXY x y = pyFaces %~ (map $ map $ first $ tran) +translateXY x y = pyFaces %~ map (map $ first tran) where tran (a,b,c) = (a+x,b+y,c) @@ -37,13 +37,13 @@ findReverseEdge :: [(Point3,Point3,Point3)] -> (Point3,Point3,Point3) -> Maybe (Point3,Point3,Point3,Point3) -findReverseEdge otherEdges (x,y,z) = fmap (\(_,_,n) -> (x,y,z,n)) - $ find (\(a,b,_) -> (x,y) == (b,a)) otherEdges +findReverseEdge otherEdges (x,y,z) = (\(_,_,n) -> (x,y,z,n)) + <$> find (\(a,b,_) -> (x,y) == (b,a)) otherEdges faceEdges :: [Point3] -> [(Point3,Point3,Point3)] -faceEdges xs = map addNormal $ zip xs (tail xs ++ [head xs]) +faceEdges xs = zipWith addNormal xs (tail xs ++ [head xs]) where - addNormal (x,y) = (x,y,n) + addNormal x y = (x,y,n) (a:b:c:_) = xs n = crossProd (b -.-.- a) (c -.-.- a) @@ -93,7 +93,7 @@ polyToEdges = constructEdges . map (map fst) . _pyFaces -- rendering for silhouette polyToRender :: Polyhedra -> [RenderType] -polyToRender = map Render3 . map flat4 . polyToEdges +polyToRender = map (Render3 . flat4) . polyToEdges -- rendering for shape polyToGeoRender :: Polyhedra -> [RenderType] polyToGeoRender = map (Render3 . polyToTris . map fst) . _pyFaces diff --git a/src/Preload/Render.hs b/src/Preload/Render.hs index ac54d83a3..152cf71c1 100644 --- a/src/Preload/Render.hs +++ b/src/Preload/Render.hs @@ -101,7 +101,7 @@ preloadRender = do rboLightingName <- genObjectName bindRenderbuffer Renderbuffer $= rboLightingName renderbufferStorage Renderbuffer Depth24Stencil8 (RenderbufferSize 800 600) - fboLightingName <- newFramebufferGivenStencil rboLightingName + fboLightingName <- newFramebufferGivenStencilAlpha rboLightingName rboBaseBloomName <- genObjectName bindRenderbuffer Renderbuffer $= rboBaseBloomName @@ -213,6 +213,23 @@ newFramebufferGivenStencil rboName = do fboStatus <- framebufferStatus Framebuffer print fboStatus return (fboName,toName) + +newFramebufferGivenStencilAlpha + :: RenderbufferObject + -> IO (FramebufferObject, TextureObject) +newFramebufferGivenStencilAlpha rboName = do + fboName <- genObjectName + bindFramebuffer Framebuffer $= fboName + toName <- genObjectName + textureBinding Texture2D $= Just toName + texImage2D Texture2D NoProxy 0 RGBA8 (TextureSize2D 800 600) 0 (PixelData RGBA UnsignedByte nullPtr) + -- don't need mipmaps + textureFilter Texture2D $= minMagFilter + framebufferTexture2D Framebuffer (ColorAttachment 0) Texture2D toName 0 + framebufferRenderbuffer Framebuffer DepthStencilAttachment Renderbuffer rboName + fboStatus <- framebufferStatus Framebuffer + print fboStatus + return (fboName,toName) setupTextureFramebuffer :: GLsizei @@ -242,9 +259,9 @@ cleanUpRenderPreload pd = do {-# INLINE pokeBezQStrat #-} pokeBezQStrat :: RenderType -> [[Float]] -pokeBezQStrat (RenderBezQ vs) = fmap (\((x,y,z),(r,g,b,a),(s,t,u,v)) -> [x,y,z,r,g,b,a,s,t,u,v] - ) - vs +pokeBezQStrat (RenderBezQ vs) = fmap + (\((x,y,z),(r,g,b,a),(s,t,u,v)) -> [x,y,z,r,g,b,a,s,t,u,v]) + vs pokeBezQStrat _ = [] diff --git a/src/Render.hs b/src/Render.hs index b2ac35ce5..943698bf8 100644 --- a/src/Render.hs +++ b/src/Render.hs @@ -7,10 +7,10 @@ import Shader.Poke import Data.Preload.Render import Picture.Data --import Picture.Tree -import Geometry +--import Geometry import Geometry.Data -import Polyhedra.Data -import Polyhedra +--import Polyhedra.Data +--import Polyhedra --import Control.Lens import Control.Monad @@ -31,59 +31,35 @@ sizeToTexSize (Size x y) = TextureSize2D x y {- | Determine where light is shining in the world. -} createLightMap :: RenderData - -> Int -- Resolution division -> [(Point3,Float,Float)] -- Lights - -> [Polyhedra] -- foreground geometry - -> [Point2] -- ^ screen polygon -> Int -- ^ number of walls + -> Int -- ^ number of silhoutte lines to draw + -> Int -- ^ number of surface triangles to draw -> IO () -createLightMap pdata resDiv lightPoints fpics scPol nWalls = do +createLightMap pdata lightPoints nWalls nSils nsurfVs = do depthFunc $= Just Less - -- get viewport size so we can reset it later - (vppos,vpsize) <- get viewport - -- set the viewport size to desired fidelity - let vsize = divideSize resDiv vpsize - viewport $= (vppos, vsize) - textureBinding Texture2D $= Just (snd $ _fboLighting pdata) - -- store foreground silhouette geometry into buffer - nSils <- F.foldM (pokeShader $ _lightingLineShadowShader pdata) (concatMap polyToRender fpics) - bindShaderBuffers [_lightingLineShadowShader pdata] [nSils] - -- store foreground geometry and floor into buffer - let addC (xx,yy) = (xx,yy,0) - nsurfVs <- F.foldM (pokeShader (_lightingSurfaceShader pdata)) - $ [Render3 $ polyToTris $ map addC $ scPol ] - ++ concatMap polyToGeoRender (fpics) - bindShaderBuffers [_lightingSurfaceShader pdata] [nsurfVs] -- clear buffer to full alpha and furthest depth -- clearColor is specified in preloadRender clearColor $= Color4 0 0 0 1 clear [ColorBuffer,DepthBuffer] + --colorMask $= Color4 Disabled Disabled Disabled Disabled cullFace $= Just Back -- draw walls from your point of view in order to set z buffer - currentProgram $= Just (_shaderProgram $ _lightingWallShader pdata) - --drawShader (_lightingWallShader pdata) nWallLights drawShader (_lightingWallShader pdata) nWalls - --colorMask $= Color4 Disabled Disabled Disabled Disabled - --currentProgram $= Just (_shaderProgram $ _lightingOccludeShader pdata) - --uniform (head $ _shaderCustomUnis $ _lightingOccludeShader pdata) - -- $= Vector2 viewFromx viewFromy - --drawShader (_lightingOccludeShader pdata) nWalls ----- draw foreground elements to set z buffer - currentProgram $= Just (_shaderProgram $ _lightingSurfaceShader pdata) + ---- draw foreground elements to set z buffer drawShader (_lightingSurfaceShader pdata) nsurfVs --- for each of the lights: --- stencil out the walls from this light's point of view --- draw fading lightmap circles on the floor --- draw fading lightmaps on the walls - --cullFace $= Nothing + -- for each of the lights: + -- 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 - --depthFunc $= Just Less + depthFunc $= Just Lequal forM_ lightPoints $ \((x,y,z),r,lum) -> do -- stencil out shadows --depthFunc $= Just Less - depthFunc $= Just Lequal + --depthFunc $= Just Lequal colorMask $= Color4 Disabled Disabled Disabled Disabled clear [StencilBuffer] cullFace $= Just Back @@ -93,7 +69,6 @@ createLightMap pdata resDiv lightPoints fpics scPol nWalls = do uniform (head $ _shaderCustomUnis $ _lightingOccludeShader pdata) $= Vector3 x y z drawShader (_lightingOccludeShader pdata) nWalls - --cullFace $= Nothing currentProgram $= Just (_shaderProgram $ _lightingLineShadowShader pdata) uniform (head $ _shaderCustomUnis $ _lightingLineShadowShader pdata) $= Vector3 x y z @@ -106,7 +81,7 @@ createLightMap pdata resDiv lightPoints fpics scPol nWalls = do currentProgram $= Just (_shaderProgram $ _lightingLineShadowShader pdata) drawShader (_lightingLineShadowShader pdata) nSils - depthFunc $= Just Lequal + --depthFunc $= Just Lequal -- draw geometry surfaces cullFace $= Just Back colorMask $= Color4 Disabled Disabled Disabled Enabled @@ -118,7 +93,6 @@ createLightMap pdata resDiv lightPoints fpics scPol nWalls = do $= Vector2 r lum drawShader (_lightingSurfaceShader pdata) nsurfVs -- draw wall light "circles" - --cullFace $= Nothing currentProgram $= Just (_shaderProgram $ _lightingWallShader pdata) uniform (head $ _shaderCustomUnis $ _lightingWallShader pdata) $= Vector3 x y z @@ -127,10 +101,7 @@ createLightMap pdata resDiv lightPoints fpics scPol nWalls = do drawShader (_lightingWallShader pdata) nWalls cullFace $= Nothing stencilTest $= Disabled - blend $= Disabled - -- set the viewport size to that of the window - viewport $= (vppos, vpsize) - -- disable depth testing for blurring + --blend $= Disabled {- | Blur between two framebuffers. Assumes no depth testing is done