Fix resetting of immutable chasm/floor data storage on new world load

This commit is contained in:
2025-11-22 11:27:41 +00:00
parent 54ca961496
commit a381633dc8
6 changed files with 159 additions and 176 deletions
+19 -12
View File
@@ -1,5 +1,6 @@
module Dodge.WorldLoad (postUniverseLoadSideEffect) where
import GLHelp
import Control.Lens
import Control.Monad
import Data.Preload.Render
@@ -8,26 +9,32 @@ import Graphics.GL.Core45
import Shader.Data
import Shader.Parameters
import Shader.Poke.Floor
import Foreign.Marshal
postUniverseLoadSideEffect :: Universe -> Universe
postUniverseLoadSideEffect =
uvIOEffects
%~ (\f uv -> (uvWorld . cWorld) (postWorldLoad (uv ^. preloadData . renderData)) uv >>= f)
%~ (\f uv -> (postWorldLoad (uv ^. preloadData . renderData) uv) >>= f)
postWorldLoad :: RenderData -> CWorld -> IO CWorld
postWorldLoad :: RenderData -> Universe -> IO Universe
postWorldLoad rdata cw = do
let floorbo = (rdata ^. floorVBO . vboName)
floorptr = (rdata ^. floorVBO . vboPtr)
nfloorvxs <- foldM (pokeTile floorptr) 0 (cw ^. cwTiles)
glInvalidateBufferData floorbo
glNamedBufferStorage floorbo (fromIntegral $ 8 * nfloorvxs * floatSize) floorptr 0
glBindBufferBase GL_SHADER_STORAGE_BUFFER 8 floorbo
let chbo = rdata ^. chasmVBO . vboName
chbo = rdata ^. chasmVBO . vboName
chptr = rdata ^. chasmVBO . vboPtr
nchasmvxs <- foldM (pokeChasm chptr) 0 (cw ^. chasms)
glInvalidateBufferData floorbo
glInvalidateBufferData chbo
glNamedBufferStorage chbo (fromIntegral $ 2 * nchasmvxs * floatSize) chptr 0
glBindBufferBase GL_SHADER_STORAGE_BUFFER 7 chbo
withArray [floorbo,chbo] $ glDeleteBuffers 2
[newfloorbo,newchbo] <- glCreate glGenBuffers 2
nfloorvxs <- foldM (pokeTile floorptr) 0 (cw ^. uvWorld . cWorld . cwTiles)
glBindBufferBase GL_SHADER_STORAGE_BUFFER 8 newfloorbo
glNamedBufferStorage newfloorbo (fromIntegral $ 8 * nfloorvxs * floatSize) floorptr 0
nchasmvxs <- foldM (pokeChasm chptr) 0 (cw ^. uvWorld . cWorld . chasms)
glBindBufferBase GL_SHADER_STORAGE_BUFFER 7 newchbo
glNamedBufferStorage newchbo (fromIntegral $ 2 * nchasmvxs * floatSize) chptr 0
checkGLError "during postWorldLoad"
return $
cw & numberFloorVerxs .~ nfloorvxs
& numberChasmVerxs .~ nchasmvxs
cw & uvWorld . cWorld . numberFloorVerxs .~ nfloorvxs
& uvWorld . cWorld . numberChasmVerxs .~ nchasmvxs
& preloadData . renderData . floorVBO . vboName .~ newfloorbo
& preloadData . renderData . chasmVBO . vboName .~ newchbo