Linting

2021-04-23 11:10:45 +02:00
parent c740ca0844
commit ffe4a8083b
14 changed files with 329 additions and 286 deletions
@@ -1,25 +1,18 @@
-{-# LANGUAGE TemplateHaskell #-}
+--{-# LANGUAGE TemplateHaskell #-}
 --{-# LANGUAGE Strict #-}
 module Picture.Data
    where
+import Geometry.Data

 import Data.Monoid
+import Data.Traversable
 import qualified Data.Foldable as F
 import qualified Data.Sequence as Se
 import qualified Data.DList as DL
 import qualified Data.Vector as V
-import Geometry.Data
-
 import Control.Lens
-
--import Foreign
-
--import Graphics.Rendering.OpenGL hiding (Point (..),translate,scale,imageHeight,imageWidth)
-
 import Control.Monad 

-import Data.Traversable
-
 data RenderType
    = RenderPoly [(Point3,Point4)]
    | RenderBezQ [(Point3,Point4,Point4)]
@@ -42,6 +35,7 @@ instance Foldable FTree where
    foldMap g (FLeaf x) = g x
    {-# INLINE foldMap #-}

+{- Tree with values at and only at the leaves. -}
 data LTree a
    = LBranches [LTree a]
    | LLeaf a
@@ -50,7 +44,7 @@ instance Foldable LTree where
    foldMap g (LLeaf a) = g a
    {-# INLINE foldMap #-}
 instance Functor LTree where
-    fmap f (LBranches ts) = LBranches $ (fmap (fmap f)) ts
+    fmap f (LBranches ts) = LBranches $ fmap (fmap f) ts
    fmap f (LLeaf x) = LLeaf (f x)

 data RTree a b
@@ -61,7 +55,7 @@ instance Foldable (RTree a) where
    foldMap g (RLeaf x)      = g x
    {-# INLINE foldMap #-}
 instance Functor (RTree a) where
-    fmap f (RBranches i ts) = RBranches i $ (fmap (fmap f)) ts
+    fmap f (RBranches i ts) = RBranches i $ fmap (fmap f) ts
    fmap f (RLeaf x)      = RLeaf (f x)

 flat2 (x,y)     = [x,y]
@@ -123,7 +123,7 @@ setupFramebuffer = do
    framebufferRenderbuffer Framebuffer DepthStencilAttachment Renderbuffer fboRBO

    fboStatus <- framebufferStatus Framebuffer
-    putStrLn $ show fboStatus
+    print fboStatus

    return (fboName, fboTO, fboRBO)

@@ -1,40 +1,43 @@
--{-# LANGUAGE Strict #-}
-{-# LANGUAGE DeriveFoldable, StandaloneDeriving #-}
+--{-# LANGUAGE DeriveFoldable, StandaloneDeriving #-}
+{-
+Rendering of a picture.
+-}
 module Picture.Render
    ( module Picture.Render
    , picToLTree
--    , perspectiveMatrix 
    )
    where

 import Shader
 import MatrixHelper
-
-import Control.Lens
-import Control.Monad
-
-import qualified Control.Foldl as F
-
 import Picture.Preload
 import Picture.Data
 import Picture.Tree
 import Geometry

+import Control.Lens
+import Control.Monad
+import qualified Control.Foldl as F
 import Foreign hiding (rotate)
-
 import Graphics.Rendering.OpenGL hiding (Line,translate,scale,imageHeight,imageWidth,Polygon,Color,T)
-
 import Data.Foldable
 import Data.Maybe (fromJust)
-
 import qualified Data.IntMap.Strict as IM
+import qualified SDL

-import qualified SDL as SDL
-
-renderPicture' :: RenderData -> Float -> Float -> Point2 -> Point2 ->
-                    [((Point2,Point2),Point4)] -> [((Point2,Point2),Point4)] -> [Point4] ->
-                    (Float,Float) -> Picture -> IO (Word32)
-renderPicture' pdata rot zoom trans@(tranx,trany) wins@(winx,winy) wallPointsCol windowPoints lightPoints
+renderPicture
+    :: RenderData                   -- ^ Preloaded render data
+    -> Float                        -- ^ Rotation
+    -> Float                        -- ^ Zoom
+    -> Point2                       -- ^ Translation
+    -> Point2                       -- ^ Window size
+    -> [((Point2,Point2),Point4)]   -- ^ Wall data
+    -> [((Point2,Point2),Point4)]   -- ^ Window data
+    -> [Point4]                     -- ^ Lights data
+    -> (Float,Float)                -- ^ View from point
+    -> Picture                      -- ^ Picture
+    -> IO Word32                    -- ^ Time taken according to SDL.ticks
+renderPicture pdata rot zoom trans@(tranx,trany) wins@(winx,winy) wallPointsCol windowPoints lightPoints
                    viewFroms@(viewFromx,viewFromy) pic = do
    startTicks <- SDL.ticks
    let wallPoints = map fst wallPointsCol
@@ -83,27 +86,27 @@ renderWalls pdata wps pmat = do
    n <- F.foldM (pokeShader $ _wallFaceShader pdata) wps
    bindShaderBuffers [_wallFaceShader pdata] [n]
    currentProgram $= Just (_shaderProgram $ _wallFaceShader pdata)
-    uniform ( (fromJust $ _shaderCustomUnis $ _wallFaceShader pdata) !! 0)
+    uniform (head (fromJust $ _shaderCustomUnis $ _wallFaceShader pdata) )
            $= pmat
    drawShader (_wallFaceShader pdata) n

 setWallDepth :: RenderData -> [(Point2,Point2)] -> (Float,Float) -> GLmatrix GLfloat -> IO Word32
 setWallDepth pdata wallPoints (viewFromx,viewFromy) pmat = do
    startTicks <- SDL.ticks
-    colorMask $= (Color4 Disabled Disabled Disabled Disabled)
+    colorMask $= Color4 Disabled Disabled Disabled Disabled
    nWalls <- F.foldM (pokeShader $ _wallShadowShader pdata) wallPoints
    bindShaderBuffers [_wallShadowShader pdata] [nWalls]

    currentProgram $= Just (_shaderProgram $ _wallShadowShader pdata)
    uniform (head $ fromJust $ _shaderCustomUnis $ _wallShadowShader pdata)
            $= Vector2 viewFromx viewFromy  
-    uniform ( (fromJust $ _shaderCustomUnis $ _wallShadowShader pdata) !! 1)
+    uniform ( fromJust (_shaderCustomUnis $ _wallShadowShader pdata) !! 1)
            $= pmat
-    uniform ( (fromJust $ _shaderCustomUnis $ _wallShadowShader pdata) !! 2)
+    uniform ( fromJust (_shaderCustomUnis $ _wallShadowShader pdata) !! 2)
            $= (0 :: Float)
 --    cullFace $= Just Front
    drawShader (_wallShadowShader pdata) nWalls
-    colorMask $= (Color4 Enabled Enabled Enabled Enabled)
+    colorMask $= Color4 Enabled Enabled Enabled Enabled
    endTicks <- SDL.ticks
    return $ endTicks - startTicks

@@ -113,7 +116,7 @@ createLightMap :: RenderData -> Float -> Float -> (Float,Float) -> (Float,Float)
 createLightMap pdata rot zoom (tranx,trany) (winx,winy) wallPoints lightPoints
                    (viewFromx,viewFromy) pmat = do

-    bindFramebuffer Framebuffer $= (_spareFBO pdata)
+    bindFramebuffer Framebuffer $= _spareFBO pdata
 -- clear buffer to full alpha and furthest depth
    clearColor $= Color4 0 0 0 1
    clearDepth $= 1
@@ -126,17 +129,17 @@ createLightMap pdata rot zoom (tranx,trany) (winx,winy) wallPoints lightPoints
    bindShaderBuffers [_wallShadowShader pdata] [nWalls]
 -- set uniforms for shader that draws lights
    currentProgram $= Just (_shaderProgram $ _wallLightShader pdata)
-    uniform ( (fromJust $ _shaderCustomUnis $ _wallLightShader pdata) !! 1)
+    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)
+    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  
-    uniform ( (fromJust $ _shaderCustomUnis $ _wallShadowShader pdata) !! 1)
+    uniform ( fromJust (_shaderCustomUnis $ _wallShadowShader pdata) !! 1)
            $= pmat
-    uniform ( (fromJust $ _shaderCustomUnis $ _wallShadowShader pdata) !! 2)
+    uniform ( fromJust (_shaderCustomUnis $ _wallShadowShader pdata) !! 2)
            $= (0 :: Float)
    cullFace $= Just Back
    drawShader (_wallShadowShader pdata) nWalls
@@ -169,27 +172,27 @@ createLightMap pdata rot zoom (tranx,trany) (winx,winy) wallPoints lightPoints
        drawShader (_wallShadowShader pdata) nWalls
 -- draw floor light circles
        cullFace $= Nothing
-        colorMask $= (Color4 Disabled Disabled Disabled Enabled)
+        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  
-        uniform ( (fromJust $ _shaderCustomUnis $ _wallLightShader pdata) !! 2)
-                $= Vector2 r lum
+            $= Vector2 x y  
+        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)
+    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)
+    colorMask $= Color4 Enabled Enabled Enabled Enabled
    blend $= Enabled

 renderBackground :: RenderData -> Float -> Float -> (Float,Float) -> (Float,Float) -> IO ()
@@ -202,20 +205,20 @@ renderBackground pdata rot zoom (tranx,trany) (winx,winy) = do
    currentProgram $= Just (_shaderProgram $ _backgroundShader pdata)
    bindVertexArrayObject $= Just (_vao $ _shaderVAO $ _backgroundShader pdata)
    let backPtr = (\(_,x,_) -> x) $ head $ _vaoBufferTargets $ _shaderVAO $ _backgroundShader pdata
-        backPtr2 = (\(_,x,_) -> x) $ (_vaoBufferTargets $ _shaderVAO $ _backgroundShader pdata) !! 1
+        backPtr2 = (\(_,x,_) -> x) $ _vaoBufferTargets (_shaderVAO $ _backgroundShader pdata) !! 1
    pokeFourOff backPtr 0 (tranx,trany,rot,zoom)
    pokeTwoOff backPtr2 0  (winx,winy)
-    textureBinding Texture2D $= (fmap _textureObject $ _shaderTexture $ _backgroundShader pdata)
-    drawArrays Points (fromIntegral 0) (fromIntegral 1)
+    textureBinding Texture2D $= _textureObject <$> _shaderTexture (_backgroundShader pdata)
+    drawArrays Points 0 1

 setCommonUniforms :: RenderData -> Float -> Float -> (Float,Float) -> (Float,Float) -> IO ()
 setCommonUniforms pdata rot zoom (tranx,trany) (winx,winy) = do
    setShaderUniforms rot zoom (tranx,trany) (winx,winy) 
-        ( (extractProgAndUnis $ _lightSourceShader pdata) 
-        : (extractProgAndUnis $ _wallShadowShader pdata) 
-        : (extractProgAndUnis $ _wallLightShader pdata) 
-        : (extractProgAndUnis $ _backgroundShader pdata) 
-        : (map extractProgAndUnis $ _listShaders pdata)
+        ( extractProgAndUnis (_lightSourceShader pdata) 
+        : extractProgAndUnis (_wallShadowShader pdata) 
+        : extractProgAndUnis (_wallLightShader pdata) 
+        : extractProgAndUnis (_backgroundShader pdata) 
+        : map extractProgAndUnis (_listShaders pdata)
        )

 renderFoldable :: Foldable f => RenderData -> f RenderType -> IO Word32
@@ -1,3 +1,4 @@
+{- Transform a picture into renderable objects. -}
 module Picture.Tree
    ( picToLTree
    )
@@ -10,7 +11,11 @@ import Data.List

 -- todo: refactor out the layer check somehow
 -- consider generalising to alternative rather than using LTree
-picToLTree :: Maybe Int -> Picture -> LTree RenderType
+-- | Transform a picture into a tree of renderable objects
+picToLTree 
+    :: Maybe Int -- ^ Layer filter. Draw if 'Nothing' or when value is the same as at the leaf.
+    -> Picture
+    -> LTree RenderType
 {-# INLINE picToLTree #-}
 picToLTree mx (Polygon i ps)
    = filtB mx i $ LLeaf $ RenderPoly $ zip (map zeroZ $ polyToTris ps) $ repeat black
@@ -28,20 +33,22 @@ picToLTree mx (Circle i colC colE r)
                                         ,( ( r,-r,0), black)
                                         ]
 picToLTree mx (ThickArc i startA endA rad wdth) 
-    = filtB mx i $ LLeaf $ RenderArc $ ((0,0,0),black,(startA,endA,rad,wdth))
+    = filtB mx i $ LLeaf $ RenderArc ((0,0,0),black,(startA,endA,rad,wdth))
 picToLTree mx (Line i ps) 
    = filtB mx i $ LLeaf $ RenderLine $ zip (map zeroZ $ doubleLine ps) $ repeat white
 picToLTree mx (LineCol i vs) 
    = filtB mx i $ LLeaf $ RenderLine $ zip (map zeroZ $ doubleLine ps) $ doubleLine cs
-        where (ps,cs) = unzip vs
+  where (ps,cs) = unzip vs
 picToLTree mx (Text i s) 
    = filtB mx i $ LLeaf $ RenderText $ stringToList s
 picToLTree j Blank = LBranches []
 picToLTree j (Pictures pics) = LBranches $ map (picToLTree j) pics
 picToLTree j (OverPic f f' r f'' (OverPic g g' s g'' pic)) 
    = picToLTree j $ OverPic (f . g) (f' . g') (r + s) (f'' . g'') pic
-picToLTree j (OverPic f f' r f'' (Pictures ps)) = LBranches (map (picToLTree j . OverPic f f' r f'') ps)
-picToLTree j (OverPic f f' r f'' pic) = fmap (overPos f . overSca f' . overRot r . overCol f'') $ picToLTree j pic
+picToLTree j (OverPic f f' r f'' (Pictures ps)) 
+    = LBranches (map (picToLTree j . OverPic f f' r f'') ps)
+picToLTree j (OverPic f f' r f'' pic) 
+    = (overPos f . overSca f' . overRot r . overCol f'') <$> picToLTree j pic
 picToLTree (Just j) (OnLayer i pic) | j == i = picToLTree Nothing pic
                                    | otherwise = LBranches []
 picToLTree Nothing  (OnLayer _ pic) = picToLTree Nothing pic
@@ -53,7 +60,7 @@ filtB mx i t | Just i == mx || Nothing == mx = t

 doubleLine :: [a] -> [a]
 {-# INLINE doubleLine #-}
-doubleLine (x:y:xs) = concat $ zipWith (:) (init (x:y:xs)) $ map (\a -> [a]) (y:xs)
+doubleLine (x:y:xs) = concat $ zipWith (:) (init (x:y:xs)) $ map (: []) (y:xs)
 doubleLine _ = []

 white = (1,1,1,1)
@@ -70,8 +77,8 @@ scaleT (x,y) (a,b,(o,s,t)) = (a,b,(o,s*x,t*y))

 overPos :: (Point3 -> Point3) -> RenderType -> RenderType
 {-# INLINE overPos #-}
-overPos f (RenderPoly vs) = RenderPoly $ map (first $ f) vs
-overPos f (RenderLine vs) = RenderLine $ map (first $ f) vs
+overPos f (RenderPoly vs) = RenderPoly $ map (first f) vs
+overPos f (RenderLine vs) = RenderLine $ map (first f) vs
 overPos f (RenderText vs) = RenderText $ map (\(a,b,c) -> (f a,b,c)) vs
 overPos f (RenderBezQ vs) = RenderBezQ $ map (\(a,b,c) -> (f a,b,c)) vs
 overPos f (RenderEllipse vs) = RenderEllipse $ map (first f) vs
@@ -84,12 +91,12 @@ overRot _ ren = ren

 overCol :: (Point4 -> Point4) -> RenderType -> RenderType
 {-# INLINE overCol #-}
-overCol f (RenderPoly vs)      = RenderPoly $ map (second $ f) vs
-overCol f (RenderLine vs)      = RenderLine $ map (second $ f) vs
-overCol f (RenderEllipse vs)   = RenderEllipse $ map (second $ f) vs
-overCol f (RenderText vs)      = RenderText $ map (\(a,b,c) -> (a,f b,c)) vs
-overCol f (RenderBezQ vs)      = RenderBezQ $ map (\(a,b,c) -> (a,f b,c)) vs
-overCol f (RenderArc (a,b,c))   = RenderArc (a,f b,c)
+overCol f (RenderPoly vs)     = RenderPoly    $ map (second f) vs
+overCol f (RenderLine vs)     = RenderLine    $ map (second f) vs
+overCol f (RenderEllipse vs)  = RenderEllipse $ map (second f) vs
+overCol f (RenderText vs)     = RenderText    $ map (\(a,b,c) -> (a,f b,c)) vs
+overCol f (RenderBezQ vs)     = RenderBezQ    $ map (\(a,b,c) -> (a,f b,c)) vs
+overCol f (RenderArc (a,b,c)) = RenderArc (a,f b,c)

 overSca :: (Point2 -> Point2) -> RenderType -> RenderType
 {-# INLINE overSca #-}
@@ -110,12 +117,15 @@ charToTuple :: Char -> (Point3,Point4,Point3)
 charToTuple c = ((0,0,0),white,(offset,dimText,2*dimText))
    where offset = fromIntegral (fromEnum c) - 32

+{- Translate a 3D vector in the x and y directions. -}
 translate3 :: Float -> Float -> Point3 -> Point3
 {-# INLINE translate3 #-}
 translate3 a b (x,y,z) = (x+a,y+b,z)
+{- Scale a 3D vector in the x and y directions. -}
 scale3 :: Float -> Float -> Point3 -> Point3
 {-# INLINE scale3 #-}
 scale3 a b (x,y,z) = (x*a,y*b,z)
+{- Rotate a 3D vector in the x-y plane. -}
 rotate3 :: Float -> Point3 -> Point3
 {-# INLINE rotate3 #-}
 rotate3 a (x,y,z) = (x',y',z)