Add num_shadow_casters graphics parameter, allow cycle down enum options

src/Dodge/Data/Config.hs

@@ -10,6 +10,30 @@ import qualified Data.Set as S
 
 {-# ANN module "HLint: ignore Use camelCase" #-}
 
+data NumShadowCasters
+    = NumShadowCasters0
+    | NumShadowCasters1
+    | NumShadowCasters2
+    | NumShadowCasters3
+    | NumShadowCasters4
+    | NumShadowCasters5
+    | NumShadowCasters6
+    | NumShadowCasters7
+    | NumShadowCasters8
+    | NumShadowCasters9
+    | NumShadowCasters10
+    | NumShadowCasters11
+    | NumShadowCasters12
+    | NumShadowCasters13
+    | NumShadowCasters14
+    | NumShadowCasters15
+    | NumShadowCasters16
+    | NumShadowCasters17
+    | NumShadowCasters18
+    | NumShadowCasters19
+    | NumShadowCasters20
+    deriving (Show,Eq,Bounded,Ord,Enum)
+
 data Configuration = Configuration
     { _volume_master :: Float
     , _volume_sound :: Float
@@ -18,6 +42,7 @@ data Configuration = Configuration
     , _graphics_cloud_shadows :: Bool
     , _graphics_object_shadows :: ObjectShadows
     , _graphics_resolution_factor :: ResFactor
+    , _graphics_num_shadow_casters :: NumShadowCasters
     , _windowX :: Float
     , _windowY :: Float
     , _windowPosX :: Int
@@ -81,7 +106,8 @@ defaultConfig =
         , _graphics_wall_textured = True
         , _graphics_cloud_shadows = True
         , _graphics_object_shadows = GeoObjShads
-        , _graphics_resolution_factor = FullRes
+        , _graphics_resolution_factor = QuarterRes
+        , _graphics_num_shadow_casters = toEnum 10
         , _windowX = 800
         , _windowY = 600
         , _windowPosX = 0
@@ -95,6 +121,7 @@ debugOn :: DebugBool -> Configuration -> Bool
 debugOn db = S.member db . _debug_booleans
 
 makeLenses ''Configuration
+deriveJSON defaultOptions ''NumShadowCasters
 deriveJSON defaultOptions ''ResFactor
 deriveJSON defaultOptions ''ObjectShadows
 deriveJSON defaultOptions ''RoomClipping

src/Dodge/Menu.hs

@@ -186,6 +186,7 @@ graphicsMenuOptions =
     , makeBoolOption graphics_wall_textured "WALL TEXTURES"
     , makeEnumOption graphics_object_shadows "OBJECT SHADOWS" id
     , makeBoolOption graphics_cloud_shadows "CLOUD SHADOWS"
+    , makeEnumOption graphics_num_shadow_casters "SHADOW CASTERS" id
     ]
 
 gameOverMenu :: Universe -> ScreenLayer

src/Dodge/Menu/OptionType.hs

@@ -11,8 +11,9 @@ makeBoolOption lns t =
         (\u -> MODStringOption t (show (u ^# uvConfig . lns)))
 
 makeEnumOption lns str sideeff =
-    Toggle
+    Toggle2
         (\u -> sideeff (u & uvConfig . lns #%~ cycleEnum))
+        (\u -> sideeff (u & uvConfig . lns #%~ cycleDownEnum))
         (\u -> MODStringOption str (show (u ^# uvConfig . lns)))
 
 makeSubmenuOption submenu t = Toggle (pushScreen submenu) (const t)
@@ -21,3 +22,8 @@ cycleEnum :: (Eq a, Enum a, Bounded a) => a -> a
 cycleEnum x
     | x == maxBound = minBound
     | otherwise = succ x
+
+cycleDownEnum :: (Eq a, Enum a, Bounded a) => a -> a
+cycleDownEnum x
+    | x == minBound = maxBound
+    | otherwise = pred x

src/Dodge/Render.hs

@@ -21,7 +21,7 @@ import Graphics.GL.Core43
 import Graphics.Rendering.OpenGL hiding (color, rotate, scale, translate)
 import MatrixHelper
 import Render
-import qualified SDL
+--import qualified SDL
 import Shader
 import Shader.Bind
 import Shader.Data
@@ -29,9 +29,9 @@ import Shader.ExtraPrimitive
 import Shader.Parameters
 import Shader.Poke
 
-doDrawing :: RenderData -> Universe -> IO Word32
+doDrawing :: RenderData -> Universe -> IO ()
 doDrawing pdata u = do
-    sTicks <- SDL.ticks
+--    sTicks <- SDL.ticks
     let w = _uvWorld u
         cfig = _uvConfig u
         rot = w ^. cWorld . camPos . camRot
@@ -293,8 +293,8 @@ doDrawing pdata u = do
     renderLayer FixedCoordLayer shadV layerCounts
     renderFoldable shadV $ fixedCoordPictures u
     depthMask $= Enabled
-    eTicks <- SDL.ticks
+--    eTicks <- SDL.ticks
-    return (eTicks - sTicks)
+--    return (eTicks - sTicks)
 
 --------------------------------------------------------------------------------
 -- note: currently assume there is only one UBO, we only bind it once at setup

src/Dodge/Render/Lights.hs

@@ -2,6 +2,7 @@ module Dodge.Render.Lights (
     lightsToRender,
 ) where
 
+import Data.List (sortOn)
 import Data.Maybe
 import Dodge.Data.LWorld
 import Dodge.Data.CamPos
@@ -11,7 +12,9 @@ import qualified IntMapHelp as IM
 import Control.Lens
 
 lightsToRender :: Configuration -> CamPos -> LWorld -> [(Point3, Float, Point3)]
-lightsToRender cfig campos w =
+{-# INLINE lightsToRender #-}
+lightsToRender cfig campos w =  take (fromEnum $ cfig ^. graphics_num_shadow_casters) $
+    sortOn (\(_,x,_) -> negate x) $
     mapMaybe getLS (IM.elems $ w ^. lightSources)
         ++ mapMaybe getTLS (w ^. tempLightSources)
   where

src/Dodge/TestString.hs

@@ -1,5 +1,7 @@
 module Dodge.TestString where
 
+import Dodge.Render.ShapePicture
+import Dodge.Render.Lights
 import Data.Aeson (ToJSON)
 import Data.ByteString.Lazy.Char8 (unpack)
 import qualified Data.Aeson.Encode.Pretty as AEP
@@ -10,7 +12,11 @@ import Dodge.Data.Universe
 --import qualified Data.Map.Strict as M
 --import qualified IntMapHelp as IM
 testStringInit :: Universe -> [String]
-testStringInit u = [show $ u ^? uvWorld . hud . hudElement . diSections . sssExtra . sssSelPos . _Just]
+testStringInit u = [show $ length $ lightsToRender (u ^. uvConfig) (u ^. uvWorld . cWorld . camPos) 
+        (u ^. uvWorld . cWorld . lWorld)
+        , show $ length $ fst $ worldSPic (u ^. uvConfig) (u ^. uvWorld)
+        , show $ length $ snd $ worldSPic (u ^. uvConfig) (u ^. uvWorld) ]
+    --[show $ u ^? uvWorld . hud . hudElement . diSections . sssExtra . sssSelPos . _Just]
 --    [show $ fmap IM.keys $ u ^? uvWorld . hud . hudElement . subInventory . ciSections . sssSections]
 
 getPretty :: ToJSON a => a -> [String]

src/Preload/Render.hs

@@ -1,23 +1,22 @@
 --{-# LANGUAGE TemplateHaskell #-}
 --{-# OPTIONS_GHC -Wno-unused-top-binds #-}
-module Preload.Render
+module Preload.Render (
-    ( preloadRender
+    preloadRender,
-    , cleanUpRenderPreload
+    cleanUpRenderPreload,
-    )
+) where
-    where
-import Shader
-import Shader.Data
-import Shader.Compile
-import Shader.AuxAddition
-import Shader.Parameters
-import Shader.Bind
-import Framebuffer.Setup
-import Data.Preload.Render
 
-import Graphics.Rendering.OpenGL hiding (Point,translate,scale,imageHeight)
 import Control.Monad
-import Foreign
+import Data.Preload.Render
 import qualified Data.Vector.Mutable as MV
+import Foreign
+import Framebuffer.Setup
+import Graphics.Rendering.OpenGL hiding (Point, imageHeight, scale, translate)
+import Shader
+import Shader.AuxAddition
+import Shader.Bind
+import Shader.Compile
+import Shader.Data
+import Shader.Parameters
 
 numDrawableWalls :: Int
 numDrawableWalls = 5000
@@ -33,8 +32,8 @@ preloadRender = do
     wpVBOname <- genObjectName
     wpVBOptr <- mallocArray (8 * numDrawableWalls)
     bindBuffer ArrayBuffer $= Just wpVBOname
-    bufferData ArrayBuffer $=
+    bufferData ArrayBuffer
-        (fromIntegral $ floatSize * numDrawableWalls * 8
+        $= ( fromIntegral $ floatSize * numDrawableWalls * 8
            , nullPtr
            , StreamDraw
            )
@@ -53,8 +52,8 @@ preloadRender = do
     winVBOname <- genObjectName
     winVBOptr <- mallocArray (8 * numDrawableWalls)
     bindBuffer ArrayBuffer $= Just winVBOname
-    bufferData ArrayBuffer $=
+    bufferData ArrayBuffer
-        (fromIntegral $ floatSize * numDrawableWalls * 8
+        $= ( fromIntegral $ floatSize * numDrawableWalls * 8
            , nullPtr
            , StreamDraw
            )
@@ -68,8 +67,8 @@ preloadRender = do
     shEBOname <- genObjectName
     shEBOptr <- mallocArray numDrawableElements
     bindBuffer ElementArrayBuffer $= Just shEBOname
-    bufferData ElementArrayBuffer $=
+    bufferData ElementArrayBuffer
-        ( fromIntegral $ glushortSize * numDrawableElements
+        $= ( fromIntegral $ glushortSize * numDrawableElements
            , nullPtr
            , StreamDraw
            )
@@ -77,8 +76,8 @@ preloadRender = do
     shVBOname <- genObjectName
     shVBOptr <- mallocArray (7 * numDrawableElements)
     bindBuffer ArrayBuffer $= Just shVBOname
-    bufferData ArrayBuffer $=
+    bufferData ArrayBuffer
-        ( fromIntegral $ floatSize * numDrawableElements * 7
+        $= ( fromIntegral $ floatSize * numDrawableElements * 7
            , nullPtr
            , StreamDraw
            )
@@ -106,21 +105,22 @@ preloadRender = do
     silEBOptr <- mallocArray numDrawableElements
     -- it may be important to bind this while the correct VAO is bound
     bindBuffer ElementArrayBuffer $= Just silEBOname
-    bufferData ElementArrayBuffer $=
+    bufferData ElementArrayBuffer
-        ( fromIntegral $ glushortSize * numDrawableElements
+        $= ( fromIntegral $ glushortSize * numDrawableElements
            , nullPtr
            , StreamDraw
            )
     let silEBO = EBO{_ebo = silEBOname, _eboPtr = silEBOptr}
         shEdgeVAO = VAO{_vao = shEdgeVAOname, _vaoVBO = shVBO}
     -- lighting shaders
-    lightingWallShadShad <- makeShaderUsingVAO "lighting/wallShadow" [vert,geom,frag] EPoints wpVAO
+    lightingWallShadShad <-
+        makeShaderUsingVAO "lighting/wallShadow" [vert, geom, frag] EPoints wpVAO
             >>= addUniforms ["lightPos"]
-    lightingCapShad
+    lightingCapShad <-
-         <- makeShaderUsingVAO "lighting/cap" [vert,geom,frag] ETriangles shPosVAO
+        makeShaderUsingVAO "lighting/cap" [vert, geom, frag] ETriangles shPosVAO
             >>= addUniforms ["lightPos"]
-    lightingLineShadowShad
+    lightingLineShadowShad <-
-        <- makeShaderUsingVAO "lighting/lineShadow" [vert,geom,frag] ELinesAdjacency shEdgeVAO
+        makeShaderUsingVAO "lighting/lineShadow" [vert, geom, frag] ELinesAdjacency shEdgeVAO
             >>= addUniforms ["lightPos", "radiusUniform"]
     -- positional shader
     positionalBlankShad <- makeShader "positional/blank" [vert, frag] [3] ETriangles
@@ -130,7 +130,8 @@ preloadRender = do
     aslist <- makeShader "dualTwoD/arc" [vert, frag] [3, 4, 3] ETriangles
     eslist <- makeShader "dualTwoD/ellipse" [vert, geom, frag] [3, 4] ETriangles
     bezierQuadShader <- makeShader "dualTwoD/bezierQuad" [vert, frag] [3, 4, 4] ETriangleStrip
-    cslist <- makeShader "dualTwoD/character" [vert,frag] [3,4,2] ETriangles 
+    cslist <-
+        makeShader "dualTwoD/character" [vert, frag] [3, 4, 2] ETriangles
             >>= vaddTextureNoFilter "data/texture/charMap.png"
     -- this should really be a 2d texture array
     basicTweakZShad <- makeShader "dualTwoD/basicTweakZ" [vert, frag] [4, 4] ETriangles
@@ -145,16 +146,19 @@ preloadRender = do
     bloomBlurShad <- makeShaderUsingShaderVAO "texture/bloomBlur" [vert, frag] ETriangleStrip fsShad
     colorBlurShad <- makeShaderUsingShaderVAO "texture/colorBlur" [vert, frag] ETriangleStrip fsShad
     grayscaleShad <- makeShaderUsingShaderVAO "texture/grayscale" [vert, frag] ETriangleStrip fsShad
-    lightingTextureShad <- makeShaderUsingShaderVAO "lighting/texture" [vert,frag] ETriangleStrip fsShad
+    lightingTextureShad <-
+        makeShaderUsingShaderVAO "lighting/texture" [vert, frag] ETriangleStrip fsShad
             >>= addUniforms ["lightPos", "lumRad"]
     barrelShad <- makeShader "texture/barrel" [vert, geom, frag] [2, 2, 2, 1] EPoints
     -- blank wallShader
     wallBlankShad <- makeShaderUsingVAO "wall/blank" [vert, geom, frag] EPoints wpColVAO
     -- textured wallShader
-    wallTextureShad <- makeShaderUsingVAO "wall/texture" [vert,geom,frag] EPoints wpColVAO
+    wallTextureShad <-
+        makeShaderUsingVAO "wall/texture" [vert, geom, frag] EPoints wpColVAO
             >>= addTexture "data/texture/grayscaleDirt.png"
     ---- texture array shader
-    textArrayShad <- makeShader "texture/arrayPos" [vert,frag] [3,3] ETriangles
+    textArrayShad <-
+        makeShader "texture/arrayPos" [vert, frag] [3, 3] ETriangles
             >>= addTextureArray "data/texture/ayene_wooden_floor_transformed.png"
     --  >>= addTextureArray "data/texture/ayene_wooden_floor.png"
     -- bind fixed vertex data
@@ -185,7 +189,9 @@ preloadRender = do
     clearColor $= Color4 0 0 0 1
 
     shadV <- MV.new 6
-    zipWithM_ (MV.write shadV) [0..5] 
+    zipWithM_
+        (MV.write shadV)
+        [0 .. 5]
         [ bslist -- note the ordering is very important
         , basicTweakZShad -- ShadNum
         , bezierQuadShader
@@ -194,7 +200,8 @@ preloadRender = do
         , eslist
         ]
 
-    return $ RenderData
+    return $
+        RenderData
             { _pictureShaders = shadV
             , _shapeShader = bslista{_shadVAO = shPosColVAO}
             , _shapeEBO = shEBO
@@ -228,6 +235,7 @@ preloadRender = do
             , _rboBaseBloom = rboBaseBloomName
             , _matUBO = theUBO
             }
+
 --------------------end preloadRender
 cornerList :: [[Float]]
 cornerList =
@@ -236,6 +244,7 @@ cornerList =
     , [1, 1, 1, 1]
     , [1, -1, 1, 0]
     ]
+
 cleanUpRenderPreload :: RenderData -> IO ()
 cleanUpRenderPreload pd = do
     -- TODO fix this

src/Render.hs

@@ -63,14 +63,14 @@ createLightMap pdata lightPoints nWalls nSils nCaps drawObjShads toPos drawCPUSh
     -- to consider: adding normals/a "material" for each fragment
     blendFunc $= (Zero, OneMinusSrcColor)
     stencilTest $= Enabled
+    stencilOpSeparate Front $= (OpKeep, OpKeep, OpIncrWrap)
+    stencilOpSeparate Back $= (OpKeep, OpKeep, OpDecrWrap)
     flip VFSM.mapM_ (VFSM.fromList lightPoints) $ \(V3 x y z, rad, V3 r g b) -> do
         depthFunc $= Just Less
         -- setup stencil
         colorMask $= Color4 Disabled Disabled Disabled Disabled
         clear [StencilBuffer]
         cullFace $= Nothing
-        stencilOpSeparate Front $= (OpKeep, OpKeep, OpIncrWrap)
-        stencilOpSeparate Back $= (OpKeep, OpKeep, OpDecrWrap)
         stencilFunc $= (Always, 0, 255)
         --draw wall shadows
         currentProgram $= Just (_shadProg lwallShad)
@@ -110,7 +110,7 @@ createLightMap pdata lightPoints nWalls nSils nCaps drawObjShads toPos drawCPUSh
         -- bind world position texture
         bindTO toPos
         colorMask $= Color4 Enabled Enabled Enabled Enabled
-        stencilOp $= (OpKeep, OpKeep, OpKeep)
+        --stencilOp $= (OpKeep, OpKeep, OpKeep)
         stencilFunc $= (Equal, 0, 255)
         currentProgram $= ltextShad ^? shadProg --Just (_shadProg ltextShad)
         uniform (_shadUnis ltextShad V.! 0) $= Vector3 x y z