Refactor, try to limit dependencies

src/Dodge/Render.hs

@@ -1,66 +1,65 @@
-{- | Contains the central drawing functions for the dodge loop. -}
-module Dodge.Render 
-    ( doDrawing
-    ) where
-import Dodge.Data
-import Dodge.Render.Picture
-import Dodge.Render.ShapePicture
-import Dodge.Render.Walls
-import Dodge.Render.Lights
-import Geometry
-import Render
-import Data.Preload.Render
-import Shader
-import Shader.Poke
-import Shader.Bind
-import Shader.Data
-import MatrixHelper
-import Shader.ExtraPrimitive
-import Shader.Parameters
-import Picture.Data
+-- | Contains the central drawing functions for the dodge loop.
+module Dodge.Render (
+    doDrawing,
+) where
 
-import Foreign
 import Control.Lens
 import Control.Monad
 import qualified Control.Monad.Parallel as MP
-import Graphics.Rendering.OpenGL hiding (color,scale,translate,rotate)
-import qualified SDL
+import Data.Preload.Render
 import qualified Data.Vector.Unboxed.Mutable as UMV
+import Dodge.Data.Universe
+import Dodge.Render.Lights
+import Dodge.Render.Picture
+import Dodge.Render.ShapePicture
+import Dodge.Render.Walls
+import Foreign
+import Geometry
 import Graphics.GL.Core43
---import qualified Streaming.Prelude as S
+import Graphics.Rendering.OpenGL hiding (color, rotate, scale, translate)
+import MatrixHelper
+import Render
+import qualified SDL
+import Shader
+import Shader.Bind
+import Shader.Data
+import Shader.ExtraPrimitive
+import Shader.Parameters
+import Shader.Poke
 
 doDrawing :: RenderData -> Universe -> IO Word32
 doDrawing pdata u = do
     sTicks <- SDL.ticks
-    let w       = _uvWorld u
-        cfig    = _uvConfig u
-        rot     = _cameraRot (_cWorld w)
+    let w = _uvWorld u
+        cfig = _uvConfig u
+        rot = _cameraRot (_cWorld w)
         camzoom = _cameraZoom (_cWorld w)
-        trans   = _cameraCenter (_cWorld w)
+        trans = _cameraCenter (_cWorld w)
         wins@(V2 winx winy) = V2 (_windowX cfig) (_windowY cfig)
-        resFact             = resFactorNum $ cfig ^. graphics_resolution_factor
-        (wallPointsCol,windowPoints,wallSPics) = wallsToDraw w
-        lightPoints             = lightsToRender cfig w
-        viewFroms@(V2 vfx vfy)  = _cameraViewFrom (_cWorld w)
-        viewFrom3d              = Vector3 vfx vfy 20
-        shadV   = _pictureShaders pdata
-        lwShad  = _lightingWallShadShader pdata
+        resFact = resFactorNum $ cfig ^. graphics_resolution_factor
+        (wallPointsCol, windowPoints, wallSPics) = wallsToDraw w
+        lightPoints = lightsToRender cfig w
+        viewFroms@(V2 vfx vfy) = _cameraViewFrom (_cWorld w)
+        viewFrom3d = Vector3 vfx vfy 20
+        shadV = _pictureShaders pdata
+        lwShad = _lightingWallShadShader pdata
     -- bind as much data into vbos as feasible at this point
     -- count mutable vectors setup
-    layerCounts  <- UMV.replicate (numLayers*6) 0
+    layerCounts <- UMV.replicate (numLayers * 6) 0
     -- attempt to poke in parallel
-    let (ws,wp) = wallSPics <> worldSPic cfig w
+    let (ws, wp) = wallSPics <> worldSPic cfig w
     --( (nWalls, nWins , nFls),(nShapeVs, nIndices, nSilIndices) )
