Hlint pass

2021-07-12 12:44:43 +02:00
parent 75254cd3e4
commit ac66b4b9d6
8 changed files with 85 additions and 96 deletions
@@ -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
@@ -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)
@@ -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 $
@@ -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 

@@ -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 _ = []
@@ -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
@@ -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 _ = []


@@ -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