Add num_shadow_casters graphics parameter, allow cycle down enum options

2023-02-26 23:38:58 +00:00
parent bf1bd5bb0b
commit 6b0f78d4eb
9 changed files with 203 additions and 151 deletions
@@ -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
@@ -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
@@ -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
@@ -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
-    return (eTicks - sTicks)
+--    eTicks <- SDL.ticks
+--    return (eTicks - sTicks)

 --------------------------------------------------------------------------------
 -- note: currently assume there is only one UBO, we only bind it once at setup
@@ -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
@@ -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]
@@ -1,23 +1,22 @@
 --{-# LANGUAGE TemplateHaskell #-}
 --{-# OPTIONS_GHC -Wno-unused-top-binds #-}
-module Preload.Render
-    ( preloadRender
-    , cleanUpRenderPreload
-    )
-    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
+module Preload.Render (
+    preloadRender,
+    cleanUpRenderPreload,
+) where

-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 $=
-        (fromIntegral $ floatSize * numDrawableWalls * 8
+    bufferData ArrayBuffer
+        $= ( fromIntegral $ floatSize * numDrawableWalls * 8
           , nullPtr
           , StreamDraw
           )
@@ -53,8 +52,8 @@ preloadRender = do
    winVBOname <- genObjectName
    winVBOptr <- mallocArray (8 * numDrawableWalls)
    bindBuffer ArrayBuffer $= Just winVBOname
-    bufferData ArrayBuffer $=
-        (fromIntegral $ floatSize * numDrawableWalls * 8
+    bufferData ArrayBuffer
+        $= ( fromIntegral $ floatSize * numDrawableWalls * 8
           , nullPtr
           , StreamDraw
           )
@@ -68,8 +67,8 @@ preloadRender = do
    shEBOname <- genObjectName
    shEBOptr <- mallocArray numDrawableElements
    bindBuffer ElementArrayBuffer $= Just shEBOname
-    bufferData ElementArrayBuffer $=
-        ( fromIntegral $ glushortSize * numDrawableElements
+    bufferData ElementArrayBuffer
+        $= ( fromIntegral $ glushortSize * numDrawableElements
           , nullPtr
           , StreamDraw
           )
@@ -77,8 +76,8 @@ preloadRender = do
    shVBOname <- genObjectName
    shVBOptr <- mallocArray (7 * numDrawableElements)
    bindBuffer ArrayBuffer $= Just shVBOname
-    bufferData ArrayBuffer $=
-        ( fromIntegral $ floatSize * numDrawableElements * 7
+    bufferData ArrayBuffer
+        $= ( 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 $=
-        ( fromIntegral $ glushortSize * numDrawableElements
+    bufferData ElementArrayBuffer
+        $= ( 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
-         <- makeShaderUsingVAO "lighting/cap" [vert,geom,frag] ETriangles shPosVAO
+    lightingCapShad <-
+        makeShaderUsingVAO "lighting/cap" [vert, geom, frag] ETriangles shPosVAO
            >>= addUniforms ["lightPos"]
-    lightingLineShadowShad
-        <- makeShaderUsingVAO "lighting/lineShadow" [vert,geom,frag] ELinesAdjacency shEdgeVAO
+    lightingLineShadowShad <-
+        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
@@ -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