-    ( (nWalls, nWins , nFls),(nShapeVs, nIndices, nSilIndices) )
-        <- MP.bindM3 (\_ a b -> return (a,b))
+    ((nWalls, nWins, nFls), (nShapeVs, nIndices, nSilIndices)) <-
+        MP.bindM3
+            (\_ a b -> return (a, b))
             ( pokeLayVerxs
-                shadV 
+                shadV
                 layerCounts
                 wp
             )
             ( pokeWallsWindowsFloor
-                (shadVBOptr $ _wallTextureShader pdata) 
-                (shadVBOptr $ _windowShader pdata) 
+                (shadVBOptr $ _wallTextureShader pdata)
+                (shadVBOptr $ _windowShader pdata)
                 (shadVBOptr $ _textureArrayShader pdata)
                 wallPointsCol
                 windowPoints
@@ -70,41 +69,42 @@ doDrawing pdata u = do
                 (_vboPtr $ _vaoVBO $ _shadVAO $ _shapeShader pdata)
                 (_eboPtr $ _shapeEBO pdata)
                 (_eboPtr $ _silhouetteEBO pdata)
-                (0,0,0)
+                (0, 0, 0)
                 ws
             )
---            ( pokeSPics
---                shadV 
---                layerCounts
---                (_vboPtr $ _vaoVBO $ _shadVAO $ _shapeShader pdata)
---                (_eboPtr $ _shapeEBO pdata)
---                (_eboPtr $ _silhouetteEBO pdata)
---                (S.cons wallSPics $ worldSPic cfig w)
---            )
---        <- MP.bindM3 (\ _ wlwifl counts -> return (wlwifl,counts))
---            ( pokeBindFoldableLayer shadV layerCounts wp)
---            ( pokeWallsWindowsFloor
---                (shadVBOptr $ _wallTextureShader pdata) 
---                (shadVBOptr $ _windowShader pdata) 
---                (shadVBOptr $ _textureArrayShader pdata)
---                wallPointsCol
---                windowPoints
---                (_floorTiles w)
---            )
---            ( pokeShape
---                (_vboPtr $ _vaoVBO $ _shadVAO $ _shapeShader pdata)
---                (_eboPtr $ _shapeEBO pdata)
---                (_eboPtr $ _silhouetteEBO pdata)
---                ws
---            )
+    --            ( pokeSPics
+    --                shadV
+    --                layerCounts
+    --                (_vboPtr $ _vaoVBO $ _shadVAO $ _shapeShader pdata)
+    --                (_eboPtr $ _shapeEBO pdata)
+    --                (_eboPtr $ _silhouetteEBO pdata)
+    --                (S.cons wallSPics $ worldSPic cfig w)
+    --            )
+    --        <- MP.bindM3 (\ _ wlwifl counts -> return (wlwifl,counts))
+    --            ( pokeBindFoldableLayer shadV layerCounts wp)
+    --            ( pokeWallsWindowsFloor
+    --                (shadVBOptr $ _wallTextureShader pdata)
+    --                (shadVBOptr $ _windowShader pdata)
+    --                (shadVBOptr $ _textureArrayShader pdata)
+    --                wallPointsCol
+    --                windowPoints
+    --                (_floorTiles w)
+    --            )
+    --            ( pokeShape
+    --                (_vboPtr $ _vaoVBO $ _shadVAO $ _shapeShader pdata)
+    --                (_eboPtr $ _shapeEBO pdata)
+    --                (_eboPtr $ _silhouetteEBO pdata)
+    --                ws
+    --            )
     -- bind wall points, silhouette data, surface geometry
     bindShaderLayers shadV layerCounts
