Cleanup

2026-01-02 11:07:47 +00:00
parent 119234af89
commit 804e4eb1e2
4 changed files with 60 additions and 93 deletions
@@ -21,31 +21,30 @@ import ShapePicture

 worldSPic :: Config -> Universe -> SPic
 worldSPic cfig u =
--    (mempty :!: extraPics cfig u)
--        <> foldup propSPic (filtOn _prPos _props)
--        <> foldMap' debrisSPic (filtOn' (xyV3 . _dbPos) _debris)
--        <> foldup drawProjectile (filtOn (^. pjPos . _xy) _projectiles)
--        <> foldup drawPulseBall (filtOn _pbPos _pulseBalls)
--        <> foldup (shiftDraw _blPos _blDir (const drawBlock)) (filtOn _blPos _blocks)
--        <> foldMap' (shiftDraw _fsPos _fsDir (const _fsSPic)) (filtOn' _fsPos _foreShapes)
--        <> foldup (drawCreature (lw ^. items)) (filtOn (^. crPos . _xy) _creatures)
--        <> foldup
--            (Prelude.uncurry floorItemSPic)
--            ( IM.intersectionWith
--                (,)
--                (lw ^. items)
--                (filtOn _flItPos _floorItems)
--            )
--        <> foldup btSPic (filtOn _btPos _buttons)
--        <> foldup (mcSPic (w ^. cWorld)) (filtOn _mcPos _machines)
--        <> foldMap' drawChasm (w ^. cWorld . chasms)
--        <> w ^. cWorld . lWorld . tempSPic
--        <> 
-          testSPic cfig u
+    (mempty :!: extraPics cfig u)
+        <> foldup propSPic (filtOn _prPos _props)
+        <> foldMap' debrisSPic (filtOn' (xyV3 . _dbPos) _debris)
+        <> foldup drawProjectile (filtOn (^. pjPos . _xy) _projectiles)
+        <> foldup drawPulseBall (filtOn _pbPos _pulseBalls)
+        <> foldup (shiftDraw _blPos _blDir (const drawBlock)) (filtOn _blPos _blocks)
+        <> foldMap' (shiftDraw _fsPos _fsDir (const _fsSPic)) (filtOn' _fsPos _foreShapes)
+        <> foldup (drawCreature (lw ^. items)) (filtOn (^. crPos . _xy) _creatures)
+        <> foldup
+            (Prelude.uncurry floorItemSPic)
+            ( IM.intersectionWith
+                (,)
+                (lw ^. items)
+                (filtOn _flItPos _floorItems)
+            )
+        <> foldup btSPic (filtOn _btPos _buttons)
+        <> foldup (mcSPic (w ^. cWorld)) (filtOn _mcPos _machines)
+        <> foldMap' drawChasm (w ^. cWorld . chasms)
+        <> w ^. cWorld . lWorld . tempSPic
+        <> testSPic cfig u
  where
    w = u ^. uvWorld
    lw = w ^. cWorld . lWorld
-    --foldup = foldMap'
+    foldup = foldMap'
    filtOn f g = IM.filter (pointIsClose . f) (g lw)
    filtOn' f g = filter (pointIsClose . f) (g lw)
    pointIsClose = cullPoint cfig w
@@ -54,26 +53,27 @@ testSPic :: Config -> Universe -> SPic
 testSPic cfig u = noShape $ testPic cfig u

 testPic :: Config -> Universe -> Picture
-testPic _ _ = f
-    $ mempty
-    <> color white (line [0,10])
-    <> text "A"
-    <> translate 20 20 (arc pi 0 10)
-    <> translate 0 20 (circleSolidCol white red 10)
-  where
-    f x = translate 5 20 (setLayer DebugLayer x) <> setLayer BloomLayer x
--    fold $ do
--    cr <- u ^? uvWorld . cWorld . lWorld . creatures . ix 0
----    return mempty
--    invid <- cr ^? crManipulation . manObject . imRootSelectedItem . unNInt
--    loc <- invIndents ((\k -> u ^?! uvWorld . cWorld . lWorld . items . ix k) <$> _crInv cr) 
--        ^? ix invid . _2
--    return . color red $ setLayer DebugLayer $ reduceLocDT (f cr) loc
+testPic _ _ = mempty
+--    f
+--    $ mempty
+--    <> color white (line [0,10])
+--    <> text "A"
+--    <> translate 20 20 (arc pi 0 10)
+--    <> translate 0 20 (circleSolidCol white red 10)
 --  where
--    f cr loc = foldMap g $ map (muzzlePos loc cr)  (itemMuzzles $ loc ^. locDT . dtValue . _1)
--      where
--        g :: Point3Q -> Picture
--        g pq = translate3 (pq ^. _1) $ crossPic 5
+--    f x = translate 5 20 (setLayer DebugLayer x) <> setLayer BloomLayer x
+----    fold $ do
+----    cr <- u ^? uvWorld . cWorld . lWorld . creatures . ix 0
+------    return mempty
+----    invid <- cr ^? crManipulation . manObject . imRootSelectedItem . unNInt
+----    loc <- invIndents ((\k -> u ^?! uvWorld . cWorld . lWorld . items . ix k) <$> _crInv cr) 
+----        ^? ix invid . _2
+----    return . color red $ setLayer DebugLayer $ reduceLocDT (f cr) loc
+----  where
+----    f cr loc = foldMap g $ map (muzzlePos loc cr)  (itemMuzzles $ loc ^. locDT . dtValue . _1)
+----      where
+----        g :: Point3Q -> Picture
+----        g pq = translate3 (pq ^. _1) $ crossPic 5


 drawBlock :: Block -> SPic
