Hlint pass

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 $
+basicCrPict col cr w
-    targetingPic ++
+    | dist (_crPos cr) (_cameraCenter w) > 1.5 * max (getWindowX w) (getWindowY w) = blank 
-    [ tr . setDepth 0 $ color yellow $ circleSolid 10
+    | otherwise = pictures $
-    , tr . piercingMod $ bluntScale $ naked col cr
+        targetingPic ++
-    , tr $ torso (light4 col) (0,-crad) (0,crad)
+        [ tr . setDepth 0 $ color yellow $ circleSolid 10
-    , trFeet $ feet cr
+        , tr . piercingMod $ bluntScale $ naked col cr
-    , tr $ arms col cr
+        , tr $ torso (light4 col) (0,-crad) (0,crad)
-    , tr $ drawEquipment cr
+        , trFeet $ feet cr
-    ]
+        , tr $ arms col cr
+        , tr $ drawEquipment cr
+        ]
   where 
     crad = _crRad cr
     targetingPic = IM.elems $ IM.mapMaybeWithKey f $ _crInv cr

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)
-
+    blend $= Disabled
-    --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)
     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)
-
+    viewport $= (Position 0 0
-    bindFramebuffer Framebuffer $= (fst $ _fboLighting pdata)
+        ,divideSize (w ^. config . shadow_resolution) $ Size (round $ fst wins) (round $ snd wins))
-    let scPol = screenPolygon w
+    createLightMap pdata lightPoints nWalls nSils nsurfVs 
-    createLightMap pdata (w ^. config . shadow_resolution) lightPoints
+    viewport $= (Position 0 0, Size (round $ fst wins) (round $ snd wins))
-        (foregroundPics w) scPol nWalls
     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)

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 $

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 
 

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

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))
+findReverseEdge otherEdges (x,y,z) = (\(_,_,n) -> (x,y,z,n))
-    $ find (\(a,b,_) -> (x,y) == (b,a)) otherEdges
+    <$> 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

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
@@ -214,6 +214,23 @@ newFramebufferGivenStencil rboName = do
     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
     -> 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]
+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
+    vs
 pokeBezQStrat _ = []
 
 

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.Data
-import Polyhedra
+--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
+    ---- draw foreground elements to set z buffer
-    --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)
     drawShader (_lightingSurfaceShader pdata) nsurfVs 
--- for each of the lights: 
+    -- for each of the lights: 
--- stencil out the walls from this light's point of view
+    -- stencil out the walls from this light's point of view
--- draw fading lightmap circles on the floor
+    -- draw fading lightmap circles on the floor
--- draw fading lightmaps on the walls
+    -- draw fading lightmaps on the walls
-    --cullFace $= Nothing
     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
+    --blend $= Disabled
-    -- set the viewport size to that of the window
-    viewport $= (vppos, vpsize)
-    -- disable depth testing for blurring
 {- |
 Blur between two framebuffers.
 Assumes no depth testing is done