-    uncurry bindShaderBuffers $ unzip
-        [ ( _wallTextureShader pdata, nWalls)
-        , (_shapeShader pdata, nShapeVs)
-        , (_windowShader pdata, nWins)
-        , (_textureArrayShader pdata, nFls)
-        ]
+    uncurry bindShaderBuffers $
+        unzip
+            [ (_wallTextureShader pdata, nWalls)
+            , (_shapeShader pdata, nShapeVs)
+            , (_windowShader pdata, nWins)
+            , (_textureArrayShader pdata, nFls)
+            ]
     bindBuffer ElementArrayBuffer $= Just (_ebo $ _shapeEBO pdata)
     bufferSubData
         ElementArrayBuffer
@@ -124,16 +124,17 @@ doDrawing pdata u = do
     setViewportSize (round winx `div` resFact) (round winy `div` resFact)
     bindFramebuffer Framebuffer $= fst (_fboBase pdata)
     clearColor $= Color4 0 0 0 0
-    clear [ColorBuffer,DepthBuffer]
+    clear [ColorBuffer, DepthBuffer]
     depthFunc $= Just Less
     -- draw wall occlusions from the camera's point of view
     currentProgram $= Just (_shadProg lwShad)
-    uniform (head $  _shadUnis lwShad) $= viewFrom3d
+    uniform (head $ _shadUnis lwShad) $= viewFrom3d
     bindVertexArrayObject $= Just (_vao $ _shadVAO lwShad)
-    unless (debugOn Remove_LOS cfig) $ glDrawArrays 
-        (marshalEPrimitiveMode $ _shadPrim lwShad) 
-        0 
-        (fromIntegral nWalls)
+    unless (debugOn Remove_LOS cfig) $
+        glDrawArrays
+            (marshalEPrimitiveMode $ _shadPrim lwShad)
+            0
+            (fromIntegral nWalls)
     --draw walls onto base buffer
     if cfig ^. graphics_wall_textured
         then renderTextureWalls pdata nWalls
@@ -145,43 +146,43 @@ doDrawing pdata u = do
     currentProgram $= Just (_shadProg fs)
     bindVertexArrayObject $= Just (_vao $ _shadVAO fs)
     glDrawElements
-        (marshalEPrimitiveMode $ _shadPrim fs) 
+        (marshalEPrimitiveMode $ _shadPrim fs)
         (fromIntegral nIndices)
         GL_UNSIGNED_SHORT
         nullPtr
     --draw floor onto base buffer
---    nTextArrayVs <- pokePoint33s (shadVBOptr $ _textureArrayShader pdata) (_floorTiles w)
+    --    nTextArrayVs <- pokePoint33s (shadVBOptr $ _textureArrayShader pdata) (_floorTiles w)
     drawShader (_textureArrayShader pdata) nFls
     --draw lightmap into its own buffer
     bindFramebuffer Framebuffer $= fst (_fboLighting pdata)
     createLightMap
-        pdata 
-        lightPoints 
-        nWalls 
-        nSilIndices 
-        nIndices 
+        pdata
+        lightPoints
+        nWalls
+        nSilIndices
+        nIndices
         (_graphics_object_shadows $ _uvConfig u)
         (snd $ snd $ _fboBase pdata)
-    colorMask   $= Color4 Enabled Enabled Enabled Enabled
-    clearColor  $= Color4 0 0 0 0
+    colorMask $= Color4 Enabled Enabled Enabled Enabled
+    clearColor $= Color4 0 0 0 0
     --apply lightmap to base buffer
     bindFramebuffer Framebuffer $= fst (_fboBase pdata)
-    textureBinding Texture2D    $= Just (snd $ _fboLighting pdata)
-    blend       $= Enabled
-    blendFunc   $= (Zero, OneMinusSrcColor)
+    textureBinding Texture2D $= Just (snd $ _fboLighting pdata)
+    blend $= Enabled
+    blendFunc $= (Zero, OneMinusSrcColor)
     drawShader (_fullscreenShader pdata) 4
     --draw bloom onto bloom buffer
     bindFramebuffer Framebuffer $= fst (_fboBloom pdata)
     clear [ColorBuffer]
     depthFunc $= Just Less