@@ -20,7 +20,6 @@ data Verx = Verx
 data Layer
    = BloomLayer
    | DebugLayer
--    | DebugLayer1
    | FixedCoordLayer
    deriving (Eq, Ord, Enum, Bounded, Show, Read) --Generic, Flat)

@@ -1,10 +1,9 @@
 module Render (
    createLightMap,
    renderLayer,
-    pingPongBetween,
-    bindFBO,
 ) where

+import Shader.Parameters
 import Dodge.Base.Coordinate
 import Dodge.Data.Camera
 import Control.Lens
@@ -18,7 +17,6 @@ import Foreign hiding (rotate)
 import Geometry.Data
 import Graphics.GL.Core45
 import Picture.Data
-import Shader
 import Shader.Data

 {- | Determine where light is shining in the world.
@@ -104,12 +102,11 @@ renderLightingNoShadows positiontexture normaltexture lightPoints pdata = do
 renderFlatLighting :: RenderData -> IO ()
 renderFlatLighting pdata = do
    glBindFramebuffer GL_FRAMEBUFFER (_unFBO (fst (_fboLighting pdata)))
-    withArray [0, 0, 0, 1] $ \ptr ->
+    withArray [0, 0, 0, 1] $
        glClearNamedFramebufferfv
            (pdata ^. fboLighting . _1 . unFBO)
            GL_COLOR
            0
-            ptr
    glDisable GL_CULL_FACE
    glDepthFunc GL_ALWAYS
    glDepthMask GL_FALSE
@@ -206,21 +203,6 @@ renderShadows isclouds cam cfig shadrendertype nWalls nSils nCaps positiontextur
    glStencilOp GL_KEEP GL_KEEP GL_KEEP
    glColorMask GL_TRUE GL_TRUE GL_TRUE GL_TRUE

-- assumes that vertices have already been sent to the shader
-pingPongBetween ::
-    (FBO, TO) ->
-    (FBO, TO) ->
-    GLuint ->
-    IO ()
-pingPongBetween (fb1, to1) (fb2, to2) fs = do
-    glBindFramebuffer GL_FRAMEBUFFER (_unFBO fb2)
-    glBindTextureUnit 0 (_unTO to1)
-    glUseProgram fs
-    glDrawArrays GL_TRIANGLES 0 6
-    glBindFramebuffer GL_FRAMEBUFFER (_unFBO fb1)
-    glBindTextureUnit 0 (_unTO to2)
-    glDrawArrays GL_TRIANGLES 0 6
-
 renderLayer ::
    Layer ->
    MV.MVector (PrimState IO) (GLuint, VBO) ->
@@ -233,7 +215,20 @@ renderLayer layer shads counts = do
  where
    ln = fromEnum layer

-bindFBO :: FBO -> IO ()
-bindFBO fb =
-    --bindFramebuffer Framebuffer $= fb
-    glBindFramebuffer GL_FRAMEBUFFER (_unFBO fb)
+drawShaderLay :: Int -> UMV.MVector (PrimState IO) Int -> Int -> (GLuint, VBO) -> IO ()
+{-# INLINE drawShaderLay #-}
+drawShaderLay l countsVector shadIn fs = do
+--    putStr $ "  shader: " <> show shadIn
+    i <- UMV.read countsVector shadIn
+--    putStrLn $ "    count:  " <> show i
+    glUseProgram (fst fs)
+    glUniform1i 0 . fromIntegral $ (l * numSubElements)
+    glDrawArrays
+        GL_TRIANGLES
+        (fromIntegral $ l * numSubElements)
+        (drawCountMod shadIn i)
+
+drawCountMod :: Int -> Int -> GLsizei
+drawCountMod i n
+    | i == 3 = fromIntegral $ 2 * n  -- modifies ellipse draw count
+    | otherwise = fromIntegral n
@@ -1,27 +0,0 @@
-module Shader (drawShaderLay) where
-
--import Picture.Data
-import Control.Monad.Primitive
-import qualified Data.Vector.Unboxed.Mutable as UMV
-import Graphics.GL.Core45
-import Shader.Data
-import Shader.Parameters
-
-drawShaderLay :: Int -> UMV.MVector (PrimState IO) Int -> Int -> (GLuint, VBO) -> IO ()
-{-# INLINE drawShaderLay #-}
-drawShaderLay l countsVector shadIn fs = do
-    putStr $ "  shader: " <> show shadIn
-    i <- UMV.read countsVector shadIn
-    putStrLn $ "    count:  " <> show i
-    glUseProgram (fst fs)
-    glUniform1i 0 . fromIntegral $ (l * numSubElements)
--    if l == fromEnum DebugLayer && shadIn == 0 then print i else return ()
-    glDrawArrays
-        GL_TRIANGLES
-        (fromIntegral $ l * numSubElements)
-        (drawCountMod shadIn i)
-
-drawCountMod :: Int -> Int -> GLsizei
-drawCountMod i n
-    | i == 3 = fromIntegral $ 2 * n  -- modifies ellipse draw count
-    | otherwise = fromIntegral n