-    blendFunc $= (SrcAlpha,OneMinusSrcAlpha)
+    blendFunc $= (SrcAlpha, OneMinusSrcAlpha)
     depthMask $= Disabled
     renderLayer BloomNoZWrite shadV layerCounts
     depthMask $= Enabled
     renderLayer BloomLayer shadV layerCounts
     --depthMask $= Enabled
     --setup downscale viewport for blurring bloom
-    setViewportSize (round winx `div` (2*resFact)) (round winy `div` (2*resFact))
+    setViewportSize (round winx `div` (2 * resFact)) (round winy `div` (2 * resFact))
     bindFramebuffer Framebuffer $= fst (_fboHalf1 pdata)
     depthFunc $= Just Always
     textureBinding Texture2D $= Just (snd $ _fboBloom pdata)
@@ -198,8 +199,8 @@ doDrawing pdata u = do
     --blendFunc $= (SrcAlphaSaturate,One)
     --blendColor $= Color4 0.5 0.5 0.5 0.5
     --blendFuncSeparate $= ((SrcAlphaSaturate,One) , (One,OneMinusSrcAlpha))
-    blendFuncSeparate $= ((SrcAlpha,OneMinusSrcAlpha),(One,OneMinusSrcAlpha))
-    drawBuffers $= [FBOColorAttachment 0,NoBuffers]
+    blendFuncSeparate $= ((SrcAlpha, OneMinusSrcAlpha), (One, OneMinusSrcAlpha))
+    drawBuffers $= [FBOColorAttachment 0, NoBuffers]
     clear [ColorBuffer]
     renderLayer MidLayer shadV layerCounts
     --renderWindows pdata windowPoints
@@ -208,14 +209,19 @@ doDrawing pdata u = do
         ----render transparency depths
         depthMask $= Enabled
         blend $= Disabled
-        drawBuffers $= [NoBuffers,FBOColorAttachment 1]
+        drawBuffers $= [NoBuffers, FBOColorAttachment 1]
         renderLayer MidLayer shadV layerCounts
         drawShader (_windowShader pdata) nWins
         ----draw lightmap for cloud buffer
         depthMask $= Disabled
         blend $= Enabled
         bindFramebuffer Framebuffer $= fst (_fboLighting pdata)
-        createLightMap pdata lightPoints nWalls nSilIndices nIndices 
+        createLightMap
+            pdata
+            lightPoints
+            nWalls
+            nSilIndices
+            nIndices
             (_graphics_object_shadows $ _uvConfig u)
             (snd $ snd $ _fboCloud pdata)
         colorMask $= Color4 Enabled Enabled Enabled Enabled
@@ -224,12 +230,12 @@ doDrawing pdata u = do
     clearColor $= Color4 0 0 0 0
     bindFramebuffer Framebuffer $= fst (_fboCloud pdata)
     depthMask $= Disabled
-    drawBuffers $= [FBOColorAttachment 0,NoBuffers]
+    drawBuffers $= [FBOColorAttachment 0, NoBuffers]
     depthFunc $= Just Always
     textureBinding Texture2D $= Just (snd $ _fboLighting pdata)
     blend $= Enabled
     --blendFunc $= (Zero, OneMinusSrcAlpha)
-    blendFuncSeparate $= ((Zero, OneMinusSrcColor),(Zero, One))
+    blendFuncSeparate $= ((Zero, OneMinusSrcColor), (Zero, One))
     drawShader (_fullscreenShader pdata) 4
     blendFunc $= (SrcAlpha, OneMinusSrcAlpha)
     -- bind base buffer for drawing bloom then clouds
@@ -246,7 +252,7 @@ doDrawing pdata u = do
     --set viewport for radial distortion
     setViewportSize (round winx) (round winy)
     depthFunc $= Just Always
-    blendFunc $= (One,Zero)
+    blendFunc $= (One, Zero)
     -- perform any radial distortion
     case _distortions (_cWorld w) of
         [] -> do
@@ -257,31 +263,33 @@ doDrawing pdata u = do
         rds -> do
             let bindDrawDist :: Distortion -> IO ()
                 bindDrawDist (RadialDistortion (V2 a b) (V2 c d) (V2 e f) g) = do
-                    pokeArray (shadVBOptr $ _barrelShader pdata) [a,b,c,d,e,f,g]
+                    pokeArray (shadVBOptr $ _barrelShader pdata) [a, b, c, d, e, f, g]
                     bindShaderBuffers [_barrelShader pdata] [1]
                     drawShader (_barrelShader pdata) 1
-                fboList = take (length rds - 1) (concat (repeat [fst $ _fbo2 pdata,fst $ _fbo3 pdata]))
-                    ++ [defaultFramebufferObject]
-                toList = fst (snd (_fboBase pdata)) : concat (repeat [snd $ _fbo2 pdata,snd $ _fbo3 pdata])
+                fboList =
+                    take (length rds - 1) (concat (repeat [fst $ _fbo2 pdata, fst $ _fbo3 pdata]))
+                        ++ [defaultFramebufferObject]
+                toList = fst (snd (_fboBase pdata)) : concat (repeat [snd $ _fbo2 pdata, snd $ _fbo3 pdata])
                 bindings = zipWith (>>) (map bindFBO fboList) (map bindTO toList)
             activeTexture $= TextureUnit 1
             zipWithM_ (>>) bindings $ map bindDrawDist rds
             activeTexture $= TextureUnit 0
     depthFunc $= Just Always
     blend $= Enabled
-    blendFunc $= (SrcAlpha,OneMinusSrcAlpha)
+    blendFunc $= (SrcAlpha, OneMinusSrcAlpha)
     renderLayer DebugLayer shadV layerCounts
     -- draw overlay
     depthFunc $= Just Always
     depthMask $= Disabled
     blend $= Enabled
-    blendFunc $= (SrcAlpha,OneMinusSrcAlpha)
+    blendFunc $= (SrcAlpha, OneMinusSrcAlpha)
     bufferUBO $ isoMatrix 0 1 (V2 0 0) (V2 2 2)
     renderLayer FixedCoordLayer shadV layerCounts
     renderFoldable shadV $ fixedCoordPictures u
     depthMask $= Enabled
     eTicks <- SDL.ticks
     return (eTicks - sTicks)
+
 --------------------------------------------------------------------------------
 -- note: currently assume there is only one UBO, we only bind it once at setup
 bufferUBO :: [Float] -> IO ()
@@ -289,24 +297,27 @@ bufferUBO mat = withArray mat $ \ptr ->
     bufferSubData UniformBuffer WriteToBuffer 0 64 ptr
 
 setViewportSize :: Int -> Int -> IO ()
-setViewportSize x y = viewport $= 
-    ( Position 0 0
-    , Size (fromIntegral x) (fromIntegral y)
-    )
+setViewportSize x y =
+    viewport
+        $= ( Position 0 0
+           , Size (fromIntegral x) (fromIntegral y)
+           )
 
-renderBlankWalls 
-    :: RenderData 
-    -> Int -- ^ number of walls
-    -> IO ()
+renderBlankWalls ::
+    RenderData ->
+    -- | number of walls
+    Int ->
+    IO ()
 renderBlankWalls pdata nWalls = do
     cullFace $= Just Back
     drawShader (_wallBlankShader pdata) nWalls
     cullFace $= Nothing
 
-renderTextureWalls 
-    :: RenderData 
-    -> Int   -- ^ number of walls
-    -> IO ()
+renderTextureWalls ::
+    RenderData ->
+    -- | number of walls
+    Int ->
+    IO ()
 renderTextureWalls pdata nWalls = do
     cullFace $= Just Back
     drawShader (_wallTextureShader pdata) nWalls